forked from GitHub/gf-core
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.
This commit is contained in:
bjorn
@@ -2,12 +2,30 @@ module Main where
|
|||||||
|
|
||||||
import GFC
|
import GFC
|
||||||
import GFI
|
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.Environment (getArgs)
|
||||||
|
import System.Exit
|
||||||
|
import System.IO
|
||||||
|
|
||||||
main :: IO ()
|
main :: IO ()
|
||||||
main = do
|
main =
|
||||||
args <- getArgs
|
do args <- getArgs
|
||||||
case args of
|
case parseOptions args of
|
||||||
"--batch":args -> mainGFC args
|
Ok (opts,files) -> mainOpts opts files
|
||||||
_ -> mainGFI args
|
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)
|
||||||
|
|
||||||
|
|||||||
@@ -156,5 +156,5 @@ allCommands mgr = Map.fromAscList [
|
|||||||
|
|
||||||
prGrammar opts = case valIdOpts "printer" "" opts of
|
prGrammar opts = case valIdOpts "printer" "" opts of
|
||||||
"cats" -> unwords $ categories mgr
|
"cats" -> unwords $ categories mgr
|
||||||
v -> prGFCC v gr
|
v -> prGFCC (read v) gr
|
||||||
|
|
||||||
|
|||||||
@@ -1,4 +1,4 @@
|
|||||||
module GF.Compile (batchCompile, compileToGFCC) where
|
module GF.Compile (batchCompile, link, compileToGFCC) where
|
||||||
|
|
||||||
-- the main compiler passes
|
-- the main compiler passes
|
||||||
import GF.Compile.GetGrammar
|
import GF.Compile.GetGrammar
|
||||||
@@ -44,25 +44,34 @@ compileToGFCC :: Options -> [FilePath] -> IOE GFCC
|
|||||||
compileToGFCC opts fs =
|
compileToGFCC opts fs =
|
||||||
do gr <- batchCompile opts fs
|
do gr <- batchCompile opts fs
|
||||||
let name = justModuleName (last fs)
|
let name = justModuleName (last fs)
|
||||||
gc1 <- putPointE opts "linking ... " $
|
link opts name gr
|
||||||
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 :: 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 :: Options -> [FilePath] -> IOE SourceGrammar
|
||||||
batchCompile opts files = do
|
batchCompile opts files = do
|
||||||
(_,gr,_) <- foldM (compileModule defOpts) emptyCompileEnv files
|
(_,gr,_) <- foldM (compileModule opts) emptyCompileEnv files
|
||||||
return gr
|
return gr
|
||||||
where
|
|
||||||
defOpts = addOptions opts (options [emitCode])
|
|
||||||
|
|
||||||
-- to output an intermediate stage
|
-- to output an intermediate stage
|
||||||
intermOut :: Options -> Option -> String -> IOE ()
|
intermOut :: Options -> Dump -> String -> IOE ()
|
||||||
intermOut opts opt s = if oElem opt opts then
|
intermOut opts d s = if dump opts d then
|
||||||
ioeIO (putStrLn ("\n\n--#" +++ prOpt opt) >> putStrLn s)
|
ioeIO (putStrLn ("\n\n--#" +++ show d) >> putStrLn s)
|
||||||
else return ()
|
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.
|
-- 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.
|
-- 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
|
compileModule opts1 env file = do
|
||||||
opts0 <- ioeIO $ getOptionsFromFile file
|
opts0 <- getOptionsFromFile file
|
||||||
let useFileOpt = maybe False (const True) $ getOptVal opts0 pathList
|
let opts = addOptions opts0 opts1
|
||||||
let useLineOpt = maybe False (const True) $ getOptVal opts1 pathList
|
let fdir = dropFileName file
|
||||||
let opts = addOptions opts1 opts0
|
let ps0 = moduleFlag optLibraryPath opts
|
||||||
let fpath = dropFileName file
|
ps2 <- ioeIO $ extendPathEnv $ fdir : ps0
|
||||||
ps0 <- ioeIO $ pathListOpts opts fpath
|
let ps = ps2 ++ map (fdir </>) ps0
|
||||||
|
ioeIO $ putIfVerb opts $ "module search path:" +++ show ps ----
|
||||||
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 ----
|
|
||||||
let (_,sgr,rfs) = env
|
let (_,sgr,rfs) = env
|
||||||
let file' = if useFileOpt then takeFileName file else file -- to find file itself
|
files <- getAllFiles opts ps rfs file
|
||||||
files <- getAllFiles opts ps rfs file'
|
ioeIO $ putIfVerb opts $ "files to read:" +++ show files ----
|
||||||
ioeIOIf $ putStrLn $ "files to read:" +++ show files ----
|
|
||||||
let names = map justModuleName 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
|
foldM (compileOne opts) (0,sgr,rfs) files
|
||||||
|
|
||||||
|
|
||||||
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
|
compileOne :: Options -> CompileEnv -> FullPath -> IOE CompileEnv
|
||||||
compileOne opts env@(_,srcgr,_) file = do
|
compileOne opts env@(_,srcgr,_) file = do
|
||||||
|
|
||||||
let putp s = putPointE opts s
|
let putp s = putPointE opts s
|
||||||
let putpp = putPointEsil opts
|
let putpp = putPointEsil opts
|
||||||
let putpOpt v m act
|
let putpOpt v m act
|
||||||
| oElem beVerbose opts = putp v act
|
| beVerbose opts = putp v act
|
||||||
| oElem beSilent opts = putpp v act
|
| beSilent opts = putpp v act
|
||||||
| otherwise = ioeIO (putStrFlush m) >> act
|
| otherwise = ioeIO (putStrFlush m) >> act
|
||||||
|
|
||||||
let gf = takeExtensions file
|
let gf = takeExtensions file
|
||||||
@@ -155,25 +157,25 @@ compileSourceModule opts env@(k,gr,_) mo@(i,mi) = do
|
|||||||
mos = modules gr
|
mos = modules gr
|
||||||
|
|
||||||
mo1 <- ioeErr $ rebuildModule mos mo
|
mo1 <- ioeErr $ rebuildModule mos mo
|
||||||
intermOut opts (iOpt "show_rebuild") (prModule mo1)
|
intermOut opts DumpRebuild (prModule mo1)
|
||||||
|
|
||||||
mo1b <- ioeErr $ extendModule mos mo1
|
mo1b <- ioeErr $ extendModule mos mo1
|
||||||
intermOut opts (iOpt "show_extend") (prModule mo1b)
|
intermOut opts DumpExtend (prModule mo1b)
|
||||||
|
|
||||||
case mo1b of
|
case mo1b of
|
||||||
(_,ModMod n) | not (isCompleteModule n) -> do
|
(_,ModMod n) | not (isCompleteModule n) -> do
|
||||||
return (k,mo1b) -- refresh would fail, since not renamed
|
return (k,mo1b) -- refresh would fail, since not renamed
|
||||||
_ -> do
|
_ -> do
|
||||||
mo2:_ <- putpp " renaming " $ ioeErr $ renameModule mos mo1b
|
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
|
(mo3:_,warnings) <- putpp " type checking" $ ioeErr $ showCheckModule mos mo2
|
||||||
if null warnings then return () else putp warnings $ return ()
|
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
|
(k',mo3r:_) <- putpp " refreshing " $ ioeErr $ refreshModule (k,mos) mo3
|
||||||
intermOut opts (iOpt "show_refresh") (prModule mo3r)
|
intermOut opts DumpRefresh (prModule mo3r)
|
||||||
|
|
||||||
let eenv = () --- emptyEEnv
|
let eenv = () --- emptyEEnv
|
||||||
(mo4,eenv') <-
|
(mo4,eenv') <-
|
||||||
@@ -197,9 +199,6 @@ generateModuleCode opts file minfo = do
|
|||||||
|
|
||||||
-- auxiliaries
|
-- auxiliaries
|
||||||
|
|
||||||
pathListOpts :: Options -> FileName -> IO [InitPath]
|
|
||||||
pathListOpts opts file = return $ maybe [file] splitInModuleSearchPath $ getOptVal opts pathList
|
|
||||||
|
|
||||||
reverseModules (MGrammar ms) = MGrammar $ reverse ms
|
reverseModules (MGrammar ms) = MGrammar $ reverse ms
|
||||||
|
|
||||||
emptyCompileEnv :: CompileEnv
|
emptyCompileEnv :: CompileEnv
|
||||||
|
|||||||
@@ -15,10 +15,11 @@
|
|||||||
-- following advice of Josef Svenningsson
|
-- 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.Grammar.Grammar
|
||||||
import GF.Infra.Ident
|
import GF.Infra.Ident
|
||||||
|
import GF.Infra.Option
|
||||||
import qualified GF.Grammar.Macros as C
|
import qualified GF.Grammar.Macros as C
|
||||||
import GF.Grammar.PrGrammar (prt)
|
import GF.Grammar.PrGrammar (prt)
|
||||||
import GF.Data.Operations
|
import GF.Data.Operations
|
||||||
@@ -26,25 +27,7 @@ import Data.List
|
|||||||
import qualified GF.Infra.Modules as M
|
import qualified GF.Infra.Modules as M
|
||||||
import qualified Data.ByteString.Char8 as BS
|
import qualified Data.ByteString.Char8 as BS
|
||||||
|
|
||||||
type OptSpec = [Integer] ---
|
type OptSpec = [Optimization]
|
||||||
|
|
||||||
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]
|
|
||||||
|
|
||||||
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
|
shareModule :: OptSpec -> (Ident, SourceModInfo) -> (Ident, SourceModInfo)
|
||||||
shareModule opt (i,m) = case m of
|
shareModule opt (i,m) = case m of
|
||||||
@@ -59,31 +42,8 @@ shareInfo _ i = i
|
|||||||
|
|
||||||
-- the function putting together optimizations
|
-- the function putting together optimizations
|
||||||
shareOptim :: OptSpec -> Ident -> Term -> Term
|
shareOptim :: OptSpec -> Ident -> Term -> Term
|
||||||
shareOptim opt c
|
shareOptim opt c = (if OptValues `elem` opt then values else id)
|
||||||
| doOptFactor opt && doOptValues opt = values . factor c 0
|
. (if OptParametrize `elem` opt then factor c 0 else id)
|
||||||
| 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]
|
|
||||||
|
|
||||||
-- do even more: factor parametric branches
|
-- do even more: factor parametric branches
|
||||||
|
|
||||||
|
|||||||
@@ -39,15 +39,17 @@ import System.Cmd (system)
|
|||||||
|
|
||||||
getSourceModule :: Options -> FilePath -> IOE SourceModule
|
getSourceModule :: Options -> FilePath -> IOE SourceModule
|
||||||
getSourceModule opts file0 = do
|
getSourceModule opts file0 = do
|
||||||
file <- case getOptVal opts usePreprocessor of
|
file <- foldM runPreprocessor file0 (moduleFlag optPreprocessors opts)
|
||||||
Just p -> do
|
|
||||||
let tmp = "_gf_preproc.tmp"
|
|
||||||
cmd = p +++ file0 ++ ">" ++ tmp
|
|
||||||
ioeIO $ system cmd
|
|
||||||
-- ioeIO $ putStrLn $ "preproc" +++ cmd
|
|
||||||
return tmp
|
|
||||||
_ -> return file0
|
|
||||||
string <- readFileIOE file
|
string <- readFileIOE file
|
||||||
let tokens = myLexer string
|
let tokens = myLexer string
|
||||||
mo1 <- ioeErr $ pModDef tokens
|
mo1 <- ioeErr $ pModDef tokens
|
||||||
ioeErr $ transModDef mo1
|
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
|
||||||
|
|||||||
@@ -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 :: Options -> (Ident -> Ident -> C.Term) -> SourceGrammar -> D.GFCC
|
||||||
canon2gfcc opts pars cgr@(M.MGrammar ((a,M.ModMod abm):cms)) =
|
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
|
D.GFCC an cns gflags abs cncs
|
||||||
where
|
where
|
||||||
-- abstract
|
-- abstract
|
||||||
an = (i2i a)
|
an = (i2i a)
|
||||||
cns = map (i2i . fst) cms
|
cns = map (i2i . fst) cms
|
||||||
abs = D.Abstr aflags funs cats catfuns
|
abs = D.Abstr aflags funs cats catfuns
|
||||||
gflags = Map.fromList [(mkCId fg,x) | Just x <- [getOptVal opts (aOpt fg)]]
|
gflags = Map.empty
|
||||||
where fg = "firstlang"
|
aflags = Map.fromList [(mkCId f,x) | (f,x) <- moduleOptionsGFO (M.flags abm)]
|
||||||
aflags = Map.fromList [(mkCId f,x) | Opt (f,[x]) <- M.flags abm]
|
|
||||||
mkDef pty = case pty of
|
mkDef pty = case pty of
|
||||||
Yes t -> mkExp t
|
Yes t -> mkExp t
|
||||||
_ -> CM.primNotion
|
_ -> 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)
|
(lang,D.Concr flags lins opers lincats lindefs printnames params fcfg)
|
||||||
where
|
where
|
||||||
js = tree2list (M.jments mo)
|
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
|
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
|
then D.convertStringsInTerm decodeUTF8 else id
|
||||||
lins = Map.fromAscList
|
lins = Map.fromAscList
|
||||||
[(i2i f, utf (mkTerm tr)) | (f,CncFun _ (Yes tr) _) <- js]
|
[(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 ++ Look.allOrigInfos cg abs
|
||||||
predefADefs =
|
predefADefs =
|
||||||
[(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]]
|
[(c, AbsCat (Yes []) Nope) | c <- [cFloat,cInt,cString]]
|
||||||
aflags = nubFlags $
|
aflags =
|
||||||
concat [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
|
concatModuleOptions [M.flags mo | (_,mo) <- M.allModMod cg, M.isModAbs mo]
|
||||||
|
|
||||||
cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs]
|
cncs = sortIds [(lang, concr lang) | lang <- M.allConcretes cg abs]
|
||||||
concr la = (nubFlags flags,
|
concr la = (flags,
|
||||||
sortIds (predefCDefs ++ jments)) where
|
sortIds (predefCDefs ++ jments)) where
|
||||||
jments = Look.allOrigInfos cg la
|
jments = Look.allOrigInfos cg la
|
||||||
flags = concat [M.flags mo |
|
flags = concatModuleOptions
|
||||||
|
[M.flags mo |
|
||||||
(i,mo) <- mos, M.isModCnc mo,
|
(i,mo) <- mos, M.isModCnc mo,
|
||||||
Just r <- [lookup i (M.allExtendSpecs cg la)]]
|
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]]
|
[(c, CncCat (Yes GM.defLinType) Nope Nope) | c <- [cInt,cFloat,cString]]
|
||||||
|
|
||||||
sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
|
sortIds = sortBy (\ (f,_) (g,_) -> compare f g)
|
||||||
nubFlags = nubBy (\ (Opt (f,_)) (Opt (g,_)) -> f == g)
|
|
||||||
|
|
||||||
|
|
||||||
-- one grammar per language - needed for symtab generation
|
-- one grammar per language - needed for symtab generation
|
||||||
|
|||||||
@@ -43,9 +43,6 @@ import Debug.Trace
|
|||||||
prtIf :: (Print a) => Bool -> a -> a
|
prtIf :: (Print a) => Bool -> a -> a
|
||||||
prtIf b t = if b then trace (" " ++ prt t) t else t
|
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.
|
-- | partial evaluation of concrete syntax. AR 6\/2001 -- 16\/5\/2003 -- 5\/2\/2005.
|
||||||
|
|
||||||
type EEnv = () --- not used
|
type EEnv = () --- not used
|
||||||
@@ -55,28 +52,21 @@ optimizeModule :: Options -> ([(Ident,SourceModInfo)],EEnv) ->
|
|||||||
(Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
|
(Ident,SourceModInfo) -> Err ((Ident,SourceModInfo),EEnv)
|
||||||
optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
|
optimizeModule opts mse@(ms,eenv) mo@(_,mi) = case mi of
|
||||||
ModMod m0@(Module mt st fs me ops js) |
|
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
|
(mo1,_) <- evalModule oopts mse mo
|
||||||
let
|
let mo2 = shareModule optim mo1
|
||||||
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
|
|
||||||
return (mo2,eenv)
|
return (mo2,eenv)
|
||||||
_ -> evalModule oopts mse mo
|
_ -> evalModule oopts mse mo
|
||||||
where
|
where
|
||||||
oopts = addOptions opts (iOpts (flagsModule mo))
|
oopts = addOptions opts (moduleOptions (flagsModule mo))
|
||||||
optim = maybe "all" id $ getOptVal oopts useOptimizer
|
optim = moduleFlag optOptimizations oopts
|
||||||
|
|
||||||
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
|
evalModule :: Options -> ([(Ident,SourceModInfo)],EEnv) -> (Ident,SourceModInfo) ->
|
||||||
Err ((Ident,SourceModInfo),EEnv)
|
Err ((Ident,SourceModInfo),EEnv)
|
||||||
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
|
evalModule oopts (ms,eenv) mo@(name,mod) = case mod of
|
||||||
|
|
||||||
ModMod m0@(Module mt st fs me ops js) | st == MSComplete -> case mt 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
|
let deps = allOperDependencies name js
|
||||||
ids <- topoSortOpers deps
|
ids <- topoSortOpers deps
|
||||||
MGrammar (mod' : _) <- foldM evalOp gr ids
|
MGrammar (mod' : _) <- foldM evalOp gr ids
|
||||||
@@ -112,17 +102,15 @@ evalResInfo oopts gr (c,info) = case info of
|
|||||||
where
|
where
|
||||||
comp = if optres then computeConcrete gr else computeConcreteRec gr
|
comp = if optres then computeConcrete gr else computeConcreteRec gr
|
||||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||||
optim = maybe "all" id $ getOptVal oopts useOptimizer
|
optim = moduleFlag optOptimizations oopts
|
||||||
optres = case optim of
|
optres = OptExpand `elem` optim
|
||||||
"noexpand" -> False
|
|
||||||
_ -> True
|
|
||||||
|
|
||||||
|
|
||||||
evalCncInfo ::
|
evalCncInfo ::
|
||||||
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
|
Options -> SourceGrammar -> Ident -> Ident -> (Ident,Info) -> Err (Ident,Info)
|
||||||
evalCncInfo opts gr cnc abs (c,info) = do
|
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
|
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 ->
|
CncFun (mt@(Just (_,ty@(cont,val)))) pde ppr ->
|
||||||
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
|
eIn ("linearization in type" +++ prt (mkProd (cont,val,[])) ++++ "of function") $ do
|
||||||
pde' <- case pde of
|
pde' <- case pde of
|
||||||
Yes de | notNewEval -> do
|
Yes de -> do
|
||||||
liftM yes $ pEval ty de
|
liftM yes $ pEval ty de
|
||||||
|
|
||||||
_ -> return pde
|
_ -> return pde
|
||||||
@@ -154,7 +142,6 @@ evalCncInfo opts gr cnc abs (c,info) = do
|
|||||||
where
|
where
|
||||||
pEval = partEval opts gr
|
pEval = partEval opts gr
|
||||||
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
eIn cat = errIn ("Error optimizing" +++ cat +++ prt c +++ ":")
|
||||||
notNewEval = not (oElem oEval opts)
|
|
||||||
|
|
||||||
-- | the main function for compiling linearizations
|
-- | the main function for compiling linearizations
|
||||||
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
|
partEval :: Options -> SourceGrammar -> (Context,Type) -> Term -> Err Term
|
||||||
|
|||||||
@@ -19,8 +19,9 @@
|
|||||||
-----------------------------------------------------------------------------
|
-----------------------------------------------------------------------------
|
||||||
|
|
||||||
module GF.Compile.ReadFiles
|
module GF.Compile.ReadFiles
|
||||||
( getAllFiles,ModName,ModEnv,getOptionsFromFile,importsOfModule,
|
( getAllFiles,ModName,ModEnv,importsOfModule,
|
||||||
gfoFile,gfFile,isGFO ) where
|
gfoFile,gfFile,isGFO,
|
||||||
|
getOptionsFromFile) where
|
||||||
|
|
||||||
import GF.Infra.UseIO
|
import GF.Infra.UseIO
|
||||||
import GF.Infra.Option
|
import GF.Infra.Option
|
||||||
@@ -48,9 +49,7 @@ getAllFiles :: Options -> [InitPath] -> ModEnv -> FileName -> IOE [FullPath]
|
|||||||
getAllFiles opts ps env file = do
|
getAllFiles opts ps env file = do
|
||||||
-- read module headers from all files recursively
|
-- read module headers from all files recursively
|
||||||
ds <- liftM reverse $ get [] [] (justModuleName file)
|
ds <- liftM reverse $ get [] [] (justModuleName file)
|
||||||
if oElem beVerbose opts
|
ioeIO $ putIfVerb opts $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
|
||||||
then ioeIO $ putStrLn $ "all modules:" +++ show [name | (name,_,_,_,_) <- ds]
|
|
||||||
else return ()
|
|
||||||
return $ paths ds
|
return $ paths ds
|
||||||
where
|
where
|
||||||
-- construct list of paths to read
|
-- construct list of paths to read
|
||||||
@@ -135,8 +134,8 @@ selectFormat opts mtenv mtgf mtgfo =
|
|||||||
(_,_, Nothing) -> (CSRead,Nothing) -- source does not exist
|
(_,_, Nothing) -> (CSRead,Nothing) -- source does not exist
|
||||||
_ -> (CSComp,Nothing)
|
_ -> (CSComp,Nothing)
|
||||||
where
|
where
|
||||||
fromComp = oElem isCompiled opts -- i -gfo
|
fromComp = flag optRecomp opts == NeverRecomp
|
||||||
fromSrc = oElem fromSource opts
|
fromSrc = flag optRecomp opts == AlwaysRecomp
|
||||||
|
|
||||||
|
|
||||||
-- internal module dep information
|
-- 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
|
-- | 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
|
getOptionsFromFile file = do
|
||||||
s <- readFileIfStrict file
|
s <- ioeIO $ readFileIfStrict file
|
||||||
let ls = filter (BS.isPrefixOf (BS.pack "--#")) $ BS.lines s
|
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
|
||||||
|
|||||||
@@ -23,6 +23,7 @@ import GF.Grammar.Macros
|
|||||||
|
|
||||||
import GF.Infra.Ident
|
import GF.Infra.Ident
|
||||||
import GF.Infra.Modules
|
import GF.Infra.Modules
|
||||||
|
import GF.Infra.Option
|
||||||
import GF.Data.Operations
|
import GF.Data.Operations
|
||||||
|
|
||||||
import Data.List (nub)
|
import Data.List (nub)
|
||||||
@@ -76,7 +77,7 @@ rebuildModule ms mo@(i,mi) = do
|
|||||||
++ [oSimple i | i <- map snd insts] ----
|
++ [oSimple i | i <- map snd insts] ----
|
||||||
|
|
||||||
--- check if me is incomplete
|
--- 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 js0 = [ci | ci@(c,_) <- tree2list js, isInherited incl c]
|
||||||
let js1 = buildTree (tree2list js_ ++ js0)
|
let js1 = buildTree (tree2list js_ ++ js0)
|
||||||
return $ ModMod $ Module mt0 stat' fs1 me ops1 js1
|
return $ ModMod $ Module mt0 stat' fs1 me ops1 js1
|
||||||
|
|||||||
@@ -13,7 +13,10 @@ import qualified Data.Map as Map
|
|||||||
-- suffix analysis followed by common subexpression elimination
|
-- suffix analysis followed by common subexpression elimination
|
||||||
|
|
||||||
optGFCC :: GFCC -> GFCC
|
optGFCC :: GFCC -> GFCC
|
||||||
optGFCC gfcc = gfcc {
|
optGFCC = cseOptimize . suffixOptimize
|
||||||
|
|
||||||
|
suffixOptimize :: GFCC -> GFCC
|
||||||
|
suffixOptimize gfcc = gfcc {
|
||||||
concretes = Map.map opt (concretes gfcc)
|
concretes = Map.map opt (concretes gfcc)
|
||||||
}
|
}
|
||||||
where
|
where
|
||||||
@@ -23,6 +26,11 @@ optGFCC gfcc = gfcc {
|
|||||||
printnames = Map.map optTerm (printnames cnc)
|
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
|
-- analyse word form lists into prefix + suffixes
|
||||||
-- suffix sets can later be shared by subex elim
|
-- suffix sets can later be shared by subex elim
|
||||||
|
|
||||||
|
|||||||
@@ -5,16 +5,17 @@ import GF.GFCC.Raw.ConvertGFCC (fromGFCC)
|
|||||||
import GF.GFCC.Raw.PrintGFCCRaw (printTree)
|
import GF.GFCC.Raw.PrintGFCCRaw (printTree)
|
||||||
import GF.GFCC.GFCCtoHaskell
|
import GF.GFCC.GFCCtoHaskell
|
||||||
import GF.GFCC.GFCCtoJS
|
import GF.GFCC.GFCCtoJS
|
||||||
|
import GF.Infra.Option
|
||||||
import GF.Text.UTF8
|
import GF.Text.UTF8
|
||||||
|
|
||||||
-- top-level access to code generation
|
-- top-level access to code generation
|
||||||
|
|
||||||
prGFCC :: String -> GFCC -> String
|
prGFCC :: OutputFormat -> GFCC -> String
|
||||||
prGFCC printer gr = case printer of
|
prGFCC fmt gr = case fmt of
|
||||||
"haskell" -> grammar2haskell gr
|
FmtGFCC -> printGFCC gr
|
||||||
"haskell_gadt" -> grammar2haskellGADT gr
|
FmtJavaScript -> gfcc2js gr
|
||||||
"js" -> gfcc2js gr
|
FmtHaskell -> grammar2haskell gr
|
||||||
_ -> printGFCC gr
|
FmtHaskellGADT -> grammar2haskellGADT gr
|
||||||
|
|
||||||
printGFCC :: GFCC -> String
|
printGFCC :: GFCC -> String
|
||||||
printGFCC = encodeUTF8 . printTree . fromGFCC
|
printGFCC = encodeUTF8 . printTree . fromGFCC
|
||||||
|
|||||||
@@ -5,7 +5,8 @@ module GF.Grammar.API (
|
|||||||
prTerm,
|
prTerm,
|
||||||
checkTerm,
|
checkTerm,
|
||||||
computeTerm,
|
computeTerm,
|
||||||
showTerm
|
showTerm,
|
||||||
|
TermPrintStyle(..)
|
||||||
) where
|
) where
|
||||||
|
|
||||||
import GF.Source.ParGF
|
import GF.Source.ParGF
|
||||||
@@ -52,9 +53,15 @@ checkTermAny gr m t = do
|
|||||||
computeTerm :: Grammar -> Term -> Err Term
|
computeTerm :: Grammar -> Term -> Err Term
|
||||||
computeTerm = computeConcrete
|
computeTerm = computeConcrete
|
||||||
|
|
||||||
showTerm :: Options -> Term -> String
|
showTerm :: TermPrintStyle -> Term -> String
|
||||||
showTerm opts t
|
showTerm style t =
|
||||||
| oElem (iOpt "table") opts = unlines [p +++ s | (p,s) <- prTermTabular t]
|
case style of
|
||||||
| oElem (iOpt "all") opts = unlines [ s | (p,s) <- prTermTabular t]
|
TermPrintTable -> unlines [p +++ s | (p,s) <- prTermTabular t]
|
||||||
| oElem (iOpt "unqual") opts = prt_ t
|
TermPrintAll -> unlines [ s | (p,s) <- prTermTabular t]
|
||||||
| otherwise = prt t
|
TermPrintUnqual -> prt_ t
|
||||||
|
TermPrintDefault -> prt t
|
||||||
|
|
||||||
|
|
||||||
|
data TermPrintStyle = TermPrintTable | TermPrintAll | TermPrintUnqual | TermPrintDefault
|
||||||
|
deriving (Show,Eq)
|
||||||
|
|
||||||
|
|||||||
@@ -233,7 +233,7 @@ prExp e = case e of
|
|||||||
|
|
||||||
-- | option @-strip@ strips qualifications
|
-- | option @-strip@ strips qualifications
|
||||||
prTermOpt :: Options -> Term -> String
|
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
|
-- | to get rid of brackets in the editor
|
||||||
prRefinement :: Term -> String
|
prRefinement :: Term -> String
|
||||||
|
|||||||
381
src-3.0/GF/Infra/GetOpt.hs
Normal file
381
src-3.0/GF/Infra/GetOpt.hs
Normal file
@@ -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.
|
||||||
|
|
||||||
|
-}
|
||||||
@@ -65,7 +65,7 @@ data ModInfo i a =
|
|||||||
data Module i a = Module {
|
data Module i a = Module {
|
||||||
mtype :: ModuleType i ,
|
mtype :: ModuleType i ,
|
||||||
mstatus :: ModuleStatus ,
|
mstatus :: ModuleStatus ,
|
||||||
flags :: [Option] ,
|
flags :: ModuleOptions,
|
||||||
extend :: [(i,MInclude i)],
|
extend :: [(i,MInclude i)],
|
||||||
opens :: [OpenSpec i] ,
|
opens :: [OpenSpec i] ,
|
||||||
jments :: BinTree i a
|
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) =
|
addOpenQualif i j (Module mt ms fs me ops js) =
|
||||||
Module mt ms fs me (oQualif i j : ops) js
|
Module mt ms fs me (oQualif i j : ops) js
|
||||||
|
|
||||||
addFlag :: Option -> Module i t -> Module i t
|
addFlag :: ModuleOptions -> Module i t -> Module i t
|
||||||
addFlag f mo = mo {flags = f : flags mo}
|
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
|
flagsModule (_,mi) = case mi of
|
||||||
ModMod m -> flags m
|
ModMod m -> flags m
|
||||||
_ -> []
|
_ -> noModuleOptions
|
||||||
|
|
||||||
allFlags :: MGrammar i a -> [Option]
|
allFlags :: MGrammar i a -> ModuleOptions
|
||||||
allFlags gr = concat $ map flags $ [m | (_, ModMod m) <- modules gr]
|
allFlags gr = concatModuleOptions $ map flags $ [m | (_, ModMod m) <- modules gr]
|
||||||
|
|
||||||
mapModules :: (Module i a -> Module i a)
|
mapModules :: (Module i a -> Module i a)
|
||||||
-> MGrammar i a -> MGrammar i a
|
-> MGrammar i a -> MGrammar i a
|
||||||
@@ -267,7 +267,7 @@ emptyModInfo :: ModInfo i a
|
|||||||
emptyModInfo = ModMod emptyModule
|
emptyModInfo = ModMod emptyModule
|
||||||
|
|
||||||
emptyModule :: Module i a
|
emptyModule :: Module i a
|
||||||
emptyModule = Module MTResource MSComplete [] [] [] emptyBinTree
|
emptyModule = Module MTResource MSComplete noModuleOptions [] [] emptyBinTree
|
||||||
|
|
||||||
-- | we store the module type with the identifier
|
-- | we store the module type with the identifier
|
||||||
data IdentM i = IdentM {
|
data IdentM i = IdentM {
|
||||||
|
|||||||
@@ -1,375 +1,464 @@
|
|||||||
----------------------------------------------------------------------
|
module GF.Infra.Option
|
||||||
-- |
|
(
|
||||||
-- Module : Option
|
-- * Option types
|
||||||
-- Maintainer : AR
|
Options, ModuleOptions,
|
||||||
-- Stability : (stable)
|
Flags(..), ModuleFlags(..),
|
||||||
-- Portability : (portable)
|
Mode(..), Phase(..), Encoding(..), OutputFormat(..), Optimization(..),
|
||||||
--
|
Dump(..), Printer(..), Recomp(..),
|
||||||
-- > CVS $Date: 2005/11/14 16:03:41 $
|
-- * Option parsing
|
||||||
-- > CVS $Author: aarne $
|
parseOptions, parseModuleOptions,
|
||||||
-- > CVS $Revision: 1.34 $
|
-- * Option pretty-printing
|
||||||
--
|
moduleOptionsGFO,
|
||||||
-- Options and flags used in GF shell commands and files.
|
-- * Option manipulation
|
||||||
--
|
addOptions, concatOptions, noOptions,
|
||||||
-- The types 'Option' and 'Options' should be kept abstract, but:
|
moduleOptions,
|
||||||
--
|
addModuleOptions, concatModuleOptions, noModuleOptions,
|
||||||
-- - The constructor 'Opt' is used in "ShellCommands" and "GrammarToSource"
|
helpMessage,
|
||||||
--
|
-- * Checking options
|
||||||
-- - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands"
|
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 GF.Data.ErrM
|
||||||
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)
|
|
||||||
|
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 :: Options
|
||||||
noOptions = Opts []
|
noOptions = Options id
|
||||||
|
|
||||||
-- | simple option -o
|
addOptions :: Options -- ^ Existing options.
|
||||||
iOpt :: String -> Option
|
-> Options -- ^ Options to add (these take preference).
|
||||||
iOpt o = Opt (o,[])
|
-> Options
|
||||||
|
addOptions (Options o1) (Options o2) = Options (o2 . o1)
|
||||||
-- | 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
|
|
||||||
|
|
||||||
concatOptions :: [Options] -> Options
|
concatOptions :: [Options] -> Options
|
||||||
concatOptions = foldr addOptions noOptions
|
concatOptions = foldr addOptions noOptions
|
||||||
|
|
||||||
removeOption :: Option -> Options -> Options
|
moduleOptions :: ModuleOptions -> Options
|
||||||
removeOption o (Opts os) = iOpts (filter (/=o) os)
|
moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) })
|
||||||
|
|
||||||
removeOptions :: Options -> Options -> Options
|
addModuleOptions :: ModuleOptions -- ^ Existing options.
|
||||||
removeOptions (Opts os) os0 = foldr removeOption os0 os
|
-> ModuleOptions -- ^ Options to add (these take preference).
|
||||||
|
-> ModuleOptions
|
||||||
|
addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1)
|
||||||
|
|
||||||
options :: [Option] -> Options
|
concatModuleOptions :: [ModuleOptions] -> ModuleOptions
|
||||||
options = foldr addOption noOptions
|
concatModuleOptions = foldr addModuleOptions noModuleOptions
|
||||||
|
|
||||||
unionOptions :: Options -> Options -> Options
|
noModuleOptions :: ModuleOptions
|
||||||
unionOptions (Opts os) (Opts os') = Opts (os ++ os')
|
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])
|
moduleFlag :: (ModuleFlags -> a) -> Options -> a
|
||||||
getOptions pre inp = let
|
moduleFlag f = flag (f . optModuleFlags)
|
||||||
(os,rest) = span (isOption pre) inp -- options before args
|
|
||||||
in
|
|
||||||
(Opts (map (pOption pre) os), rest)
|
|
||||||
|
|
||||||
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"
|
parseModuleFlags :: Options -> [(String,Maybe String)] -> Err ModuleOptions
|
||||||
useParserMCFGviaCFG = iOpt "mcfg-via-cfg"
|
parseModuleFlags opts flags =
|
||||||
useParserCFG = iOpt "cfg"
|
mapM (uncurry (findFlag moduleOptDescr)) flags >>= foldM (flip ($)) (optModuleOptions opts)
|
||||||
useParserCF = iOpt "cf"
|
|
||||||
|
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,
|
defaultModuleFlags :: ModuleFlags
|
||||||
showEBNF, showCF, showWords, showOpts,
|
defaultModuleFlags = ModuleFlags {
|
||||||
isCompiled, isHaskell, noCompOpers, retainOpers,
|
optName = Nothing,
|
||||||
noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option
|
optAbsName = Nothing,
|
||||||
defaultGrOpts :: [Option]
|
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"
|
defaultFlags :: Flags
|
||||||
showXML = iOpt "xml"
|
defaultFlags = Flags {
|
||||||
showOld = iOpt "old"
|
optMode = ModeInteractive,
|
||||||
showLatex = iOpt "latex"
|
optStopAfterPhase = Compile,
|
||||||
showFullForm = iOpt "fullform"
|
optVerbosity = 1,
|
||||||
showEBNF = iOpt "ebnf"
|
optShowCPUTime = False,
|
||||||
showCF = iOpt "cf"
|
optEmitGFO = True,
|
||||||
showWords = iOpt "ws"
|
optGFODir = ".",
|
||||||
showOpts = iOpt "opts"
|
optOutputFormats = [FmtGFCC],
|
||||||
-- showOptim = iOpt "opt"
|
optOutputFile = Nothing,
|
||||||
isCompiled = iOpt "gfc"
|
optOutputDir = Nothing,
|
||||||
isHaskell = iOpt "gfhs"
|
optRecomp = RecompIfNewer,
|
||||||
noCompOpers = iOpt "nocomp"
|
optPrinter = [],
|
||||||
retainOpers = iOpt "retain"
|
optProb = False,
|
||||||
defaultGrOpts = []
|
optRetainResource = False,
|
||||||
noCF = iOpt "nocf"
|
optModuleFlags = defaultModuleFlags
|
||||||
checkCirc = iOpt "nocirc"
|
}
|
||||||
noCheckCirc = iOpt "nocheckcirc"
|
|
||||||
lexerByNeed = iOpt "cflexer"
|
|
||||||
useUTF8id = iOpt "utf8id"
|
|
||||||
elimSubs = iOpt "subs"
|
|
||||||
|
|
||||||
-- ** linearization
|
-- Option descriptions
|
||||||
|
|
||||||
allLin, firstLin, distinctLin, dontLin,
|
moduleOptDescr :: [OptDescr (Err ModuleOptions)]
|
||||||
showRecord, showStruct, xmlLin, latexLin,
|
moduleOptDescr =
|
||||||
tableLin, useUTF8, showLang, withMetas :: Option
|
[
|
||||||
defaultLinOpts :: [Option]
|
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"
|
optimize x = case lookup x optimizationPackages of
|
||||||
firstLin = iOpt "one"
|
Just p -> set $ \o -> o { optOptimizations = p }
|
||||||
distinctLin = iOpt "nub"
|
Nothing -> fail $ "Unknown optimization package: " ++ x
|
||||||
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
|
toggleOptimize x b = set $ \o -> o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) }
|
||||||
|
|
||||||
beVerbose, showInfo, beSilent, emitCode, getHelp,
|
dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
|
||||||
doMake, doBatch, notEmitCode, makeMulti, beShort,
|
|
||||||
wholeGrammar, makeFudget, byLines, byWords, analMorpho,
|
|
||||||
doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
|
|
||||||
stripQualif, nostripQualif, showAll, fromSource :: Option
|
|
||||||
|
|
||||||
beVerbose = iOpt "v"
|
set = return . ModuleOptions
|
||||||
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
|
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"
|
instance Functor OptDescr where
|
||||||
optCompute = iOpt "compute"
|
fmap f (Option cs ss d s) = Option cs ss (fmap f d) s
|
||||||
optCheck = iOpt "typecheck"
|
|
||||||
optParaphrase = iOpt "paraphrase"
|
|
||||||
forJava = iOpt "java"
|
|
||||||
|
|
||||||
-- ** 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"
|
instance Show OutputFormat where
|
||||||
absView = iOpt "Abs"
|
show = lookupShow outputFormats
|
||||||
|
|
||||||
-- ** options that take arguments
|
instance Read OutputFormat where
|
||||||
|
readsPrec = lookupReadsPrec outputFormats
|
||||||
|
|
||||||
useTokenizer, useUntokenizer, useParser, withFun,
|
optimizationPackages :: [(String,[Optimization])]
|
||||||
useLanguage, useResource, speechLanguage, useFont,
|
optimizationPackages =
|
||||||
grammarFormat, grammarPrinter, filterString, termCommand,
|
[("all_subs", [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), -- deprecated
|
||||||
transferFun, forForms, menuDisplay, sizeDisplay, typeDisplay,
|
("all", [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]),
|
||||||
noDepTypes, extractGr, pathList, uniCoding :: String -> Option
|
("values", [OptStem,OptCSE,OptExpand,OptValues]),
|
||||||
-- | used on command line
|
("parametrize", [OptStem,OptCSE,OptExpand,OptParametrize]),
|
||||||
firstCat :: String -> Option
|
("none", [OptStem,OptCSE,OptExpand]),
|
||||||
-- | used in grammar, to avoid clash w res word
|
("noexpand", [OptStem,OptCSE])]
|
||||||
gStartCat :: String -> Option
|
|
||||||
|
|
||||||
useTokenizer = aOpt "lexer"
|
encodings :: [(String,Encoding)]
|
||||||
useUntokenizer = aOpt "unlexer"
|
encodings =
|
||||||
useParser = aOpt "parser"
|
[("utf8", UTF_8),
|
||||||
-- useStrategy = aOpt "strategy" -- parsing strategy
|
("latin1", ISO_8859_1)]
|
||||||
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:
|
lookupShow :: Eq a => [(String,a)] -> a -> String
|
||||||
gfcConversion :: String -> Option
|
lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs]
|
||||||
gfcConversion = aOpt "conversion"
|
|
||||||
|
|
||||||
useName, useAbsName, useCncName, useResName,
|
lookupReadsPrec :: [(String,a)] -> Int -> ReadS a
|
||||||
useFile, useOptimizer :: String -> Option
|
lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x]
|
||||||
|
|
||||||
useName = aOpt "name"
|
onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a)
|
||||||
useAbsName = aOpt "abs"
|
onOff f def = OptArg g "[on,off]"
|
||||||
useCncName = aOpt "cnc"
|
where g ma = maybe (return def) readOnOff ma >>= f
|
||||||
useResName = aOpt "res"
|
readOnOff x = case map toLower x of
|
||||||
useFile = aOpt "file"
|
"on" -> return True
|
||||||
useOptimizer = aOpt "optimize"
|
"off" -> return False
|
||||||
|
_ -> fail $ "Expected [on,off], got: " ++ show x
|
||||||
|
|
||||||
markLin :: String -> Option
|
readOutputFormat :: Monad m => String -> m OutputFormat
|
||||||
markOptXML, markOptJava, markOptStruct, markOptFocus :: String
|
readOutputFormat s =
|
||||||
|
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
|
||||||
|
|
||||||
markLin = aOpt "mark"
|
-- FIXME: this is a copy of the function in GF.Devel.UseIO.
|
||||||
markOptXML = oArg "xml"
|
splitInModuleSearchPath :: String -> [FilePath]
|
||||||
markOptJava = oArg "java"
|
splitInModuleSearchPath s = case break isPathSep s of
|
||||||
markOptStruct = oArg "struct"
|
(f,_:cs) -> f : splitInModuleSearchPath cs
|
||||||
markOptFocus = oArg "focus"
|
(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
|
beSilent :: Options -> Bool
|
||||||
firstRefine, lastRefine :: String
|
beSilent = flag ((<= 0) . optVerbosity)
|
||||||
|
|
||||||
nextRefine = aOpt "nextrefine"
|
dump :: Options -> Dump -> Bool
|
||||||
firstRefine = oArg "first"
|
dump opts d = moduleFlag ((d `elem`) . optDump) opts
|
||||||
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
|
|
||||||
|
|||||||
@@ -24,6 +24,7 @@ import System.FilePath
|
|||||||
import System.IO
|
import System.IO
|
||||||
import System.IO.Error
|
import System.IO.Error
|
||||||
import System.Environment
|
import System.Environment
|
||||||
|
import System.Exit
|
||||||
import System.CPUTime
|
import System.CPUTime
|
||||||
import Control.Monad
|
import Control.Monad
|
||||||
import Control.Exception(evaluate)
|
import Control.Exception(evaluate)
|
||||||
@@ -39,20 +40,16 @@ putShow' f = putStrLn . show . length . show . f
|
|||||||
|
|
||||||
putIfVerb :: Options -> String -> IO ()
|
putIfVerb :: Options -> String -> IO ()
|
||||||
putIfVerb opts msg =
|
putIfVerb opts msg =
|
||||||
if oElem beVerbose opts
|
if beVerbose opts
|
||||||
then putStrLn msg
|
then putStrLn msg
|
||||||
else return ()
|
else return ()
|
||||||
|
|
||||||
putIfVerbW :: Options -> String -> IO ()
|
putIfVerbW :: Options -> String -> IO ()
|
||||||
putIfVerbW opts msg =
|
putIfVerbW opts msg =
|
||||||
if oElem beVerbose opts
|
if beVerbose opts
|
||||||
then putStr (' ' : msg)
|
then putStr (' ' : msg)
|
||||||
else return ()
|
else return ()
|
||||||
|
|
||||||
-- | obsolete with IOE monad
|
|
||||||
errIO :: a -> Err a -> IO a
|
|
||||||
errIO = errOptIO noOptions
|
|
||||||
|
|
||||||
errOptIO :: Options -> a -> Err a -> IO a
|
errOptIO :: Options -> a -> Err a -> IO a
|
||||||
errOptIO os e m = case m of
|
errOptIO os e m = case m of
|
||||||
Ok x -> return x
|
Ok x -> return x
|
||||||
@@ -235,6 +232,13 @@ foldIOE f s xs = case xs of
|
|||||||
Ok v -> foldIOE f v xx
|
Ok v -> foldIOE f v xx
|
||||||
Bad m -> return $ (s, Just m)
|
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 :: String -> IOE ()
|
||||||
putStrLnE = ioeIO . putStrLnFlush
|
putStrLnE = ioeIO . putStrLnFlush
|
||||||
|
|
||||||
@@ -243,28 +247,27 @@ putStrE = ioeIO . putStrFlush
|
|||||||
|
|
||||||
-- this is more verbose
|
-- this is more verbose
|
||||||
putPointE :: Options -> String -> IOE a -> IOE a
|
putPointE :: Options -> String -> IOE a -> IOE a
|
||||||
putPointE = putPointEgen (oElem beSilent)
|
putPointE = putPointEgen beSilent
|
||||||
|
|
||||||
-- this is less verbose
|
-- this is less verbose
|
||||||
putPointEsil :: Options -> String -> IOE a -> IOE a
|
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 :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a
|
||||||
putPointEgen cond opts msg act = do
|
putPointEgen cond opts msg act = do
|
||||||
let ve x = if cond opts then return () else x
|
when (cond opts) $ ioeIO $ putStrFlush msg
|
||||||
ve $ ioeIO $ putStrFlush msg
|
|
||||||
|
|
||||||
t1 <- ioeIO $ getCPUTime
|
t1 <- ioeIO $ getCPUTime
|
||||||
a <- act >>= ioeIO . evaluate
|
a <- act >>= ioeIO . evaluate
|
||||||
t2 <- ioeIO $ getCPUTime
|
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
|
return a
|
||||||
|
|
||||||
|
|
||||||
-- | forces verbosity
|
-- | forces verbosity
|
||||||
putPointEVerb :: Options -> String -> IOE a -> IOE a
|
putPointEVerb :: Options -> String -> IOE a -> IOE a
|
||||||
putPointEVerb opts = putPointE (addOption beVerbose opts)
|
putPointEVerb = putPointEgen (const False)
|
||||||
|
|
||||||
-- ((do {s <- readFile f; return (return s)}) )
|
-- ((do {s <- readFile f; return (return s)}) )
|
||||||
readFileIOE :: FilePath -> IOE BS.ByteString
|
readFileIOE :: FilePath -> IOE BS.ByteString
|
||||||
|
|||||||
@@ -51,7 +51,7 @@ trModule (i,mo) = case mo of
|
|||||||
body = P.MBody
|
body = P.MBody
|
||||||
(trExtends (extend m))
|
(trExtends (extend m))
|
||||||
(mkOpens (map trOpen (opens 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 :: [(Ident,MInclude Ident)] -> P.Extend
|
||||||
trExtends [] = P.NoExt
|
trExtends [] = P.NoExt
|
||||||
@@ -130,11 +130,11 @@ trPerh p = case p of
|
|||||||
May b -> P.EIndir $ tri b
|
May b -> P.EIndir $ tri b
|
||||||
_ -> P.EMeta ---
|
_ -> P.EMeta ---
|
||||||
|
|
||||||
|
trFlags :: ModuleOptions -> [P.TopDef]
|
||||||
|
trFlags = map trFlag . moduleOptionsGFO
|
||||||
|
|
||||||
trFlag :: Option -> P.TopDef
|
trFlag :: (String,String) -> P.TopDef
|
||||||
trFlag o = case o of
|
trFlag (f,x) = P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
|
||||||
Opt (f,[x]) -> P.DefFlag [P.FlagDef (tri $ identC (BS.pack f)) (tri $ identC (BS.pack x))]
|
|
||||||
_ -> P.DefFlag [] --- warning?
|
|
||||||
|
|
||||||
trt :: Term -> P.Exp
|
trt :: Term -> P.Exp
|
||||||
trt trm = case trm of
|
trt trm = case trm of
|
||||||
|
|||||||
@@ -107,14 +107,14 @@ transModDef x = case x of
|
|||||||
opens' <- transOpens opens
|
opens' <- transOpens opens
|
||||||
defs0 <- mapM trDef $ getTopDefs defs
|
defs0 <- mapM trDef $ getTopDefs defs
|
||||||
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
|
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'))
|
return (id',GM.ModMod (GM.Module mtyp' mstat' flags' extends' opens' defs'))
|
||||||
MReuse _ -> do
|
MReuse _ -> do
|
||||||
return (id', GM.ModMod (GM.Module mtyp' mstat' [] [] [] emptyBinTree))
|
return (id', GM.ModMod (GM.Module mtyp' mstat' noModuleOptions [] [] emptyBinTree))
|
||||||
MUnion imps -> do
|
MUnion imps -> do
|
||||||
imps' <- mapM transIncluded imps
|
imps' <- mapM transIncluded imps
|
||||||
return (id',
|
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 []
|
MWith m insts -> mkBody xx $ MWithEBody [] m insts NoOpens []
|
||||||
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
|
MWithBody m insts opens defs -> mkBody xx $ MWithEBody [] m insts opens defs
|
||||||
@@ -126,7 +126,7 @@ transModDef x = case x of
|
|||||||
opens' <- transOpens opens
|
opens' <- transOpens opens
|
||||||
defs0 <- mapM trDef $ getTopDefs defs
|
defs0 <- mapM trDef $ getTopDefs defs
|
||||||
defs' <- U.buildAnyTree [d | Left ds <- defs0, d <- ds]
|
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',
|
return (id',
|
||||||
GM.ModWith (GM.Module mtyp' mstat' flags' extends' opens' defs') m' insts')
|
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)
|
ISome i ids -> liftM2 (,) (transIdent i) (liftM GM.MIOnly $ mapM transIdent ids)
|
||||||
IMinus i ids -> liftM2 (,) (transIdent i) (liftM GM.MIExcept $ 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
|
transAbsDef x = case x of
|
||||||
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
|
DefCat catdefs -> liftM (Left . concat) $ mapM transCatDef catdefs
|
||||||
DefFun fundefs -> do
|
DefFun fundefs -> do
|
||||||
@@ -240,7 +240,7 @@ transAbsDef x = case x of
|
|||||||
DefTrans defs -> do
|
DefTrans defs -> do
|
||||||
defs' <- liftM concat $ mapM getDefsGen defs
|
defs' <- liftM concat $ mapM getDefsGen defs
|
||||||
returnl [(c, G.AbsTrans f) | (c,(_,Yes f)) <- 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
|
_ -> Bad $ "illegal definition in abstract module:" ++++ printTree x
|
||||||
where
|
where
|
||||||
-- to get data constructors as terms
|
-- to get data constructors as terms
|
||||||
@@ -253,9 +253,9 @@ transAbsDef x = case x of
|
|||||||
returnl :: a -> Err (Either a b)
|
returnl :: a -> Err (Either a b)
|
||||||
returnl = return . Left
|
returnl = return . Left
|
||||||
|
|
||||||
transFlagDef :: FlagDef -> Err GO.Option
|
transFlagDef :: FlagDef -> Err GO.ModuleOptions
|
||||||
transFlagDef x = case x of
|
transFlagDef x = case x of
|
||||||
FlagDef f x -> return $ GO.Opt (prPIdent f,[prPIdent x])
|
FlagDef f x -> parseModuleOptions ["--" ++ prPIdent f ++ "=" ++ prPIdent x]
|
||||||
where
|
where
|
||||||
prPIdent (PIdent (_,c)) = BS.unpack c
|
prPIdent (PIdent (_,c)) = BS.unpack c
|
||||||
|
|
||||||
@@ -306,7 +306,7 @@ transDataDef x = case x of
|
|||||||
DataId id -> liftM G.Cn $ transIdent id
|
DataId id -> liftM G.Cn $ transIdent id
|
||||||
DataQId id0 id -> liftM2 G.QC (transIdent id0) (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
|
transResDef x = case x of
|
||||||
DefPar pardefs -> do
|
DefPar pardefs -> do
|
||||||
pardefs' <- mapM transParDef pardefs
|
pardefs' <- mapM transParDef pardefs
|
||||||
@@ -332,7 +332,7 @@ transResDef x = case x of
|
|||||||
defs' <- liftM concat $ mapM getDefs defs
|
defs' <- liftM concat $ mapM getDefs defs
|
||||||
returnl [(f, G.ResOper pt pe) | (f,(pt,pe)) <- 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
|
_ -> Bad $ "illegal definition form in resource" +++ printTree x
|
||||||
where
|
where
|
||||||
mkOverload (c,j) = case j of
|
mkOverload (c,j) = case j of
|
||||||
@@ -354,7 +354,7 @@ transParDef x = case x of
|
|||||||
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
|
ParDefAbs id -> liftM2 (,) (transIdent id) (return [])
|
||||||
_ -> Bad $ "illegal definition in resource:" ++++ printTree x
|
_ -> 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
|
transCncDef x = case x of
|
||||||
DefLincat defs -> do
|
DefLincat defs -> do
|
||||||
defs' <- liftM concat $ mapM transPrintDef defs
|
defs' <- liftM concat $ mapM transPrintDef defs
|
||||||
@@ -374,7 +374,7 @@ transCncDef x = case x of
|
|||||||
DefPrintOld defs -> do --- a guess, for backward compatibility
|
DefPrintOld defs -> do --- a guess, for backward compatibility
|
||||||
defs' <- liftM concat $ mapM transPrintDef defs
|
defs' <- liftM concat $ mapM transPrintDef defs
|
||||||
returnl [(f, G.CncFun Nothing nope (yes e)) | (f,e) <- 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
|
DefPattern defs -> do
|
||||||
defs' <- liftM concat $ mapM getDefs defs
|
defs' <- liftM concat $ mapM getDefs defs
|
||||||
let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs']
|
let defs2 = [(f, termInPattern t) | (f,(_,Yes t)) <- defs']
|
||||||
@@ -700,10 +700,10 @@ transOldGrammar opts name0 x = case x of
|
|||||||
ne = NoExt
|
ne = NoExt
|
||||||
q = CMCompl
|
q = CMCompl
|
||||||
|
|
||||||
name = maybe name0 (++ ".gf") $ getOptVal opts useName
|
name = maybe name0 (++ ".gf") $ moduleFlag optName opts
|
||||||
absName = identPI $ maybe topic id $ getOptVal opts useAbsName
|
absName = identPI $ maybe topic id $ moduleFlag optAbsName opts
|
||||||
resName = identPI $ maybe ("Res" ++ lang) id $ getOptVal opts useResName
|
resName = identPI $ maybe ("Res" ++ lang) id $ moduleFlag optResName opts
|
||||||
cncName = identPI $ maybe lang id $ getOptVal opts useCncName
|
cncName = identPI $ maybe lang id $ moduleFlag optCncName opts
|
||||||
|
|
||||||
identPI s = PIdent ((0,0),BS.pack s)
|
identPI s = PIdent ((0,0),BS.pack s)
|
||||||
|
|
||||||
|
|||||||
@@ -12,56 +12,40 @@ import GF.Infra.Option
|
|||||||
import GF.GFCC.API
|
import GF.GFCC.API
|
||||||
import GF.Data.ErrM
|
import GF.Data.ErrM
|
||||||
|
|
||||||
|
import Data.Maybe
|
||||||
import System.FilePath
|
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
|
mainGFC :: Options -> [FilePath] -> IOE ()
|
||||||
_ | all ((==".gfcc") . takeExtensions) fs -> do
|
mainGFC opts fs =
|
||||||
gfccs <- mapM file2gfcc fs
|
do gr <- batchCompile opts fs
|
||||||
let gfcc = foldl1 unionGFCC gfccs
|
let cnc = justModuleName (last fs)
|
||||||
let gfccFile = targetNameGFCC opts (absname gfcc)
|
if flag optStopAfterPhase opts == Compile
|
||||||
outputFile gfccFile (printGFCC gfcc)
|
then return ()
|
||||||
mapM_ (alsoPrint opts gfcc) printOptions
|
else do gfcc <- link opts cnc gr
|
||||||
|
writeOutputs opts gfcc
|
||||||
_ -> do
|
|
||||||
appIOE (mapM_ (batchCompile opts) (map return fs)) >>= err fail return
|
|
||||||
putStrLn "Done."
|
|
||||||
|
|
||||||
targetName :: Options -> CId -> String
|
writeOutputs :: Options -> GFCC -> IOE ()
|
||||||
targetName opts abs = case getOptVal opts (aOpt "target") of
|
writeOutputs opts gfcc = mapM_ (\fmt -> writeOutput opts fmt gfcc) (flag optOutputFormats opts)
|
||||||
Just n -> n
|
|
||||||
_ -> prCId abs
|
|
||||||
|
|
||||||
targetNameGFCC :: Options -> CId -> FilePath
|
writeOutput :: Options -> OutputFormat-> GFCC -> IOE ()
|
||||||
targetNameGFCC opts abs = targetName opts abs ++ ".gfcc"
|
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
|
fmtExtension :: OutputFormat -> String
|
||||||
if oElem (iOpt opt) opts
|
fmtExtension FmtGFCC = "gfcc"
|
||||||
then outputFile name (prGFCC opt gr)
|
fmtExtension FmtJavaScript = "js"
|
||||||
else return ()
|
fmtExtension FmtHaskell = "hs"
|
||||||
|
fmtExtension FmtHaskellGADT = "hs"
|
||||||
|
|
||||||
outputFile :: FilePath -> String -> IO ()
|
writeOutputFile :: FilePath -> String -> IOE ()
|
||||||
outputFile outfile output =
|
writeOutputFile outfile output = ioeIO $
|
||||||
do writeFile outfile output
|
do writeFile outfile output
|
||||||
putStrLn $ "wrote file " ++ outfile
|
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"
|
|
||||||
|
|||||||
@@ -3,12 +3,12 @@ module GFI (mainGFI) where
|
|||||||
import GF.Command.Interpreter
|
import GF.Command.Interpreter
|
||||||
import GF.Command.Importing
|
import GF.Command.Importing
|
||||||
import GF.Command.Commands
|
import GF.Command.Commands
|
||||||
|
import GF.Data.ErrM
|
||||||
import GF.GFCC.API
|
import GF.GFCC.API
|
||||||
|
|
||||||
import GF.Grammar.API -- for cc command
|
import GF.Grammar.API -- for cc command
|
||||||
|
|
||||||
import GF.Infra.UseIO
|
import GF.Infra.UseIO
|
||||||
import GF.Infra.Option ---- Haskell's option lib
|
import GF.Infra.Option
|
||||||
import GF.System.Readline (fetchCommand)
|
import GF.System.Readline (fetchCommand)
|
||||||
|
|
||||||
import System.CPUTime
|
import System.CPUTime
|
||||||
@@ -17,10 +17,10 @@ import Data.Version
|
|||||||
import Paths_gf
|
import Paths_gf
|
||||||
|
|
||||||
|
|
||||||
mainGFI :: [String] -> IO ()
|
mainGFI :: Options -> [FilePath] -> IO ()
|
||||||
mainGFI xx = do
|
mainGFI opts files = do
|
||||||
putStrLn welcome
|
putStrLn welcome
|
||||||
env <- importInEnv emptyMultiGrammar xx
|
env <- importInEnv emptyMultiGrammar opts files
|
||||||
loop (GFEnv emptyGrammar env [] 0)
|
loop (GFEnv emptyGrammar env [] 0)
|
||||||
return ()
|
return ()
|
||||||
|
|
||||||
@@ -31,25 +31,26 @@ loop gfenv0 = do
|
|||||||
s <- fetchCommand (prompt env)
|
s <- fetchCommand (prompt env)
|
||||||
let gfenv = gfenv0 {history = s : history gfenv0}
|
let gfenv = gfenv0 {history = s : history gfenv0}
|
||||||
case words s of
|
case words s of
|
||||||
|
|
||||||
-- special commands, requiring source grammar in env
|
-- special commands, requiring source grammar in env
|
||||||
"cc":ws -> do
|
"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
|
let t = pTerm (unwords term) >>= checkTerm sgr >>= computeTerm sgr
|
||||||
err putStrLn (putStrLn . showTerm opts) t ---- make pipable
|
err putStrLn (putStrLn . showTerm opts) t ---- make pipable
|
||||||
loopNewCPU gfenv
|
loopNewCPU gfenv
|
||||||
|
|
||||||
"i":args -> do
|
"i":args -> do
|
||||||
let (opts,files) = getOptions "-" args
|
case parseOptions args of
|
||||||
case opts of
|
Ok (opts,files)
|
||||||
_ | oElem (iOpt "retain") opts -> do
|
| flag optRetainResource opts ->
|
||||||
src <- importSource sgr opts files
|
do src <- importSource sgr opts files
|
||||||
loopNewCPU $ gfenv {sourcegrammar = src}
|
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
|
-- other special commands, working on GFEnv
|
||||||
_ -> do
|
|
||||||
env1 <- importInEnv (multigrammar env) args
|
|
||||||
loopNewCPU $ gfenv {commandenv = env1}
|
|
||||||
"e":_ -> loopNewCPU $ gfenv {commandenv=env{multigrammar=emptyMultiGrammar}}
|
"e":_ -> loopNewCPU $ gfenv {commandenv=env{multigrammar=emptyMultiGrammar}}
|
||||||
"ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
|
"ph":_ -> mapM_ putStrLn (reverse (history gfenv0)) >> loopNewCPU gfenv
|
||||||
"q":_ -> putStrLn "See you." >> return gfenv
|
"q":_ -> putStrLn "See you." >> return gfenv
|
||||||
@@ -64,8 +65,8 @@ loopNewCPU gfenv = do
|
|||||||
putStrLn (show ((cpu' - cputime gfenv) `div` 1000000000) ++ " msec")
|
putStrLn (show ((cpu' - cputime gfenv) `div` 1000000000) ++ " msec")
|
||||||
loop $ gfenv {cputime = cpu'}
|
loop $ gfenv {cputime = cpu'}
|
||||||
|
|
||||||
importInEnv mgr0 xx = do
|
importInEnv :: MultiGrammar -> Options -> [FilePath] -> IO CommandEnv
|
||||||
let (opts,files) = getOptions "-" xx
|
importInEnv mgr0 opts files = do
|
||||||
mgr1 <- case files of
|
mgr1 <- case files of
|
||||||
[] -> return mgr0
|
[] -> return mgr0
|
||||||
_ -> importGrammar mgr0 opts files
|
_ -> importGrammar mgr0 opts files
|
||||||
|
|||||||
Reference in New Issue
Block a user