mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-23 03:32:51 -06:00
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
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 {
|
||||
mtype :: ModuleType i ,
|
||||
mstatus :: ModuleStatus ,
|
||||
flags :: [Option] ,
|
||||
flags :: ModuleOptions,
|
||||
extend :: [(i,MInclude i)],
|
||||
opens :: [OpenSpec i] ,
|
||||
jments :: BinTree i a
|
||||
@@ -126,16 +126,16 @@ addOpenQualif :: i -> i -> Module i t -> Module i t
|
||||
addOpenQualif i j (Module mt ms fs me ops js) =
|
||||
Module mt ms fs me (oQualif i j : ops) js
|
||||
|
||||
addFlag :: Option -> Module i t -> Module i t
|
||||
addFlag f mo = mo {flags = f : flags mo}
|
||||
addFlag :: ModuleOptions -> Module i t -> Module i t
|
||||
addFlag f mo = mo {flags = addModuleOptions (flags mo) f}
|
||||
|
||||
flagsModule :: (i,ModInfo i a) -> [Option]
|
||||
flagsModule :: (i,ModInfo i a) -> ModuleOptions
|
||||
flagsModule (_,mi) = case mi of
|
||||
ModMod m -> flags m
|
||||
_ -> []
|
||||
_ -> noModuleOptions
|
||||
|
||||
allFlags :: MGrammar i a -> [Option]
|
||||
allFlags gr = concat $ map flags $ [m | (_, ModMod m) <- modules gr]
|
||||
allFlags :: MGrammar i a -> ModuleOptions
|
||||
allFlags gr = concatModuleOptions $ map flags $ [m | (_, ModMod m) <- modules gr]
|
||||
|
||||
mapModules :: (Module i a -> Module i a)
|
||||
-> MGrammar i a -> MGrammar i a
|
||||
@@ -267,7 +267,7 @@ emptyModInfo :: ModInfo i a
|
||||
emptyModInfo = ModMod emptyModule
|
||||
|
||||
emptyModule :: Module i a
|
||||
emptyModule = Module MTResource MSComplete [] [] [] emptyBinTree
|
||||
emptyModule = Module MTResource MSComplete noModuleOptions [] [] emptyBinTree
|
||||
|
||||
-- | we store the module type with the identifier
|
||||
data IdentM i = IdentM {
|
||||
|
||||
@@ -1,375 +1,464 @@
|
||||
----------------------------------------------------------------------
|
||||
-- |
|
||||
-- Module : Option
|
||||
-- Maintainer : AR
|
||||
-- Stability : (stable)
|
||||
-- Portability : (portable)
|
||||
--
|
||||
-- > CVS $Date: 2005/11/14 16:03:41 $
|
||||
-- > CVS $Author: aarne $
|
||||
-- > CVS $Revision: 1.34 $
|
||||
--
|
||||
-- Options and flags used in GF shell commands and files.
|
||||
--
|
||||
-- The types 'Option' and 'Options' should be kept abstract, but:
|
||||
--
|
||||
-- - The constructor 'Opt' is used in "ShellCommands" and "GrammarToSource"
|
||||
--
|
||||
-- - The constructor 'Opts' us udes in "API", "Shell" and "ShellCommands"
|
||||
-----------------------------------------------------------------------------
|
||||
module GF.Infra.Option
|
||||
(
|
||||
-- * Option types
|
||||
Options, ModuleOptions,
|
||||
Flags(..), ModuleFlags(..),
|
||||
Mode(..), Phase(..), Encoding(..), OutputFormat(..), Optimization(..),
|
||||
Dump(..), Printer(..), Recomp(..),
|
||||
-- * Option parsing
|
||||
parseOptions, parseModuleOptions,
|
||||
-- * Option pretty-printing
|
||||
moduleOptionsGFO,
|
||||
-- * Option manipulation
|
||||
addOptions, concatOptions, noOptions,
|
||||
moduleOptions,
|
||||
addModuleOptions, concatModuleOptions, noModuleOptions,
|
||||
helpMessage,
|
||||
-- * Checking options
|
||||
flag, moduleFlag,
|
||||
-- * Convenience methods for checking options
|
||||
beVerbose, beSilent,
|
||||
dump
|
||||
) where
|
||||
|
||||
module GF.Infra.Option where
|
||||
import Control.Monad
|
||||
import Data.Char (toLower)
|
||||
import Data.List
|
||||
import Data.Maybe
|
||||
import GF.Infra.GetOpt
|
||||
--import System.Console.GetOpt
|
||||
import System.FilePath
|
||||
|
||||
import Data.List (partition)
|
||||
import Data.Char (isDigit)
|
||||
import GF.Data.ErrM
|
||||
|
||||
-- * all kinds of options, to be kept abstract
|
||||
|
||||
newtype Option = Opt (String,[String]) deriving (Eq,Show,Read)
|
||||
newtype Options = Opts [Option] deriving (Eq,Show,Read)
|
||||
|
||||
|
||||
usageHeader :: String
|
||||
usageHeader = unlines
|
||||
["Usage: gfc [OPTIONS] [FILE [...]]",
|
||||
"",
|
||||
"How each FILE is handled depends on the file name suffix:",
|
||||
"",
|
||||
".gf Normal or old GF source, will be compiled.",
|
||||
".gfo Compiled GF source, will be loaded as is.",
|
||||
".gfe Example-based GF source, will be converted to .gf and compiled.",
|
||||
".ebnf Extended BNF format, will be converted to .gf and compiled.",
|
||||
".cf Context-free (BNF) format, will be converted to .gf and compiled.",
|
||||
"",
|
||||
"If multiple FILES are given, they must be normal GF source, .gfo or .gfe files.",
|
||||
"For the other input formats, only one file can be given.",
|
||||
"",
|
||||
"Command-line options:"]
|
||||
|
||||
|
||||
helpMessage :: String
|
||||
helpMessage = usageInfo usageHeader optDescr
|
||||
|
||||
|
||||
-- FIXME: do we really want multi-line errors?
|
||||
errors :: [String] -> Err a
|
||||
errors = fail . unlines
|
||||
|
||||
-- Types
|
||||
|
||||
data Mode = ModeVersion | ModeHelp | ModeInteractive | ModeCompiler
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data Phase = Preproc | Convert | Compile | Link
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data Encoding = UTF_8 | ISO_8859_1
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data OutputFormat = FmtGFCC | FmtJavaScript | FmtHaskell | FmtHaskellGADT
|
||||
deriving (Eq,Ord)
|
||||
|
||||
data Optimization = OptStem | OptCSE | OptExpand | OptParametrize | OptValues
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data Warning = WarnMissingLincat
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data Dump = DumpRebuild | DumpExtend | DumpRename | DumpTypeCheck | DumpRefresh | DumpOptimize | DumpCanon
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
-- | Pretty-printing options
|
||||
data Printer = PrinterStrip -- ^ Remove name qualifiers.
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data Recomp = AlwaysRecomp | RecompIfNewer | NeverRecomp
|
||||
deriving (Show,Eq,Ord)
|
||||
|
||||
data ModuleFlags = ModuleFlags {
|
||||
optName :: Maybe String,
|
||||
optAbsName :: Maybe String,
|
||||
optCncName :: Maybe String,
|
||||
optResName :: Maybe String,
|
||||
optPreprocessors :: [String],
|
||||
optEncoding :: Encoding,
|
||||
optOptimizations :: [Optimization],
|
||||
optLibraryPath :: [FilePath],
|
||||
optStartCat :: Maybe String,
|
||||
optSpeechLanguage :: Maybe String,
|
||||
optLexer :: Maybe String,
|
||||
optUnlexer :: Maybe String,
|
||||
optBuildParser :: Bool,
|
||||
optWarnings :: [Warning],
|
||||
optDump :: [Dump]
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
data Flags = Flags {
|
||||
optMode :: Mode,
|
||||
optStopAfterPhase :: Phase,
|
||||
optVerbosity :: Int,
|
||||
optShowCPUTime :: Bool,
|
||||
optEmitGFO :: Bool,
|
||||
optGFODir :: FilePath,
|
||||
optOutputFormats :: [OutputFormat],
|
||||
optOutputFile :: Maybe FilePath,
|
||||
optOutputDir :: Maybe FilePath,
|
||||
optRecomp :: Recomp,
|
||||
optPrinter :: [Printer],
|
||||
optProb :: Bool,
|
||||
optRetainResource :: Bool,
|
||||
optModuleFlags :: ModuleFlags
|
||||
}
|
||||
deriving (Show)
|
||||
|
||||
newtype Options = Options (Flags -> Flags)
|
||||
|
||||
instance Show Options where
|
||||
show (Options o) = show (o defaultFlags)
|
||||
|
||||
newtype ModuleOptions = ModuleOptions (ModuleFlags -> ModuleFlags)
|
||||
|
||||
-- Option parsing
|
||||
|
||||
parseOptions :: [String] -> Err (Options, [FilePath])
|
||||
parseOptions args
|
||||
| not (null errs) = errors errs
|
||||
| otherwise = do opts <- liftM concatOptions $ sequence optss
|
||||
return (opts, files)
|
||||
where (optss, files, errs) = getOpt RequireOrder optDescr args
|
||||
|
||||
parseModuleOptions :: [String] -> Err ModuleOptions
|
||||
parseModuleOptions args
|
||||
| not (null errs) = errors errs
|
||||
| not (null files) = errors $ map ("Non-option among module options: " ++) files
|
||||
| otherwise = liftM concatModuleOptions $ sequence flags
|
||||
where (flags, files, errs) = getOpt RequireOrder moduleOptDescr args
|
||||
|
||||
-- Showing options
|
||||
|
||||
-- | Pretty-print the module options that are preserved in .gfo files.
|
||||
moduleOptionsGFO :: ModuleOptions -> [(String,String)]
|
||||
moduleOptionsGFO (ModuleOptions o) =
|
||||
maybe [] (\l -> [("language",l)]) (optSpeechLanguage mfs)
|
||||
where mfs = o defaultModuleFlags
|
||||
|
||||
|
||||
-- Option manipulation
|
||||
|
||||
noOptions :: Options
|
||||
noOptions = Opts []
|
||||
noOptions = Options id
|
||||
|
||||
-- | simple option -o
|
||||
iOpt :: String -> Option
|
||||
iOpt o = Opt (o,[])
|
||||
|
||||
-- | option with argument -o=a
|
||||
aOpt :: String -> String -> Option
|
||||
aOpt o a = Opt (o,[a])
|
||||
|
||||
iOpts :: [Option] -> Options
|
||||
iOpts = Opts
|
||||
|
||||
-- | value of option argument
|
||||
oArg :: String -> String
|
||||
oArg s = s
|
||||
|
||||
oElem :: Option -> Options -> Bool
|
||||
oElem o (Opts os) = elem o os
|
||||
|
||||
eqOpt :: String -> Option -> Bool
|
||||
eqOpt s (Opt (o, [])) = s == o
|
||||
eqOpt s _ = False
|
||||
|
||||
type OptFun = String -> Option
|
||||
type OptFunId = String
|
||||
|
||||
getOptVal :: Options -> OptFun -> Maybe String
|
||||
getOptVal (Opts os) fopt =
|
||||
case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
|
||||
a:_ -> Just a
|
||||
_ -> Nothing
|
||||
|
||||
isSetFlag :: Options -> OptFun -> Bool
|
||||
isSetFlag (Opts os) fopt =
|
||||
case [a | opt@(Opt (o,[a])) <- os, opt == fopt a] of
|
||||
a:_ -> True
|
||||
_ -> False
|
||||
|
||||
getOptInt :: Options -> OptFun -> Maybe Int
|
||||
getOptInt opts f = do
|
||||
s <- getOptVal opts f
|
||||
if (not (null s) && all isDigit s) then return (read s) else Nothing
|
||||
|
||||
optIntOrAll :: Options -> OptFun -> [a] -> [a]
|
||||
optIntOrAll opts f = case getOptInt opts f of
|
||||
Just i -> take i
|
||||
_ -> id
|
||||
|
||||
optIntOrN :: Options -> OptFun -> Int -> Int
|
||||
optIntOrN opts f n = case getOptInt opts f of
|
||||
Just i -> i
|
||||
_ -> n
|
||||
|
||||
optIntOrOne :: Options -> OptFun -> Int
|
||||
optIntOrOne opts f = optIntOrN opts f 1
|
||||
|
||||
changeOptVal :: Options -> OptFun -> String -> Options
|
||||
changeOptVal os f x =
|
||||
addOption (f x) $ maybe os (\y -> removeOption (f y) os) $ getOptVal os f
|
||||
|
||||
addOption :: Option -> Options -> Options
|
||||
addOption o (Opts os) = iOpts (o:os)
|
||||
|
||||
addOptions :: Options -> Options -> Options
|
||||
addOptions (Opts os) os0 = foldr addOption os0 os
|
||||
addOptions :: Options -- ^ Existing options.
|
||||
-> Options -- ^ Options to add (these take preference).
|
||||
-> Options
|
||||
addOptions (Options o1) (Options o2) = Options (o2 . o1)
|
||||
|
||||
concatOptions :: [Options] -> Options
|
||||
concatOptions = foldr addOptions noOptions
|
||||
|
||||
removeOption :: Option -> Options -> Options
|
||||
removeOption o (Opts os) = iOpts (filter (/=o) os)
|
||||
moduleOptions :: ModuleOptions -> Options
|
||||
moduleOptions (ModuleOptions f) = Options (\o -> o { optModuleFlags = f (optModuleFlags o) })
|
||||
|
||||
removeOptions :: Options -> Options -> Options
|
||||
removeOptions (Opts os) os0 = foldr removeOption os0 os
|
||||
addModuleOptions :: ModuleOptions -- ^ Existing options.
|
||||
-> ModuleOptions -- ^ Options to add (these take preference).
|
||||
-> ModuleOptions
|
||||
addModuleOptions (ModuleOptions o1) (ModuleOptions o2) = ModuleOptions (o2 . o1)
|
||||
|
||||
options :: [Option] -> Options
|
||||
options = foldr addOption noOptions
|
||||
concatModuleOptions :: [ModuleOptions] -> ModuleOptions
|
||||
concatModuleOptions = foldr addModuleOptions noModuleOptions
|
||||
|
||||
unionOptions :: Options -> Options -> Options
|
||||
unionOptions (Opts os) (Opts os') = Opts (os ++ os')
|
||||
noModuleOptions :: ModuleOptions
|
||||
noModuleOptions = ModuleOptions id
|
||||
|
||||
-- * parsing options, with prefix pre (e.g. \"-\")
|
||||
flag :: (Flags -> a) -> Options -> a
|
||||
flag f (Options o) = f (o defaultFlags)
|
||||
|
||||
getOptions :: String -> [String] -> (Options, [String])
|
||||
getOptions pre inp = let
|
||||
(os,rest) = span (isOption pre) inp -- options before args
|
||||
in
|
||||
(Opts (map (pOption pre) os), rest)
|
||||
moduleFlag :: (ModuleFlags -> a) -> Options -> a
|
||||
moduleFlag f = flag (f . optModuleFlags)
|
||||
|
||||
pOption :: String -> String -> Option
|
||||
pOption pre s = case span (/= '=') (drop (length pre) s) of
|
||||
(f,_:a) -> aOpt f a
|
||||
(o,[]) -> iOpt o
|
||||
|
||||
isOption :: String -> String -> Bool
|
||||
isOption pre = (==pre) . take (length pre)
|
||||
|
||||
-- * printing options, without prefix
|
||||
|
||||
prOpt :: Option -> String
|
||||
prOpt (Opt (s,[])) = s
|
||||
prOpt (Opt (s,xs)) = s ++ "=" ++ concat xs
|
||||
|
||||
prOpts :: Options -> String
|
||||
prOpts (Opts os) = unwords $ map prOpt os
|
||||
|
||||
-- * a suggestion for option names
|
||||
|
||||
-- ** parsing
|
||||
|
||||
strictParse, forgiveParse, ignoreParse, literalParse, rawParse, firstParse :: Option
|
||||
-- | parse as term instead of string
|
||||
dontParse :: Option
|
||||
|
||||
strictParse = iOpt "strict"
|
||||
forgiveParse = iOpt "n"
|
||||
ignoreParse = iOpt "ign"
|
||||
literalParse = iOpt "lit"
|
||||
rawParse = iOpt "raw"
|
||||
firstParse = iOpt "1"
|
||||
dontParse = iOpt "read"
|
||||
|
||||
newParser, newerParser, newCParser, newMParser :: Option
|
||||
newParser = iOpt "new"
|
||||
newerParser = iOpt "newer"
|
||||
newCParser = iOpt "cfg"
|
||||
newMParser = iOpt "mcfg"
|
||||
newFParser = iOpt "fcfg"
|
||||
|
||||
{-
|
||||
useParserMCFG, useParserMCFGviaCFG, useParserCFG, useParserCF :: Option
|
||||
|
||||
useParserMCFG = iOpt "mcfg"
|
||||
useParserMCFGviaCFG = iOpt "mcfg-via-cfg"
|
||||
useParserCFG = iOpt "cfg"
|
||||
useParserCF = iOpt "cf"
|
||||
parseModuleFlags :: Options -> [(String,Maybe String)] -> Err ModuleOptions
|
||||
parseModuleFlags opts flags =
|
||||
mapM (uncurry (findFlag moduleOptDescr)) flags >>= foldM (flip ($)) (optModuleOptions opts)
|
||||
|
||||
findFlag :: Monad m => [OptDescr a] -> String -> Maybe String -> m a
|
||||
findFlag opts n mv =
|
||||
case filter (`flagMatches` n) opts of
|
||||
[] -> fail $ "Unknown option: " ++ n
|
||||
[opt] -> flagValue opt n mv
|
||||
_ -> fail $ n ++ " matches multiple options."
|
||||
|
||||
flagMatches :: OptDescr a -> String -> Bool
|
||||
flagMatches (Option cs ss _ _) n = n `elem` (map (:[]) cs ++ ss)
|
||||
|
||||
flagValue :: Monad m => OptDescr a -> String -> Maybe String -> m a
|
||||
flagValue (Option _ _ arg _) n mv =
|
||||
case (arg, mv) of
|
||||
(NoArg x, Nothing) -> return x
|
||||
(NoArg _, Just _ ) -> fail $ "Option " ++ n ++ " does not take a value."
|
||||
(ReqArg _ _, Nothing) -> fail $ "Option " ++ n ++ " requires a value."
|
||||
(ReqArg f _, Just x ) -> return (f x)
|
||||
(OptArg f _, mx ) -> return (f mx)
|
||||
|
||||
-}
|
||||
|
||||
-- ** grammar formats
|
||||
-- Default options
|
||||
|
||||
showAbstr, showXML, showOld, showLatex, showFullForm,
|
||||
showEBNF, showCF, showWords, showOpts,
|
||||
isCompiled, isHaskell, noCompOpers, retainOpers,
|
||||
noCF, checkCirc, noCheckCirc, lexerByNeed, useUTF8id :: Option
|
||||
defaultGrOpts :: [Option]
|
||||
defaultModuleFlags :: ModuleFlags
|
||||
defaultModuleFlags = ModuleFlags {
|
||||
optName = Nothing,
|
||||
optAbsName = Nothing,
|
||||
optCncName = Nothing,
|
||||
optResName = Nothing,
|
||||
optPreprocessors = [],
|
||||
optEncoding = ISO_8859_1,
|
||||
optOptimizations = [OptStem,OptCSE,OptExpand,OptParametrize,OptValues],
|
||||
optLibraryPath = [],
|
||||
optStartCat = Nothing,
|
||||
optSpeechLanguage = Nothing,
|
||||
optLexer = Nothing,
|
||||
optUnlexer = Nothing,
|
||||
optBuildParser = True,
|
||||
optWarnings = [],
|
||||
optDump = []
|
||||
}
|
||||
|
||||
showAbstr = iOpt "abs"
|
||||
showXML = iOpt "xml"
|
||||
showOld = iOpt "old"
|
||||
showLatex = iOpt "latex"
|
||||
showFullForm = iOpt "fullform"
|
||||
showEBNF = iOpt "ebnf"
|
||||
showCF = iOpt "cf"
|
||||
showWords = iOpt "ws"
|
||||
showOpts = iOpt "opts"
|
||||
-- showOptim = iOpt "opt"
|
||||
isCompiled = iOpt "gfc"
|
||||
isHaskell = iOpt "gfhs"
|
||||
noCompOpers = iOpt "nocomp"
|
||||
retainOpers = iOpt "retain"
|
||||
defaultGrOpts = []
|
||||
noCF = iOpt "nocf"
|
||||
checkCirc = iOpt "nocirc"
|
||||
noCheckCirc = iOpt "nocheckcirc"
|
||||
lexerByNeed = iOpt "cflexer"
|
||||
useUTF8id = iOpt "utf8id"
|
||||
elimSubs = iOpt "subs"
|
||||
defaultFlags :: Flags
|
||||
defaultFlags = Flags {
|
||||
optMode = ModeInteractive,
|
||||
optStopAfterPhase = Compile,
|
||||
optVerbosity = 1,
|
||||
optShowCPUTime = False,
|
||||
optEmitGFO = True,
|
||||
optGFODir = ".",
|
||||
optOutputFormats = [FmtGFCC],
|
||||
optOutputFile = Nothing,
|
||||
optOutputDir = Nothing,
|
||||
optRecomp = RecompIfNewer,
|
||||
optPrinter = [],
|
||||
optProb = False,
|
||||
optRetainResource = False,
|
||||
optModuleFlags = defaultModuleFlags
|
||||
}
|
||||
|
||||
-- ** linearization
|
||||
-- Option descriptions
|
||||
|
||||
allLin, firstLin, distinctLin, dontLin,
|
||||
showRecord, showStruct, xmlLin, latexLin,
|
||||
tableLin, useUTF8, showLang, withMetas :: Option
|
||||
defaultLinOpts :: [Option]
|
||||
moduleOptDescr :: [OptDescr (Err ModuleOptions)]
|
||||
moduleOptDescr =
|
||||
[
|
||||
Option ['n'] ["name"] (ReqArg name "NAME")
|
||||
(unlines ["Use NAME as the name of the output. This is used in the output file names, ",
|
||||
"with suffixes depending on the formats, and, when relevant, ",
|
||||
"internally in the output."]),
|
||||
Option [] ["abs"] (ReqArg absName "NAME")
|
||||
("Use NAME as the name of the abstract syntax module generated from "
|
||||
++ "a grammar in GF 1 format."),
|
||||
Option [] ["cnc"] (ReqArg cncName "NAME")
|
||||
("Use NAME as the name of the concrete syntax module generated from "
|
||||
++ "a grammar in GF 1 format."),
|
||||
Option [] ["res"] (ReqArg resName "NAME")
|
||||
("Use NAME as the name of the resource module generated from "
|
||||
++ "a grammar in GF 1 format."),
|
||||
Option ['i'] [] (ReqArg addLibDir "DIR") "Add DIR to the library search path.",
|
||||
Option [] ["path"] (ReqArg setLibPath "DIR:DIR:...") "Set the library search path.",
|
||||
Option [] ["preproc"] (ReqArg preproc "CMD")
|
||||
(unlines ["Use CMD to preprocess input files.",
|
||||
"Multiple preprocessors can be used by giving this option multiple times."]),
|
||||
Option [] ["coding"] (ReqArg coding "ENCODING")
|
||||
("Character encoding of the source grammar, ENCODING = "
|
||||
++ concat (intersperse " | " (map fst encodings)) ++ "."),
|
||||
Option [] ["parser"] (onOff parser True) "Build parser (default on).",
|
||||
Option [] ["startcat"] (ReqArg startcat "CAT") "Grammar start category.",
|
||||
Option [] ["language"] (ReqArg language "LANG") "Set the speech language flag to LANG in the generated grammar.",
|
||||
Option [] ["lexer"] (ReqArg lexer "LEXER") "Use lexer LEXER.",
|
||||
Option [] ["unlexer"] (ReqArg unlexer "UNLEXER") "Use unlexer UNLEXER.",
|
||||
Option [] ["optimize"] (ReqArg optimize "OPT")
|
||||
"Select an optimization package. OPT = all | values | parametrize | none",
|
||||
Option [] ["stem"] (onOff (toggleOptimize OptStem) True) "Perform stem-suffix analysis (default on).",
|
||||
Option [] ["cse"] (onOff (toggleOptimize OptCSE) True) "Perform common sub-expression elimination (default on).",
|
||||
dumpOption "rebuild" DumpRebuild,
|
||||
dumpOption "extend" DumpExtend,
|
||||
dumpOption "rename" DumpRename,
|
||||
dumpOption "tc" DumpTypeCheck,
|
||||
dumpOption "refresh" DumpRefresh,
|
||||
dumpOption "opt" DumpOptimize,
|
||||
dumpOption "canon" DumpCanon
|
||||
]
|
||||
where
|
||||
name x = set $ \o -> o { optName = Just x }
|
||||
absName x = set $ \o -> o { optAbsName = Just x }
|
||||
cncName x = set $ \o -> o { optCncName = Just x }
|
||||
resName x = set $ \o -> o { optResName = Just x }
|
||||
addLibDir x = set $ \o -> o { optLibraryPath = x:optLibraryPath o }
|
||||
setLibPath x = set $ \o -> o { optLibraryPath = splitInModuleSearchPath x }
|
||||
preproc x = set $ \o -> o { optPreprocessors = optPreprocessors o ++ [x] }
|
||||
coding x = case lookup x encodings of
|
||||
Just c -> set $ \o -> o { optEncoding = c }
|
||||
Nothing -> fail $ "Unknown character encoding: " ++ x
|
||||
parser x = set $ \o -> o { optBuildParser = x }
|
||||
startcat x = set $ \o -> o { optStartCat = Just x }
|
||||
language x = set $ \o -> o { optSpeechLanguage = Just x }
|
||||
lexer x = set $ \o -> o { optLexer = Just x }
|
||||
unlexer x = set $ \o -> o { optUnlexer = Just x }
|
||||
|
||||
allLin = iOpt "all"
|
||||
firstLin = iOpt "one"
|
||||
distinctLin = iOpt "nub"
|
||||
dontLin = iOpt "show"
|
||||
showRecord = iOpt "record"
|
||||
showStruct = iOpt "structured"
|
||||
xmlLin = showXML
|
||||
latexLin = showLatex
|
||||
tableLin = iOpt "table"
|
||||
defaultLinOpts = [firstLin]
|
||||
useUTF8 = iOpt "utf8"
|
||||
showLang = iOpt "lang"
|
||||
showDefs = iOpt "defs"
|
||||
withMetas = iOpt "metas"
|
||||
optimize x = case lookup x optimizationPackages of
|
||||
Just p -> set $ \o -> o { optOptimizations = p }
|
||||
Nothing -> fail $ "Unknown optimization package: " ++ x
|
||||
|
||||
-- ** other
|
||||
toggleOptimize x b = set $ \o -> o { optOptimizations = (if b then (x:) else delete x) (optOptimizations o) }
|
||||
|
||||
beVerbose, showInfo, beSilent, emitCode, getHelp,
|
||||
doMake, doBatch, notEmitCode, makeMulti, beShort,
|
||||
wholeGrammar, makeFudget, byLines, byWords, analMorpho,
|
||||
doTrace, noCPU, doCompute, optimizeCanon, optimizeValues,
|
||||
stripQualif, nostripQualif, showAll, fromSource :: Option
|
||||
dumpOption s d = Option [] ["dump-"++s] (NoArg (set $ \o -> o { optDump = d:optDump o})) ("Dump output of the " ++ s ++ " phase.")
|
||||
|
||||
beVerbose = iOpt "v"
|
||||
invertGrep = iOpt "v" --- same letter in unix
|
||||
showInfo = iOpt "i"
|
||||
beSilent = iOpt "s"
|
||||
emitCode = iOpt "o"
|
||||
getHelp = iOpt "help"
|
||||
doMake = iOpt "make"
|
||||
doBatch = iOpt "batch"
|
||||
notEmitCode = iOpt "noemit"
|
||||
makeMulti = iOpt "multi"
|
||||
beShort = iOpt "short"
|
||||
wholeGrammar = iOpt "w"
|
||||
makeFudget = iOpt "f"
|
||||
byLines = iOpt "lines"
|
||||
byWords = iOpt "words"
|
||||
analMorpho = iOpt "morpho"
|
||||
doTrace = iOpt "tr"
|
||||
noCPU = iOpt "nocpu"
|
||||
doCompute = iOpt "c"
|
||||
optimizeCanon = iOpt "opt"
|
||||
optimizeValues = iOpt "val"
|
||||
stripQualif = iOpt "strip"
|
||||
nostripQualif = iOpt "nostrip"
|
||||
showAll = iOpt "all"
|
||||
showFields = iOpt "fields"
|
||||
showMulti = iOpt "multi"
|
||||
fromSource = iOpt "src"
|
||||
makeConcrete = iOpt "examples"
|
||||
fromExamples = iOpt "ex"
|
||||
openEditor = iOpt "edit"
|
||||
getTrees = iOpt "trees"
|
||||
set = return . ModuleOptions
|
||||
|
||||
-- ** mainly for stand-alone
|
||||
optDescr :: [OptDescr (Err Options)]
|
||||
optDescr =
|
||||
[
|
||||
Option ['?','h'] ["help"] (NoArg (mode ModeHelp)) "Show help message.",
|
||||
Option ['V'] ["version"] (NoArg (mode ModeVersion)) "Display GF version number.",
|
||||
Option ['v'] ["verbose"] (OptArg verbosity "N") "Set verbosity (default 1). -v alone is the same as -v 3.",
|
||||
Option ['q','s'] ["quiet"] (NoArg (verbosity (Just "0"))) "Quiet, same as -v 0.",
|
||||
Option [] ["batch"] (NoArg (mode ModeCompiler)) "Run in batch compiler mode.",
|
||||
Option [] ["interactive"] (NoArg (mode ModeInteractive)) "Run in interactive mode (default).",
|
||||
Option ['E'] [] (NoArg (phase Preproc)) "Stop after preprocessing (with --preproc).",
|
||||
Option ['C'] [] (NoArg (phase Convert)) "Stop after conversion to .gf.",
|
||||
Option ['c'] [] (NoArg (phase Compile)) "Stop after compiling to .gfo (default) .",
|
||||
Option [] ["make"] (NoArg (phase Link)) "Build .gfcc file and other output files.",
|
||||
Option [] ["cpu"] (NoArg (cpu True)) "Show compilation CPU time statistics.",
|
||||
Option [] ["no-cpu"] (NoArg (cpu False)) "Don't show compilation CPU time statistics (default).",
|
||||
Option [] ["emit-gfo"] (NoArg (emitGFO True)) "Create .gfo files (default).",
|
||||
Option [] ["no-emit-gfo"] (NoArg (emitGFO False)) "Do not create .gfo files.",
|
||||
Option [] ["gfo-dir"] (ReqArg gfoDir "DIR") "Directory to put .gfo files in (default = '.').",
|
||||
Option ['f'] ["output-format"] (ReqArg outFmt "FMT")
|
||||
(unlines ["Output format. FMT can be one of:",
|
||||
"Multiple concrete: gfcc (default), gar, js, ...",
|
||||
"Single concrete only: cf, bnf, lbnf, gsl, srgs_xml, srgs_abnf, ...",
|
||||
"Abstract only: haskell, ..."]),
|
||||
Option ['o'] ["output-file"] (ReqArg outFile "FILE")
|
||||
"Save output in FILE (default is out.X, where X depends on output format.",
|
||||
Option ['D'] ["output-dir"] (ReqArg outDir "DIR")
|
||||
"Save output files (other than .gfc files) in DIR.",
|
||||
Option [] ["src","force-recomp"] (NoArg (recomp AlwaysRecomp))
|
||||
"Always recompile from source.",
|
||||
Option [] ["gfo","recomp-if-newer"] (NoArg (recomp RecompIfNewer))
|
||||
"(default) Recompile from source if the source is newer than the .gfo file.",
|
||||
Option [] ["gfo","no-recomp"] (NoArg (recomp NeverRecomp))
|
||||
"Never recompile from source, if there is already .gfo file.",
|
||||
Option [] ["strip"] (NoArg (printer PrinterStrip))
|
||||
"Remove name qualifiers when pretty-printing.",
|
||||
Option [] ["retain"] (NoArg (set $ \o -> o { optRetainResource = True })) "Retain opers.",
|
||||
Option [] ["prob"] (NoArg (prob True)) "Read probabilities from '--# prob' pragmas."
|
||||
] ++ map (fmap (liftM moduleOptions)) moduleOptDescr
|
||||
where phase x = set $ \o -> o { optStopAfterPhase = x }
|
||||
mode x = set $ \o -> o { optMode = x }
|
||||
verbosity mv = case mv of
|
||||
Nothing -> set $ \o -> o { optVerbosity = 3 }
|
||||
Just v -> case reads v of
|
||||
[(i,"")] | i >= 0 -> set $ \o -> o { optVerbosity = i }
|
||||
_ -> fail $ "Bad verbosity: " ++ show v
|
||||
cpu x = set $ \o -> o { optShowCPUTime = x }
|
||||
emitGFO x = set $ \o -> o { optEmitGFO = x }
|
||||
gfoDir x = set $ \o -> o { optGFODir = x }
|
||||
outFmt x = readOutputFormat x >>= \f ->
|
||||
set $ \o -> o { optOutputFormats = optOutputFormats o ++ [f] }
|
||||
outFile x = set $ \o -> o { optOutputFile = Just x }
|
||||
outDir x = set $ \o -> o { optOutputDir = Just x }
|
||||
recomp x = set $ \o -> o { optRecomp = x }
|
||||
printer x = set $ \o -> o { optPrinter = x : optPrinter o }
|
||||
prob x = set $ \o -> o { optProb = x }
|
||||
|
||||
useUnicode, optCompute, optCheck, optParaphrase, forJava :: Option
|
||||
set = return . Options
|
||||
|
||||
useUnicode = iOpt "unicode"
|
||||
optCompute = iOpt "compute"
|
||||
optCheck = iOpt "typecheck"
|
||||
optParaphrase = iOpt "paraphrase"
|
||||
forJava = iOpt "java"
|
||||
instance Functor OptDescr where
|
||||
fmap f (Option cs ss d s) = Option cs ss (fmap f d) s
|
||||
|
||||
-- ** for edit session
|
||||
instance Functor ArgDescr where
|
||||
fmap f (NoArg x) = NoArg (f x)
|
||||
fmap f (ReqArg g s) = ReqArg (f . g) s
|
||||
fmap f (OptArg g s) = OptArg (f . g) s
|
||||
|
||||
allLangs, absView :: Option
|
||||
outputFormats :: [(String,OutputFormat)]
|
||||
outputFormats =
|
||||
[("gfcc", FmtGFCC),
|
||||
("js", FmtJavaScript),
|
||||
("haskell", FmtHaskell),
|
||||
("haskell_gadt", FmtHaskellGADT)]
|
||||
|
||||
allLangs = iOpt "All"
|
||||
absView = iOpt "Abs"
|
||||
instance Show OutputFormat where
|
||||
show = lookupShow outputFormats
|
||||
|
||||
-- ** options that take arguments
|
||||
instance Read OutputFormat where
|
||||
readsPrec = lookupReadsPrec outputFormats
|
||||
|
||||
useTokenizer, useUntokenizer, useParser, withFun,
|
||||
useLanguage, useResource, speechLanguage, useFont,
|
||||
grammarFormat, grammarPrinter, filterString, termCommand,
|
||||
transferFun, forForms, menuDisplay, sizeDisplay, typeDisplay,
|
||||
noDepTypes, extractGr, pathList, uniCoding :: String -> Option
|
||||
-- | used on command line
|
||||
firstCat :: String -> Option
|
||||
-- | used in grammar, to avoid clash w res word
|
||||
gStartCat :: String -> Option
|
||||
optimizationPackages :: [(String,[Optimization])]
|
||||
optimizationPackages =
|
||||
[("all_subs", [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]), -- deprecated
|
||||
("all", [OptStem,OptCSE,OptExpand,OptParametrize,OptValues]),
|
||||
("values", [OptStem,OptCSE,OptExpand,OptValues]),
|
||||
("parametrize", [OptStem,OptCSE,OptExpand,OptParametrize]),
|
||||
("none", [OptStem,OptCSE,OptExpand]),
|
||||
("noexpand", [OptStem,OptCSE])]
|
||||
|
||||
useTokenizer = aOpt "lexer"
|
||||
useUntokenizer = aOpt "unlexer"
|
||||
useParser = aOpt "parser"
|
||||
-- useStrategy = aOpt "strategy" -- parsing strategy
|
||||
withFun = aOpt "fun"
|
||||
firstCat = aOpt "cat"
|
||||
gStartCat = aOpt "startcat"
|
||||
useLanguage = aOpt "lang"
|
||||
useResource = aOpt "res"
|
||||
speechLanguage = aOpt "language"
|
||||
useFont = aOpt "font"
|
||||
grammarFormat = aOpt "format"
|
||||
grammarPrinter = aOpt "printer"
|
||||
filterString = aOpt "filter"
|
||||
termCommand = aOpt "transform"
|
||||
transferFun = aOpt "transfer"
|
||||
forForms = aOpt "forms"
|
||||
menuDisplay = aOpt "menu"
|
||||
sizeDisplay = aOpt "size"
|
||||
typeDisplay = aOpt "types"
|
||||
noDepTypes = aOpt "nodeptypes"
|
||||
extractGr = aOpt "extract"
|
||||
pathList = aOpt "path"
|
||||
uniCoding = aOpt "coding"
|
||||
probFile = aOpt "probs"
|
||||
noparseFile = aOpt "noparse"
|
||||
usePreprocessor = aOpt "preproc"
|
||||
encodings :: [(String,Encoding)]
|
||||
encodings =
|
||||
[("utf8", UTF_8),
|
||||
("latin1", ISO_8859_1)]
|
||||
|
||||
-- peb 16/3-05:
|
||||
gfcConversion :: String -> Option
|
||||
gfcConversion = aOpt "conversion"
|
||||
lookupShow :: Eq a => [(String,a)] -> a -> String
|
||||
lookupShow xs z = fromMaybe "lookupShow" $ lookup z [(y,x) | (x,y) <- xs]
|
||||
|
||||
useName, useAbsName, useCncName, useResName,
|
||||
useFile, useOptimizer :: String -> Option
|
||||
lookupReadsPrec :: [(String,a)] -> Int -> ReadS a
|
||||
lookupReadsPrec xs _ s = [(z,rest) | (x,rest) <- lex s, (y,z) <- xs, y == x]
|
||||
|
||||
useName = aOpt "name"
|
||||
useAbsName = aOpt "abs"
|
||||
useCncName = aOpt "cnc"
|
||||
useResName = aOpt "res"
|
||||
useFile = aOpt "file"
|
||||
useOptimizer = aOpt "optimize"
|
||||
onOff :: Monad m => (Bool -> m a) -> Bool -> ArgDescr (m a)
|
||||
onOff f def = OptArg g "[on,off]"
|
||||
where g ma = maybe (return def) readOnOff ma >>= f
|
||||
readOnOff x = case map toLower x of
|
||||
"on" -> return True
|
||||
"off" -> return False
|
||||
_ -> fail $ "Expected [on,off], got: " ++ show x
|
||||
|
||||
markLin :: String -> Option
|
||||
markOptXML, markOptJava, markOptStruct, markOptFocus :: String
|
||||
readOutputFormat :: Monad m => String -> m OutputFormat
|
||||
readOutputFormat s =
|
||||
maybe (fail $ "Unknown output format: " ++ show s) return $ lookup s outputFormats
|
||||
|
||||
markLin = aOpt "mark"
|
||||
markOptXML = oArg "xml"
|
||||
markOptJava = oArg "java"
|
||||
markOptStruct = oArg "struct"
|
||||
markOptFocus = oArg "focus"
|
||||
-- FIXME: this is a copy of the function in GF.Devel.UseIO.
|
||||
splitInModuleSearchPath :: String -> [FilePath]
|
||||
splitInModuleSearchPath s = case break isPathSep s of
|
||||
(f,_:cs) -> f : splitInModuleSearchPath cs
|
||||
(f,_) -> [f]
|
||||
where
|
||||
isPathSep :: Char -> Bool
|
||||
isPathSep c = c == ':' || c == ';'
|
||||
|
||||
--
|
||||
-- * Convenience functions for checking options
|
||||
--
|
||||
|
||||
-- ** refinement order
|
||||
beVerbose :: Options -> Bool
|
||||
beVerbose = flag ((>= 3) . optVerbosity)
|
||||
|
||||
nextRefine :: String -> Option
|
||||
firstRefine, lastRefine :: String
|
||||
beSilent :: Options -> Bool
|
||||
beSilent = flag ((<= 0) . optVerbosity)
|
||||
|
||||
nextRefine = aOpt "nextrefine"
|
||||
firstRefine = oArg "first"
|
||||
lastRefine = oArg "last"
|
||||
dump :: Options -> Dump -> Bool
|
||||
dump opts d = moduleFlag ((d `elem`) . optDump) opts
|
||||
|
||||
-- ** Boolean flags
|
||||
|
||||
flagYes, flagNo :: String
|
||||
|
||||
flagYes = oArg "yes"
|
||||
flagNo = oArg "no"
|
||||
|
||||
-- ** integer flags
|
||||
|
||||
flagDepth, flagAlts, flagLength, flagNumber, flagRawtrees :: String -> Option
|
||||
|
||||
flagDepth = aOpt "depth"
|
||||
flagAlts = aOpt "alts"
|
||||
flagLength = aOpt "length"
|
||||
flagNumber = aOpt "number"
|
||||
flagRawtrees = aOpt "rawtrees"
|
||||
|
||||
caseYesNo :: Options -> OptFun -> Maybe Bool
|
||||
caseYesNo opts f = do
|
||||
v <- getOptVal opts f
|
||||
if v == flagYes then return True
|
||||
else if v == flagNo then return False
|
||||
else Nothing
|
||||
|
||||
@@ -24,6 +24,7 @@ import System.FilePath
|
||||
import System.IO
|
||||
import System.IO.Error
|
||||
import System.Environment
|
||||
import System.Exit
|
||||
import System.CPUTime
|
||||
import Control.Monad
|
||||
import Control.Exception(evaluate)
|
||||
@@ -39,20 +40,16 @@ putShow' f = putStrLn . show . length . show . f
|
||||
|
||||
putIfVerb :: Options -> String -> IO ()
|
||||
putIfVerb opts msg =
|
||||
if oElem beVerbose opts
|
||||
if beVerbose opts
|
||||
then putStrLn msg
|
||||
else return ()
|
||||
|
||||
putIfVerbW :: Options -> String -> IO ()
|
||||
putIfVerbW opts msg =
|
||||
if oElem beVerbose opts
|
||||
if beVerbose opts
|
||||
then putStr (' ' : msg)
|
||||
else return ()
|
||||
|
||||
-- | obsolete with IOE monad
|
||||
errIO :: a -> Err a -> IO a
|
||||
errIO = errOptIO noOptions
|
||||
|
||||
errOptIO :: Options -> a -> Err a -> IO a
|
||||
errOptIO os e m = case m of
|
||||
Ok x -> return x
|
||||
@@ -235,6 +232,13 @@ foldIOE f s xs = case xs of
|
||||
Ok v -> foldIOE f v xx
|
||||
Bad m -> return $ (s, Just m)
|
||||
|
||||
dieIOE :: IOE a -> IO a
|
||||
dieIOE x = appIOE x >>= err die return
|
||||
|
||||
die :: String -> IO a
|
||||
die s = do hPutStrLn stderr s
|
||||
exitFailure
|
||||
|
||||
putStrLnE :: String -> IOE ()
|
||||
putStrLnE = ioeIO . putStrLnFlush
|
||||
|
||||
@@ -243,28 +247,27 @@ putStrE = ioeIO . putStrFlush
|
||||
|
||||
-- this is more verbose
|
||||
putPointE :: Options -> String -> IOE a -> IOE a
|
||||
putPointE = putPointEgen (oElem beSilent)
|
||||
putPointE = putPointEgen beSilent
|
||||
|
||||
-- this is less verbose
|
||||
putPointEsil :: Options -> String -> IOE a -> IOE a
|
||||
putPointEsil = putPointEgen (not . oElem beVerbose)
|
||||
putPointEsil = putPointEgen (not . beVerbose)
|
||||
|
||||
putPointEgen :: (Options -> Bool) -> Options -> String -> IOE a -> IOE a
|
||||
putPointEgen cond opts msg act = do
|
||||
let ve x = if cond opts then return () else x
|
||||
ve $ ioeIO $ putStrFlush msg
|
||||
when (cond opts) $ ioeIO $ putStrFlush msg
|
||||
|
||||
t1 <- ioeIO $ getCPUTime
|
||||
a <- act >>= ioeIO . evaluate
|
||||
t2 <- ioeIO $ getCPUTime
|
||||
|
||||
ve $ ioeIO $ putStrLnFlush (' ' : show ((t2 - t1) `div` 1000000000) ++ " msec")
|
||||
when (flag optShowCPUTime opts) $ ioeIO $ putStrLnFlush (' ' : show ((t2 - t1) `div` 1000000000) ++ " msec")
|
||||
return a
|
||||
|
||||
|
||||
-- | forces verbosity
|
||||
putPointEVerb :: Options -> String -> IOE a -> IOE a
|
||||
putPointEVerb opts = putPointE (addOption beVerbose opts)
|
||||
putPointEVerb = putPointEgen (const False)
|
||||
|
||||
-- ((do {s <- readFile f; return (return s)}) )
|
||||
readFileIOE :: FilePath -> IOE BS.ByteString
|
||||
|
||||
Reference in New Issue
Block a user