cmdargs 0.6 → 0.10.22
raw patch · 39 files changed
Files
- CHANGES.txt +152/−0
- Data/Generics/Any.hs +15/−8
- Data/Generics/Any/Prelude.hs +21/−4
- LICENSE +1/−1
- Main.hs +19/−5
- README.md +364/−0
- Setup.hs +0/−2
- System/Console/CmdArgs/Annotate.hs +7/−8
- System/Console/CmdArgs/Default.hs +12/−0
- System/Console/CmdArgs/Explicit.hs +119/−18
- System/Console/CmdArgs/Explicit/Complete.hs +201/−0
- System/Console/CmdArgs/Explicit/ExpandArgsAt.hs +33/−0
- System/Console/CmdArgs/Explicit/Help.hs +25/−8
- System/Console/CmdArgs/Explicit/Process.hs +35/−43
- System/Console/CmdArgs/Explicit/SplitJoin.hs +54/−0
- System/Console/CmdArgs/Explicit/Type.hs +39/−20
- System/Console/CmdArgs/GetOpt.hs +6/−29
- System/Console/CmdArgs/Helper.hs +327/−0
- System/Console/CmdArgs/Implicit.hs +67/−14
- System/Console/CmdArgs/Implicit/Ann.hs +4/−0
- System/Console/CmdArgs/Implicit/Global.hs +60/−24
- System/Console/CmdArgs/Implicit/Local.hs +88/−26
- System/Console/CmdArgs/Implicit/Read.hs +0/−137
- System/Console/CmdArgs/Implicit/Reader.hs +111/−0
- System/Console/CmdArgs/Implicit/Reform.hs +42/−0
- System/Console/CmdArgs/Implicit/Type.hs +14/−10
- System/Console/CmdArgs/Implicit/UI.hs +56/−2
- System/Console/CmdArgs/Quote.hs +213/−0
- System/Console/CmdArgs/Test/All.hs +2/−0
- System/Console/CmdArgs/Test/Explicit.hs +20/−2
- System/Console/CmdArgs/Test/Implicit/Diffy.hs +31/−4
- System/Console/CmdArgs/Test/Implicit/HLint.hs +9/−5
- System/Console/CmdArgs/Test/Implicit/Maker.hs +6/−3
- System/Console/CmdArgs/Test/Implicit/Tests.hs +193/−18
- System/Console/CmdArgs/Test/Implicit/Util.hs +43/−15
- System/Console/CmdArgs/Test/SplitJoin.hs +149/−0
- System/Console/CmdArgs/Text.hs +11/−5
- cmdargs.cabal +48/−12
- cmdargs.htm +0/−432
+ CHANGES.txt view
@@ -0,0 +1,152 @@+Changelog for CmdArgs++0.10.22, released 2023-03-13+ #68, support GHC 9.6+0.10.21, released 2021-02-14+ Handle GHC 9.0 optimisations+ Remove support for GHC 7.4 to 7.8+0.10.20, released 2018-01-22+ #54, use the getopt data types from base+0.10.19, released 2018-01-01+ #47, ensure Semigroup instance on all GHC versions+0.10.18, released 2017-09-24+ #47, GHC 8.4 compatibility+0.10.17, released 2017-03-31+ Add processValueIO for more controlled error messages+ #529, don't include the stack trace in processValue+0.10.16, released 2017-03-22+ Minor improvement to error messages+0.10.15, released 2017-03-06+ #43, GHC 8.2 compatibility+0.10.14, released 2016-02-16+ #39, ensure correct line breaks in HTML help output+ #18, preserve manual \n in help messages+ #25, reformat the README+0.10.13, released 2015-05-22+ #24, support Ratio in some places+0.10.12, released 2014-10-27+ GHC 7.2 compatibility+0.10.11, released 2014-10-12+ #15, never put [brackets] around optional args in Explicit+0.10.10, released 2014-09-18+ #14, fix @ file arguments+0.10.9, released 2014-07-22+ #10, fix versionArgs (broken in 0.10.8)+0.10.8, released 2014-07-21+ Avoid compilation warnings on GHC 7.8+ #9, add --numeric-version flag+ Update the copyright year+ Change GetOpt.usageInfo to be more like GetOpt+0.10.7, released 2013-12-09+ #1, fix timestamps in .tar.gz dist file+0.10.6, released 2013-12-05+ #625, more documentation about args/argPos+ #626, ensure initial lists don't get reversed (fix after #610)+0.10.5, released 2013-07-29+ #615, support lists inside a newtype+0.10.4, released 2013-06-26+ #610, make sure it is O(n) to append arguments, not O(n^2)+0.10.3, released 2013-04-05+ Append list items under an enum+ Support &= ignore on enum fields+0.10.2, released 2013-02-28+ Relax upper bounds to be GHC 7.7 compatible+0.10.1, released 2012-11-17+ #569, set the test program to off by default+ Complete revamp of cmdargs-browser, far better Javascript+ Add a missing case for Helper marshalling FlagNone+0.10, released 2012-08-09+ Revert to 0.9.6, including modeExpandAt+0.9.7, released 2012-08-09+ Revert to 0.9.5, to fix up PVP breakage+0.9.6, released 2012-07-29+ #539, hopefully more fixes to compiling in profile mode+ #522, add modeExpandAt and noAtExpand annotation+ #522, don't @expand after --+0.9.5, released 2012-03-25+ Don't specify TH extension unless quotation is true+0.9.4, released 2012-03-25+ #539, specify the TH extension in the Cabal file+ Allow transformers 0.3.*+ Correct copyright in license and cabal file+0.9.3, released 2012-02-10+ Add expandArgsAt and support for @ flag file directives+0.9.2, released 2012-01-07+ Don't build the test program if quotation is turned off+0.9.1, released 2012-01-05+ Improve the documentation for the Explicit module+ #433, propagate groupname on modes in the Implicit code+0.9, released 2011-11-05+ #467, add completions for people running bash+ #334, add a Quote module, to write pure in the impure syntax+ #482, fix the sample in Explicit, don't use def+ #461, fix the translation for enum/enum_+ Make showHelp take an argument for the prefix bits+ Add Helper interface, and initial cmdargs-browser code+ Add splitArgs/joinArgs+0.8, released 2011-08-13+ #450, redo the manual generator so Maker example is not cut off+ Support all the types in Data.Int/Data.Word+ Make modeArgs take a list of arguments as well+0.7, released 2011-05-07+ No changes, just a version bump to allow requiring the GHC fix+0.6.10, released 2011-05-07+ Change the annotate module to cope better with GHC's CSE+0.6.9, released 2011-04-03+ #422, support newtype value as the underlying type+0.6.8, released 2011-02-13+ Allow versionArgs [summary] to override --version+ Improve the documentation surrounding opt+ Add modeReform to Mode+ Add modeEmpty, to construct blank Mode values+ Improve the documentation surrounding pure annotations.+0.6.7, released 2011-01-15+ #395, don't put two newlines after --help or --version+0.6.6, released 2010-12-30+ #392, support helpArgs [groupname "something"]+0.6.5, released 2010-12-15+ Don't fail with ambiguous enum if you exactly match a value+ Put errors on stderr+0.6.4, released 2010-11-20+ Eliminate the filepath dependence+0.6.3, released 2010-11-10+ Switch mtl for transformers+0.6.2, released 2010-11-10+ Build on GHC 7.0 RC2, add an extra type signature+ Add verbosityArgs to customise the verbose/quiet flags+ Add helpArg/versionArg flags to customise those flags+ Support multiline summary using \n escape codes+0.6.1, released 2010-10-04+ Build on GHC 6.10, don't rely on record name disambiguation+0.6, released 2010-09-18+ Add ignore annotation for modes and flags+ #350, make top-level help appear properly+0.5, released 2010-09-15+ #351, name/explicit attributes on mode were broken (regression)+0.4, released 2010-09-05+ #342, display common fields only once+ Raise errors if annotations are placed in invalid places+ Rewrite the translation of annotation to explicit modes+ Treat anything after -- as an argument+ Add a pure annotation mechanism+ Introduce System.Console.CmdArgs.Annotate+0.3, released 2010-08-23+ Add a documentation example for the Explicit mode+ Improve the purity and annotations a bit, try disabling CSE+ Change the help format+ Rename groupHiden to groupHidden, patch from Matthew Cox+ Bug, missing fields and explicit enums didn't work together+0.2, released 2010-08-14+ #252, add support for grouped flags/modes+ #333, support missing fields+ Add support for reading tuple values (including nested)+ #292, add support for automatic enumerations+ #221, make argpos work with non-string fields+ #222, support opt and args together+ #230, different modes can share short flags+ #295, make verbosity flags explicit+ #231, add support for Maybe+ #256, add --option=false support+ Complete rewrite to introduce Explicit module+0.1, released 2009-09-12+ Start of changelog
Data/Generics/Any.hs view
@@ -2,11 +2,13 @@ module Data.Generics.Any where -import Control.Monad.State+import Control.Exception+import Control.Monad.Trans.State import qualified Data.Data as D-import Data.Data hiding (toConstr, typeOf, dataTypeOf, isAlgType)+import Data.Data hiding (toConstr, typeOf, dataTypeOf) import Data.List import Data.Maybe+import System.IO.Unsafe type CtorName = String@@ -18,6 +20,8 @@ | otherwise = Nothing where y = init $ tail x +try1 :: a -> Either SomeException a+try1 = unsafePerformIO . try . evaluate --------------------------------------------------------------------- -- BASIC TYPES@@ -62,7 +66,7 @@ typeShell = tyconUQname . typeShellFull typeShellFull :: Any -> String-typeShellFull = tyConString . typeRepTyCon . typeOf+typeShellFull = tyConName . typeRepTyCon . typeOf typeName :: Any -> String typeName = show . typeOf@@ -81,6 +85,7 @@ compose0 :: Any -> CtorName -> Any+compose0 x c | either (const False) (== c) $ try1 $ ctor x = x compose0 (Any x) c = Any $ fromConstrB err y `asTypeOf` x where Just y = readConstr (D.dataTypeOf x) c err = error $ "Data.Generics.Any: Undefined field inside compose0, " ++ c ++ " :: " ++ show (Any x)@@ -89,11 +94,13 @@ recompose :: Any -> [Any] -> Any recompose (Any x) cs | null s = Any $ res `asTypeOf` x | otherwise = err- where (res,s) = flip runState cs $ flip fromConstrM (D.toConstr x) $ do- cs <- get- if null cs then err else do- put $ tail cs- return $ fromAny $ head cs+ where (res,s) = runState (fromConstrM field $ D.toConstr x) cs++ field :: Data d => State [Any] d+ field = do cs <- get+ if null cs then err else do+ put $ tail cs+ return $ fromAny $ head cs err = error $ "Data.Generics.Any.recompose: Incorrect number of children to recompose, " ++ ctor (Any x) ++ " :: " ++ show (Any x) ++ ", expected " ++ show (arity $ Any x) ++
Data/Generics/Any/Prelude.hs view
@@ -2,7 +2,6 @@ module Data.Generics.Any.Prelude where -import Prelude hiding (head,tail,null) import Data.Generics.Any import Data.Maybe @@ -16,6 +15,11 @@ cons :: AnyT a -> AnyT [a] -> AnyT [a] cons x y = compose y "(:)" [x,y] +uncons :: AnyT [a] -> Maybe (AnyT a, AnyT [a])+uncons x = case decompose x of+ ("[]",[]) -> Nothing+ ("(:)",[a,b]) -> Just (a,b)+ null :: AnyT [a] -> Bool null x | isList x = ctor x == "[]" @@ -25,13 +29,26 @@ nil_ :: AnyT [a] -> AnyT [a] nil_ w = compose w "[]" [] +list_ :: AnyT [a] -> AnyT a -> AnyT [a]+list_ w x = cons x $ nil_ w+ append :: AnyT [a] -> AnyT [a] -> AnyT [a] append x y | typeOf x == typeOf y = f x y- where f x y | null x = y- | otherwise = cons (head x) (f (tail x) y)+ where f x y = case uncons x of+ Nothing -> y+ Just (a,b) -> cons a $ f b y +reverse :: AnyT [a] -> AnyT [a]+reverse xs | isList xs = rev xs (nil_ xs)+ where rev xs acc = case uncons xs of+ Nothing -> acc+ Just (x,xs) -> rev xs (cons x acc) -isList x = typeShell x == "[]"++isString x = typeName x == "[Char]"+-- GHC 9.6 changes from [] to List, so accept either+isList x = ts == "[]" || ts == "List"+ where ts = typeShell x isMaybe x = typeShell x == "Maybe" isTuple x = isJust $ readTupleType $ typeShell x
LICENSE view
@@ -1,4 +1,4 @@-Copyright Neil Mitchell 2006-2007.+Copyright Neil Mitchell 2009-2023. All rights reserved. Redistribution and use in source and binary forms, with or without
Main.hs view
@@ -1,5 +1,5 @@ -module Main where+module Main(main) where import System.Console.CmdArgs.Test.All import qualified System.Console.CmdArgs.Test.Implicit.Diffy as D@@ -10,6 +10,7 @@ import System.Console.CmdArgs.Text import System.Console.CmdArgs.Default +import Control.Monad import Data.List import Data.Maybe import System.IO@@ -25,8 +26,8 @@ where flags = [flagHelpFormat $ \a b _ -> Help a b ,flagVersion $ const Version- ,flagNone ["t","test"] (const Test) "Run the tests"- ,flagNone ["g","generate"] (const Generate) "Generate the manual"]+ ,flagNone ["test","t"] (const Test) "Run the tests"+ ,flagNone ["generate","g"] (const Generate) "Generate the manual"] ms = map (remap Demo (\(Demo x) -> (x,Demo))) demo @@ -36,12 +37,24 @@ let ver = "CmdArgs demo program, (C) Neil Mitchell" case x of Version -> putStrLn ver- Help hlp txt -> putStrLn $ showText txt $ Line ver : Line "" : helpText hlp args+ Help hlp txt -> do+ let xs = showText txt $ helpText [ver] hlp args+ putStrLn xs+ when (hlp == HelpFormatBash) $ do+ writeFileBinary "cmdargs.bash_comp" xs+ putStrLn "# Output written to cmdargs.bash_comp" Test -> test Generate -> generateManual Demo x -> runDemo x +writeFileBinary :: FilePath -> String -> IO ()+writeFileBinary file x = do+ h <- openBinaryFile file WriteMode+ hPutStr h x+ hClose h++ --------------------------------------------------------------------- -- GENERATE MANUAL @@ -75,7 +88,7 @@ recode :: [String] -> [String]-recode = concatMap f . blanks . takeWhile (not . isPrefixOf "test")+recode = concatMap f . blanks . takeWhile (/= "-- STOP MANUAL") where blanks ("":"":xs) = blanks ("":xs) blanks [""] = []@@ -83,6 +96,7 @@ blanks (x:xs) = x : blanks xs f x | x == "import System.Console.CmdArgs.Test.Implicit.Util" = []+ | "{-# OPTIONS_GHC " `isPrefixOf` x = [] | "{-# LANGUAGE " `isPrefixOf` x = ["{-# LANGUAGE DeriveDataTypeable #-}"] | "module System.Console.CmdArgs.Test.Implicit." `isPrefixOf` x = ["module " ++ drop 44 x] f x = [x]
+ README.md view
@@ -0,0 +1,364 @@+# CmdArgs: Easy Command Line Processing [](https://hackage.haskell.org/package/cmdargs) [](https://www.stackage.org/package/cmdargs) [](https://github.com/ndmitchell/cmdargs/actions)++CmdArgs is a Haskell library for defining command line parsers. The two features that make it a better choice than the standard [getopt library](http://haskell.org/ghc/docs/latest/html/libraries/base/System-Console-GetOpt.html) are:++* It's very concise to use. The HLint command line handling is three times shorter with CmdArgs.+* It supports programs with multiple modes, such as [darcs](http://darcs.net) or [Cabal](http://haskell.org/cabal/).++A very simple example of a command line processor is:+```haskell+data Sample = Sample {hello :: String} deriving (Show, Data, Typeable)++sample = Sample{hello = def &= help "World argument" &= opt "world"}+ &= summary "Sample v1"++main = print =<< cmdArgs sample+```+Despite being very concise, this processor is already fairly well featured:++ $ runghc Sample.hs --hello=world+ Sample {hello = "world"}++ $ runghc Sample.hs --help+ Sample v1, (C) Neil Mitchell 2009++ sample [FLAG]++ -? --help[=FORMAT] Show usage information (optional format)+ -V --version Show version information+ -v --verbose Higher verbosity+ -q --quiet Lower verbosity+ -h --hello=VALUE World argument (default=world)++## User Manual++The rest of this document explains how to write the "hello world" of command line processors, then how to extend it with features into a complex command line processor. Finally this document gives three samples, which the `cmdargs` program can run. The three samples are:++* `hlint` - the [HLint](https://github.com/ndmitchell/hlint#readme) program.+* `diffy` - a program to compare the differences between directories.+* `maker` - a make style program.++For each example you are encouraged to look at it's source (in the [repo](https://github.com/ndmitchell/cmdargs/tree/master/System/Console/CmdArgs/Test/Implicit)) and run it (try `cmdargs hlint --help`). The HLint program is fairly standard in terms of it's argument processing, and previously used the [System.Console.GetOpt](http://haskell.org/ghc/docs/latest/html/libraries/base/System-Console-GetOpt.html) library. Using GetOpt required 90 lines and a reasonable amount of duplication. Using CmdArgs the code requires 30 lines, and the logic is much simpler.++**Acknowledgements** Thanks to Kevin Quick for substantial patches, and additional code contributions from Sebastian Fischer and Daniel Schoepe.+++## Hello World Example++The following code defines a complete command line argument processor:+```haskell+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -fno-cse #-}+module Sample where+import System.Console.CmdArgs++data Sample = Sample {hello :: String}+ deriving (Show, Data, Typeable)++sample = Sample{hello = def}++main = print =<< cmdArgs sample+```+To use the CmdArgs library there are three steps:++* Define a record data type (`Sample`) that contains a field for each argument. This type needs to have instances for `Show`, `Data` and `Typeable`.+* Give a value of that type (`sample`) with default values (`def` is a default value of any type, but I could also have written `""`). This value is turned into a command line by calling the `cmdArgs` function.+* To ensure GHC evalutes attributes the right number of times we disable the CSE optimisation on this module.++Now we have a reasonably functional command line argument processor. Some sample interactions are:++ $ runghc Sample.hs --hello=world+ Sample {hello = "world"}++ $ runghc Sample.hs --version+ The sample program++ $ runghc Sample.hs --help+ The sample program++ sample [OPTIONS]++ -? --help Display help message+ -V --version Print version information+ -h --hello=ITEM++CmdArgs uses defaults to automatically infer a command line parser for a value, and provides annotations to override any of the the defaults. CmdArgs automatically supports `--help` and `--version` flags, and optionally supports verbosity flags.++## Specifying Attributes++In order to control the behaviour we can add attributes. For example to add an attribute specifying the help text for the `--hello` argument we can write:+```haskell+sample = Sample{hello = def &= help "Who to say hello to"}+```+We can add additional attributes, for example to specify the type of the value expected by hello:+```haskell+sample = Sample {hello = def &= help "Who to say hello to" &= typ "WORLD"}+```+Now when running `--help` the final line is:++ -h --hello=WORLD Who to say hello to++There are many more attributes, detailed in the [Haddock documentation](http://hackage.haskell.org/packages/archive/cmdargs/latest/doc/html/System-Console-CmdArgs.html#2).+++## Multiple Modes++To specify a program with multiple modes, similar to [darcs](http://darcs.net/), we can supply a data type with multiple constructors, for example:+```haskell+data Sample = Hello {whom :: String}+ | Goodbye+ deriving (Show, Data, Typeable)++hello = Hello{whom = def}+goodbye = Goodbye++main = print =<< cmdArgs (modes [hello,goodbye])+```+Compared to the first example, we now have multiple constructors, and a sample value for each constructor is passed to `cmdArgs`. Some sample interactions with this command line are:++ $ runghc Sample.hs hello --whom=world+ Hello {whom = "world"}++ $ runghc Sample.hs goodbye+ Goodbye++ $ runghc Sample.hs --help+ The sample program++ sample [OPTIONS]++ Common flags+ -? --help Display help message+ -V --version Print version information++ sample hello [OPTIONS]++ -w --whom=ITEM++ sample goodbye [OPTIONS]++As before, the behaviour can be customised using attributes.+++## Larger Examples++For each of the following examples we first explain the purpose of the program, then give the source code, and finally the output of `--help`. The programs are intended to show sample uses of CmdArgs, and are available to experiment with through `cmdargs progname`.++### HLint++The [HLint](https://github.com/ndmitchell/hlint#readme) program analyses a list of files, using various options to control the analysis. The command line processing is simple, but a few interesting points are:++* The `--report` flag can be used to output a report in a standard location, but giving the flag a value changes where the file is output.+* The `color` field is assigned two flag aliases, `--colour` and `-c`. Assigning the `-c` short flag explicitly stops either of the CPP fields using it.+* The `show_` field would clash with `show` if given the expected name, but CmdArgs automatically strips the trailing underscore.+* The `cpp_define` field has an underscore in it's name, which is transformed into a hyphen for the flag name.++The code is:+```haskell+{-# LANGUAGE DeriveDataTypeable #-}+module HLint where+import System.Console.CmdArgs++data HLint = HLint+ {report :: [FilePath]+ ,hint :: [FilePath]+ ,color :: Bool+ ,ignore_ :: [String]+ ,show_ :: Bool+ ,extension :: [String]+ ,language :: [String]+ ,utf8 :: Bool+ ,encoding :: String+ ,find :: [FilePath]+ ,test_ :: Bool+ ,datadir :: [FilePath]+ ,cpp_define :: [String]+ ,cpp_include :: [FilePath]+ ,files :: [FilePath]+ }+ deriving (Data,Typeable,Show,Eq)++hlint = HLint+ {report = def &= opt "report.html" &= typFile &= help "Generate a report in HTML"+ ,hint = def &= typFile &= help "Hint/ignore file to use"+ ,color = def &= name "c" &= name "colour" &= help "Color the output (requires ANSI terminal)"+ ,ignore_ = def &= typ "MESSAGE" &= help "Ignore a particular hint"+ ,show_ = def &= help "Show all ignored ideas"+ ,extension = def &= typ "EXT" &= help "File extensions to search (defaults to hs and lhs)"+ ,language = def &= name "X" &= typ "LANG" &= help "Language extension (Arrows, NoCPP)"+ ,utf8 = def &= help "Use UTF-8 text encoding"+ ,encoding = def &= typ "ENC" &= help "Choose the text encoding"+ ,find = def &= typFile &= help "Find hints in a Haskell file"+ ,test_ = def &= help "Run in test mode"+ ,datadir = def &= typDir &= help "Override the data directory"+ ,cpp_define = def &= typ "NAME[=VALUE]" &= help "CPP #define"+ ,cpp_include = def &= typDir &= help "CPP include path"+ ,files = def &= args &= typ "FILES/DIRS"+ } &=+ verbosity &=+ help "Suggest improvements to Haskell source code" &=+ summary "HLint v0.0.0, (C) Neil Mitchell" &=+ details ["Hlint gives hints on how to improve Haskell code",""+ ,"To check all Haskell files in 'src' and generate a report type:"," hlint src --report"]++mode = cmdArgsMode hlint+```+Produces the `--help` output:++ HLint v0.0.0, (C) Neil Mitchell++ hlint [OPTIONS] [FILES/DIRS]+ Suggest improvements to Haskell source code++ Common flags:+ -r --report[=FILE] Generate a report in HTML+ -h --hint=FILE Hint/ignore file to use+ -c --colour --color Color the output (requires ANSI terminal)+ -i --ignore=MESSAGE Ignore a particular hint+ -s --show Show all ignored ideas+ --extension=EXT File extensions to search (defaults to hs and lhs)+ -X --language=LANG Language extension (Arrows, NoCPP)+ -u --utf8 Use UTF-8 text encoding+ --encoding=ENC Choose the text encoding+ -f --find=FILE Find hints in a Haskell file+ -t --test Run in test mode+ -d --datadir=DIR Override the data directory+ --cpp-define=NAME[=VALUE] CPP #define+ --cpp-include=DIR CPP include path+ -? --help Display help message+ -V --version Print version information+ -v --verbose Loud verbosity+ -q --quiet Quiet verbosity++ Hlint gives hints on how to improve Haskell code++ To check all Haskell files in 'src' and generate a report type:+ hlint src --report+++### Diffy++The Diffy sample is a based on the idea of creating directory listings and comparing them. The tool can operate in two separate modes, `create` or `diff`. This sample is fictional, but the ideas are drawn from a real program. A few notable features:++* There are multiple modes of execution, creating and diffing.+* The diff mode takes exactly two arguments, the old file and the new file.+* Default values are given for the `out` field, which are different in both modes.++The code is:+```haskell+{-# LANGUAGE DeriveDataTypeable #-}+module Diffy where+import System.Console.CmdArgs++data Diffy = Create {src :: Maybe FilePath, out :: FilePath}+ | Diff {old :: FilePath, new :: FilePath, out :: FilePath}+ deriving (Data,Typeable,Show,Eq)++outFlags x = x &= help "Output file" &= typFile++create = Create+ {src = def &= help "Source directory" &= typDir+ ,out = outFlags "ls.txt"+ } &= help "Create a fingerprint"++diff = Diff+ {old = def &= typ "OLDFILE" &= argPos 0+ ,new = def &= typ "NEWFILE" &= argPos 1+ ,out = outFlags "diff.txt"+ } &= help "Perform a diff"++mode = cmdArgsMode $ modes [create,diff] &= help "Create and compare differences" &= program "diffy" &= summary "Diffy v1.0"+```+And `--help` produces:++ Diffy v1.0++ diffy [COMMAND] ... [OPTIONS]+ Create and compare differences++ Common flags:+ -o --out=FILE Output file+ -? --help Display help message+ -V --version Print version information++ diffy create [OPTIONS]+ Create a fingerprint++ -s --src=DIR Source directory++ diffy diff [OPTIONS] OLDFILE NEWFILE+ Perform a diff++### Maker++The Maker sample is based around a build system, where we can either build a project, clean the temporary files, or run a test. Some interesting features are:++* The build mode is the default, so `maker` on it's own will be interpreted as a build command.+* The build method is an enumeration.+* The `threads` field is in two of the constructors, but not all three. It is given the short flag `-j`, rather than the default `-t`.++The code is:+```haskell+{-# LANGUAGE DeriveDataTypeable #-}+module Maker where+import System.Console.CmdArgs++data Method = Debug | Release | Profile+ deriving (Data,Typeable,Show,Eq)++data Maker+ = Wipe+ | Test {threads :: Int, extra :: [String]}+ | Build {threads :: Int, method :: Method, files :: [FilePath]}+ deriving (Data,Typeable,Show,Eq)++threadsMsg x = x &= help "Number of threads to use" &= name "j" &= typ "NUM"++wipe = Wipe &= help "Clean all build objects"++test_ = Test+ {threads = threadsMsg def+ ,extra = def &= typ "ANY" &= args+ } &= help "Run the test suite"++build = Build+ {threads = threadsMsg def+ ,method = enum+ [Release &= help "Release build"+ ,Debug &= help "Debug build"+ ,Profile &= help "Profile build"]+ ,files = def &= args+ } &= help "Build the project" &= auto++mode = cmdArgsMode $ modes [build,wipe,test_]+ &= help "Build helper program"+ &= program "maker"+ &= summary "Maker v1.0\nMake it"+```+And `--help` produces:++ Maker v1.0+ Make it++ maker [COMMAND] ... [OPTIONS]+ Build helper program++ Common flags:+ -? --help Display help message+ -V --version Print version information++ maker [build] [OPTIONS] [ITEM]+ Build the project++ -j --threads=NUM Number of threads to use+ -r --release Release build+ -d --debug Debug build+ -p --profile Profile build++ maker wipe [OPTIONS]+ Clean all build objects++ maker test [OPTIONS] [ANY]+ Run the test suite++ -j --threads=NUM Number of threads to use
Setup.hs view
@@ -1,4 +1,2 @@-#! /usr/bin/runhaskell- import Distribution.Simple main = defaultMain
System/Console/CmdArgs/Annotate.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE PatternGuards, ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable #-}+{-# OPTIONS_GHC -O0 #-} -- | This module captures annotations on a value, and builds a 'Capture' value. -- This module has two ways of writing annotations:@@ -29,7 +30,7 @@ ) where import Control.Monad-import Control.Monad.State+import Control.Monad.Trans.State import Data.Data(Data,Typeable) import Data.List import Data.Maybe@@ -189,14 +190,10 @@ (&=) :: (Data val, Data ann) => val -> ann -> val (&=) x y = addAnn (id_ x) (id_ y) --{-# NOINLINE const_ #-}-const_ :: a -> b -> b-const_ f x = x- {-# INLINE id_ #-} id_ :: a -> a-id_ x = const_ (\() -> ()) x+id_ x = case unit of () -> x+ where unit = reverse "" `seq` () ---------------------------------------------------------------------@@ -210,6 +207,8 @@ | AMany [Annotate ann] | AAtom Any | ACtor Any [Annotate ann]+ deriving Typeable+ -- specifically DOES NOT derive Data, to avoid people accidentally including it -- | Add an annotation to a value.@@ -230,7 +229,7 @@ -- -- This operation is not type safe, and may raise an exception at runtime -- if any field has the wrong type or label.-record :: Data a => a -> [Annotate b] -> Annotate b+record :: Data a => a -> [Annotate ann] -> Annotate ann record a b = ACtor (Any a) b -- | Capture the annotations from an annotated value.
System/Console/CmdArgs/Default.hs view
@@ -3,6 +3,8 @@ -- To use the default value simply write 'def'. module System.Console.CmdArgs.Default where +import Data.Int+import Data.Word -- | Class for default values. class Default a where@@ -17,6 +19,16 @@ instance Default Double where def = 0 instance Default [a] where def = [] instance Default (Maybe a) where def = Nothing++instance Default Int8 where def = 0+instance Default Int16 where def = 0+instance Default Int32 where def = 0+instance Default Int64 where def = 0+instance Default Word where def = 0+instance Default Word8 where def = 0+instance Default Word16 where def = 0+instance Default Word32 where def = 0+instance Default Word64 where def = 0 -- EXPANDY: $(2\10 instance ($(1,$ Default a$)) => Default ($(1,$ a$)) where def = ($(1,$ def))) instance (Default a1,Default a2) => Default (a1,a2) where def = (def,def)
System/Console/CmdArgs/Explicit.hs view
@@ -1,4 +1,4 @@-+{-# LANGUAGE ScopedTypeVariables, CPP #-} {-| This module constructs command lines. You may either use the helper functions ('flagNone', 'flagOpt', 'mode' etc.) or construct the type directly. These@@ -10,21 +10,25 @@ As an example of a parser: - > arguments :: Mode [(String,String)]- > arguments = mode "explicit" [] "Explicit sample program" (flagArg (upd "file") "FILE")- > [flagOpt "world" ["hello","h"] (upd "world") "WHO" "World argument"- > ,flagReq ["greeting","g"] (upd "greeting") "MSG" "Greeting to give"- > ,flagHelpSimple (("help",""):)]- > where upd msg x v = Right $ (msg,x):v+ @+ arguments :: 'Mode' [(String,String)]+ arguments = 'mode' \"explicit\" [] \"Explicit sample program\" ('flagArg' (upd \"file\") \"FILE\")+ ['flagOpt' \"world\" [\"hello\",\"h\"] (upd \"world\") \"WHO\" \"World argument\"+ ,'flagReq' [\"greeting\",\"g\"] (upd \"greeting\") \"MSG\" \"Greeting to give\"+ ,'flagHelpSimple' ((\"help\",\"\"):)]+ where upd msg x v = Right $ (msg,x):v+ @ And this can be invoked by: - > main = do- > x <- processArgs arguments- > if ("help","") `elem` xs then- > print $ helpText def arguments- > else- > print x+ @+ main = do+ xs <- 'processArgs' arguments+ if (\"help\",\"\") \`elem\` xs then+ print $ 'helpText' [] 'HelpFormatDefault' arguments+ else+ print xs+ @ /Groups/: The 'Group' structure allows flags/modes to be grouped for the purpose of displaying help. When processing command lines, the group structure is ignored.@@ -37,27 +41,118 @@ enter a mode, simply give sub-modes, and leave 'modeArgs' as @Nothing@. Alternatively, if you want one sub-mode to be selected by default, place all it's flags both in the sub-mode and the outer mode.++ /Parsing rules/: Command lines are parsed as per most GNU programs. Short arguments single+ letter flags start with @-@, longer flags start with @--@, and everything else is considered+ an argument. Anything after @--@ alone is considered to be an argument. For example:++ > -f --flag argument1 -- --argument2++ This command line passes one single letter flag (@f@), one longer flag (@flag@) and two arguments+ (@argument1@ and @--argument2@). -} module System.Console.CmdArgs.Explicit( -- * Running command lines- module System.Console.CmdArgs.Explicit.Process,+ process, processArgs, processValue, processValueIO, -- * Constructing command lines module System.Console.CmdArgs.Explicit.Type,- module System.Console.CmdArgs.Explicit,+ flagHelpSimple, flagHelpFormat, flagVersion, flagNumericVersion, flagsVerbosity, -- * Displaying help- module System.Console.CmdArgs.Explicit.Help+ module System.Console.CmdArgs.Explicit.Help,+ -- * Utilities for working with command lines+ module System.Console.CmdArgs.Explicit.ExpandArgsAt,+ module System.Console.CmdArgs.Explicit.SplitJoin,+ Complete(..), complete ) where -import System.Console.CmdArgs.Explicit.Type hiding (showRecord, (*=))+import System.Console.CmdArgs.Explicit.Type import System.Console.CmdArgs.Explicit.Process import System.Console.CmdArgs.Explicit.Help+import System.Console.CmdArgs.Explicit.ExpandArgsAt+import System.Console.CmdArgs.Explicit.SplitJoin+import System.Console.CmdArgs.Explicit.Complete import System.Console.CmdArgs.Default+import System.Console.CmdArgs.Helper import System.Console.CmdArgs.Text import System.Console.CmdArgs.Verbosity +import Control.Monad import Data.Char+import Data.Maybe+import System.Environment+import System.Exit+import System.IO +-- | Process the flags obtained by @'getArgs'@ and @'expandArgsAt'@ with a mode. Displays+-- an error and exits with failure if the command line fails to parse, or returns+-- the associated value. Implemented in terms of 'process'. This function makes+-- use of the following environment variables:+--+-- * @$CMDARGS_COMPLETE@ - causes the program to produce completions using 'complete', then exit.+-- Completions are based on the result of 'getArgs', the index of the current argument is taken+-- from @$CMDARGS_COMPLETE@ (set it to @-@ to complete the last argument), and the index within+-- that argument is taken from @$CMDARGS_COMPLETE_POS@ (if set).+--+-- * @$CMDARGS_HELPER@\/@$CMDARGS_HELPER_/PROG/@ - uses the helper mechanism for entering command+-- line programs as described in "System.Console.CmdArgs.Helper".+processArgs :: Mode a -> IO a+processArgs m = do+ env <- getEnvironment+ case lookup "CMDARGS_COMPLETE" env of+ Just x -> do+ args <- getArgs+ let argInd = fromMaybe (length args - 1) $ readMay x+ argPos = fromMaybe (if argInd >= 0 && argInd < length args then length (args !! argInd) else 0) $+ readMay =<< lookup "CMDARGS_COMPLETE_POS" env+ print $ complete m (concatMap words args) (argInd,argPos)+ exitWith ExitSuccess+ Nothing -> do+ nam <- getProgName+ let var = mplus (lookup ("CMDARGS_HELPER_" ++ show (map toUpper $ head $ modeNames m ++ [nam])) env)+ (lookup "CMDARGS_HELPER" env)+ case var of+ Nothing -> processValueIO m =<< (if modeExpandAt m then expandArgsAt else return) =<< getArgs+ Just cmd -> do+ res <- execute cmd m []+ case res of+ Left err -> do+ hPutStrLn stderr $ "Error when running helper " ++ cmd+ hPutStrLn stderr err+ exitFailure+ Right args -> processValueIO m args+++readMay :: Read a => String -> Maybe a+readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of+ [x] -> Just x+ _ -> Nothing+++#if __GLASGOW_HASKELL__ < 800+errorWithoutStackTrace :: String -> a+errorWithoutStackTrace = error+#endif++-- | Process a list of flags (usually obtained from @'getArgs'@ and @'expandArgsAt'@) with a mode.+-- Throws an error if the command line fails to parse, or returns+-- the associated value. Implemeneted in terms of 'process'. This function+-- does not take account of any environment variables that may be set+-- (see 'processArgs').+--+-- If you are in 'IO' you will probably get a better user experience by calling 'processValueIO'.+processValue :: Mode a -> [String] -> a+processValue m xs = case process m xs of+ Left x -> errorWithoutStackTrace x+ Right x -> x++-- | Like 'processValue' but on failure prints to stderr and exits the program.+processValueIO :: Mode a -> [String] -> IO a+processValueIO m xs = case process m xs of+ Left x -> do hPutStrLn stderr x; exitFailure+ Right x -> return x++ -- | Create a help flag triggered by @-?@/@--help@. flagHelpSimple :: (a -> a) -> Flag a flagHelpSimple f = flagNone ["help","?"] f "Display help message"@@ -78,7 +173,7 @@ Right (a,b) -> Right $ f a b v format :: String -> Either String (HelpFormat,TextFormat)- format xs = foldl (\acc x -> either Left (f x) acc) (Right def) (sep xs)+ format xs = foldl (\acc x -> f x =<< acc) (Right def) (sep xs) where sep = words . map (\x -> if x `elem` ":," then ' ' else toLower x) f x (a,b) = case x of@@ -87,6 +182,8 @@ "def" -> Right (HelpFormatDefault,b) "html" -> Right (a,HTML) "text" -> Right (a,defaultWrap)+ "bash" -> Right (HelpFormatBash,Wrap 1000000)+ "zsh" -> Right (HelpFormatZsh ,Wrap 1000000) _ | all isDigit x -> Right (a,Wrap $ read x) _ -> Left "unrecognised help format, expected one of: all one def html text <NUMBER>" @@ -94,6 +191,10 @@ -- | Create a version flag triggered by @-V@/@--version@. flagVersion :: (a -> a) -> Flag a flagVersion f = flagNone ["version","V"] f "Print version information"++-- | Create a version flag triggered by @--numeric-version@.+flagNumericVersion :: (a -> a) -> Flag a+flagNumericVersion f = flagNone ["numeric-version"] f "Print just the version number" -- | Create verbosity flags triggered by @-v@/@--verbose@ and
+ System/Console/CmdArgs/Explicit/Complete.hs view
@@ -0,0 +1,201 @@+{-# LANGUAGE PatternGuards #-}++-- | This module does command line completion+module System.Console.CmdArgs.Explicit.Complete(+ Complete(..), complete,+ completeBash, completeZsh+ ) where++import System.Console.CmdArgs.Explicit.Type+import Control.Monad+import Data.List+import Data.Maybe+++-- | How to complete a command line option.+-- The 'Show' instance is suitable for parsing from shell scripts.+data Complete+ = CompleteValue String -- ^ Complete to a particular value+ | CompleteFile String FilePath -- ^ Complete to a prefix, and a file+ | CompleteDir String FilePath -- ^ Complete to a prefix, and a directory+ deriving (Eq,Ord)++instance Show Complete where+ show (CompleteValue a) = "VALUE " ++ a+ show (CompleteFile a b) = "FILE " ++ a ++ " " ++ b+ show (CompleteDir a b) = "DIR " ++ a ++ " " ++ b++ showList xs = showString $ unlines (map show xs)+++prepend :: String -> Complete -> Complete+prepend a (CompleteFile b c) = CompleteFile (a++b) c+prepend a (CompleteDir b c) = CompleteDir (a++b) c+prepend a (CompleteValue b) = CompleteValue (a++b)+++-- | Given a current state, return the set of commands you could type now, in preference order.+complete+ :: Mode a -- ^ Mode specifying which arguments are allowed+ -> [String] -- ^ Arguments the user has already typed+ -> (Int,Int) -- ^ 0-based index of the argument they are currently on, and the position in that argument+ -> [Complete]+-- Roll forward looking at modes, and if you match a mode, enter it+-- If the person just before is a flag without arg, look at how you can complete that arg+-- If your prefix is a complete flag look how you can complete that flag+-- If your prefix looks like a flag, look for legitimate flags+-- Otherwise give a file/dir if they are arguments to this mode, and all flags+-- If you haven't seen any args/flags then also autocomplete to any child modes+complete mode_ args_ (i,_) = nub $ followArgs mode args now+ where+ (seen,next) = splitAt i args_+ now = head $ next ++ [""]+ (mode,args) = followModes mode_ seen+++-- | Given a mode and some arguments, try and drill down into the mode+followModes :: Mode a -> [String] -> (Mode a, [String])+followModes m (x:xs) | Just m2 <- pickBy modeNames x $ modeModes m = followModes m2 xs+followModes m xs = (m,xs)+++pickBy :: (a -> [String]) -> String -> [a] -> Maybe a+pickBy f name xs = find (\x -> name `elem` f x) xs `mplus`+ find (\x -> any (name `isPrefixOf`) (f x)) xs+++-- | Follow args deals with all seen arguments, then calls on to deal with the next one+followArgs :: Mode a -> [String] -> (String -> [Complete])+followArgs m = first+ where+ first [] = expectArgFlagMode (modeModes m) (argsPick 0) (modeFlags m)+ first xs = norm 0 xs++ -- i is the number of arguments that have gone past+ norm i [] = expectArgFlag (argsPick i) (modeFlags m)+ norm i ("--":xs) = expectArg $ argsPick (i + length xs)+ norm i (('-':'-':x):xs) | null b, flagInfo flg == FlagReq = val i flg xs+ | otherwise = norm i xs+ where (a,b) = break (== '=') x+ flg = getFlag a+ norm i (('-':x:y):xs) = case flagInfo flg of+ FlagReq | null y -> val i flg xs+ | otherwise -> norm i xs+ FlagOpt{} -> norm i xs+ _ | "=" `isPrefixOf` y -> norm i xs+ | null y -> norm i xs+ | otherwise -> norm i (('-':y):xs)+ where flg = getFlag [x]+ norm i (x:xs) = norm (i+1) xs++ val i flg [] = expectVal flg+ val i flg (x:xs) = norm i xs++ argsPick i = let (lst,end) = modeArgs m in if i < length lst then Just $ lst !! i else end++ -- if you can't find the flag, pick one that is FlagNone (has all the right fallback)+ getFlag x = fromMaybe (flagNone [] id "") $ pickBy flagNames x $ modeFlags m+++expectArgFlagMode :: [Mode a] -> Maybe (Arg a) -> [Flag a] -> String -> [Complete]+expectArgFlagMode mode arg flag x =+ (if "-" `isPrefixOf` x then [] else expectMode mode x) +++ expectArgFlag arg flag x++expectArgFlag :: Maybe (Arg a) -> [Flag a] -> String -> [Complete]+expectArgFlag arg flag x+ | "-" `isPrefixOf` x = expectFlag flag x ++ [CompleteValue "-" | x == "-", isJust arg]+ | otherwise = expectArg arg x ++ expectFlag flag x++expectMode :: [Mode a] -> String -> [Complete]+expectMode mode = expectStrings (map modeNames mode)++expectArg :: Maybe (Arg a) -> String -> [Complete]+expectArg Nothing x = []+expectArg (Just arg) x = expectFlagHelp (argType arg) x++expectFlag :: [Flag a] -> String -> [Complete]+expectFlag flag x+ | (a,_:b) <- break (== '=') x = case pickBy (map f . flagNames) a flag of+ Nothing -> []+ Just flg -> map (prepend (a ++ "=")) $ expectVal flg b+ | otherwise = expectStrings (map (map f . flagNames) flag) x+ where f x = "-" ++ ['-' | length x > 1] ++ x++expectVal :: Flag a -> String -> [Complete]+expectVal flg = expectFlagHelp (flagType flg)++expectStrings :: [[String]] -> String -> [Complete]+expectStrings xs x = map CompleteValue $ concatMap (take 1 . filter (x `isPrefixOf`)) xs++expectFlagHelp :: FlagHelp -> String -> [Complete]+expectFlagHelp typ x = case typ of+ "FILE" -> [CompleteFile "" x]+ "DIR" -> [CompleteDir "" x]+ "FILE/DIR" -> [CompleteFile "" x, CompleteDir "" x]+ "DIR/FILE" -> [CompleteDir "" x, CompleteFile "" x]+ '[':s | "]" `isSuffixOf` s -> expectFlagHelp (init s) x+ _ -> []+++---------------------------------------------------------------------+-- BASH SCRIPT++completeBash :: String -> [String]+completeBash prog =+ ["# Completion for " ++ prog+ ,"# Generated by CmdArgs: http://community.haskell.org/~ndm/cmdargs/"+ ,"_" ++ prog ++ "()"+ ,"{"+ ," # local CMDARGS_DEBUG=1 # uncomment to debug this script"+ ,""+ ," COMPREPLY=()"+ ," function add { COMPREPLY[((${#COMPREPLY[@]} + 1))]=$1 ; }"+ ," IFS=$'\\n\\r'"+ ,""+ ," export CMDARGS_COMPLETE=$((${COMP_CWORD} - 1))"+ ," result=`" ++ prog ++ " ${COMP_WORDS[@]:1}`"+ ,""+ ," if [ -n $CMDARGS_DEBUG ]; then"+ ," echo Call \\(${COMP_WORDS[@]:1}, $CMDARGS_COMPLETE\\) > cmdargs.tmp"+ ," echo $result >> cmdargs.tmp"+ ," fi"+ ," unset CMDARGS_COMPLETE"+ ," unset CMDARGS_COMPLETE_POS"+ ,""+ ," for x in $result ; do"+ ," case $x in"+ ," VALUE\\ *)"+ ," add ${x:6}"+ ," ;;"+ ," FILE\\ *)"+ ," local prefix=`expr match \"${x:5}\" '\\([^ ]*\\)'`"+ ," local match=`expr match \"${x:5}\" '[^ ]* \\(.*\\)'`"+ ," for x in `compgen -f -- \"$match\"`; do"+ ," add $prefix$x"+ ," done"+ ," ;;"+ ," DIR\\ *)"+ ," local prefix=`expr match \"${x:4}\" '\\([^ ]*\\)'`"+ ," local match=`expr match \"${x:4}\" '[^ ]* \\(.*\\)'`"+ ," for x in `compgen -d -- \"$match\"`; do"+ ," add $prefix$x"+ ," done"+ ," ;;"+ ," esac"+ ," done"+ ," unset IFS"+ ,""+ ," if [ -n $CMDARGS_DEBUG ]; then"+ ," echo echo COMPREPLY: ${#COMPREPLY[@]} = ${COMPREPLY[@]} >> cmdargs.tmp"+ ," fi"+ ,"}"+ ,"complete -o bashdefault -F _" ++ prog ++ " " ++ prog+ ]+++---------------------------------------------------------------------+-- ZSH SCRIPT++completeZsh :: String -> [String]+completeZsh _ = ["echo TODO: help add Zsh completions to cmdargs programs"]
+ System/Console/CmdArgs/Explicit/ExpandArgsAt.hs view
@@ -0,0 +1,33 @@+{-# LANGUAGE RecordWildCards #-}+module System.Console.CmdArgs.Explicit.ExpandArgsAt(expandArgsAt) where++import System.FilePath+++-- | Expand @\@@ directives in a list of arguments, usually obtained from 'getArgs'.+-- As an example, given the file @test.txt@ with the lines @hello@ and @world@:+--+-- > expandArgsAt ["@test.txt","!"] == ["hello","world","!"]+--+-- Any @\@@ directives in the files will be recursively expanded (raising an error+-- if there is infinite recursion).+--+-- To supress @\@@ expansion, pass any @\@@ arguments after @--@.+expandArgsAt :: [String] -> IO [String]+expandArgsAt args = do+ ebefore <- mapM (f [] ".") before+ return $ concat ebefore ++ after+ where+ (before,after) = break (== "--") args++ f seen dir ('@':x)+ | x `elem` seen = error $ unlines $+ "System.Console.CmdArgs.Explicit.expandArgsAt, recursion in @ directives:" :+ map (" "++) (reverse $ x:seen)+ | length seen > 15 = error $ unlines $+ "System.Console.CmdArgs.Explicit.expandArgsAt, over 15 @ directives deep:" :+ map (" "++) (reverse seen)+ | otherwise = do+ src <- readFile $ dir </> x+ fmap concat $ mapM (f (x:seen) (takeDirectory x)) $ lines src+ f _ _ x = return [x]
System/Console/CmdArgs/Explicit/Help.hs view
@@ -1,3 +1,4 @@+{-# OPTIONS_GHC -fno-warn-orphans #-} -- Not good reasons, but shouldn't be too fatal {- Sample renderings: @@ -6,7 +7,7 @@ programname [OPTIONS] FILE1 FILE2 [FILES] Program to perform some action- + -f --flag description Flag grouping: -a --another description@@ -45,6 +46,7 @@ module System.Console.CmdArgs.Explicit.Help(HelpFormat(..), helpText) where import System.Console.CmdArgs.Explicit.Type+import System.Console.CmdArgs.Explicit.Complete import System.Console.CmdArgs.Text import System.Console.CmdArgs.Default import Data.List@@ -56,6 +58,8 @@ = HelpFormatDefault -- ^ Equivalent to 'HelpFormatAll' if there is not too much text, otherwise 'HelpFormatOne'. | HelpFormatOne -- ^ Display only the first mode. | HelpFormatAll -- ^ Display all modes.+ | HelpFormatBash -- ^ Bash completion information+ | HelpFormatZsh -- ^ Z shell completion information deriving (Read,Show,Enum,Bounded,Eq,Ord) instance Default HelpFormat where def = HelpFormatDefault@@ -70,13 +74,20 @@ instance Show (Arg a) where show = show . argType --- | Generate a help message from a mode.-helpText :: HelpFormat -> Mode a -> [Text]-helpText HelpFormatDefault = helpTextDefault-helpText HelpFormatOne = helpTextOne-helpText HelpFormatAll = helpTextAll+-- | Generate a help message from a mode. The first argument is a prefix,+-- which is prepended when not using 'HelpFormatBash' or 'HelpFormatZsh'.+helpText :: [String] -> HelpFormat -> Mode a -> [Text]+helpText pre HelpFormatDefault x = helpPrefix pre ++ helpTextDefault x+helpText pre HelpFormatOne x = helpPrefix pre ++ helpTextOne x+helpText pre HelpFormatAll x = helpPrefix pre ++ helpTextAll x+helpText pre HelpFormatBash x = map Line $ completeBash $ head $ modeNames x ++ ["unknown"]+helpText pre HelpFormatZsh x = map Line $ completeZsh $ head $ modeNames x ++ ["unknown"] +helpPrefix :: [String] -> [Text]+helpPrefix xs = map Line xs ++ [Line "" | not $ null xs]++ helpTextDefault x = if length all > 40 then one else all where all = helpTextAll x one = helpTextOne x@@ -104,7 +115,7 @@ -- > <options> helpTextOne :: Mode a -> [Text] helpTextOne m = pre ++ ms ++ suf- where + where (pre,suf) = helpTextMode m ms = space $ [Line "Commands:" | not $ null $ groupUnnamed $ modeGroupModes m] ++ helpGroup f (modeGroupModes m) f m = return $ cols [concat $ take 1 $ modeNames m, ' ' : modeHelp m]@@ -116,7 +127,7 @@ pre = [Line $ unwords $ take 1 (modeNames x) ++ ["[COMMAND] ..." | notNullGroup modes] ++ ["[OPTIONS]" | not $ null $ fromGroup flags] ++- map argType (maybeToList $ modeArgs x)] +++ helpArgs (modeArgs x)] ++ [Line $ " " ++ modeHelp x | not $ null $ modeHelp x] suf = space ([Line "Flags:" | mixedGroup flags] ++@@ -127,6 +138,12 @@ helpGroup :: (a -> [Text]) -> Group a -> [Text] helpGroup f xs = concatMap f (groupUnnamed xs) ++ concatMap g (groupNamed xs) where g (a,b) = Line (a ++ ":") : concatMap f b+++helpArgs :: ([Arg a], Maybe (Arg a)) -> [String]+helpArgs (ys,y) = [['['|o] ++ argType x ++ [']'|o] | (i,x) <- zip [0..] xs, let o = False && req <= i]+ where xs = ys ++ maybeToList y+ req = maximum $ 0 : [i | (i,x) <- zip [1..] xs, argRequire x] helpFlag :: Flag a -> [Text]
System/Console/CmdArgs/Explicit/Process.hs view
@@ -1,35 +1,13 @@--module System.Console.CmdArgs.Explicit.Process(process, processValue, processArgs) where+{-# LANGUAGE RecordWildCards #-}+module System.Console.CmdArgs.Explicit.Process(process) where import System.Console.CmdArgs.Explicit.Type import Control.Arrow import Data.List import Data.Maybe-import System.Environment-import System.Exit --- | Process the flags obtained by @getArgs@ with a mode. Displays--- an error and exits with failure if the command line fails to parse, or returns--- the associated value. Implemented in terms of 'process'.-processArgs :: Mode a -> IO a-processArgs m = do- xs <- getArgs- case process m xs of- Left x -> do putStrLn x; exitFailure- Right x -> return x----- | Process a list of flags (usually obtained from @getArgs@) with a mode. Displays--- an error and exits with failure if the command line fails to parse, or returns--- the associated value. Implemeneted in terms of 'process'.-processValue :: Mode a -> [String] -> a-processValue m xs = case process m xs of- Left x -> error x- Right x -> x----- | Process a list of flags (usually obtained from @getArgs@) with a mode. Returns+-- | Process a list of flags (usually obtained from @getArgs@/@expandArgsAt@) with a mode. Returns -- @Left@ and an error message if the command line fails to parse, or @Right@ and -- the associated value. process :: Mode a -> [String] -> Either String a@@ -42,10 +20,10 @@ Ambiguous xs -> Left $ ambiguous "mode" a xs Found x -> processMode x as NotFound- | isNothing (modeArgs m) && args /= [] &&+ | null (fst $ modeArgs m) && isNothing (snd $ modeArgs m) && args /= [] && not (null $ modeModes m) && not ("-" `isPrefixOf` concat args) -> Left $ missing "mode" $ concatMap modeNames $ modeModes m- | otherwise -> either Left (modeCheck m) $ processFlags m (modeValue m) args+ | otherwise -> modeCheck m =<< processFlags m (modeValue m) args where (find,a,as) = case args of [] -> (NotFound,"",[])@@ -53,15 +31,19 @@ data S a = S- {val :: a- ,args :: [String]- ,errs :: [String]+ {val :: a -- The value you are accumulating+ ,args :: [String] -- The arguments you are processing through+ ,argsCount :: Int -- The number of unnamed arguments you have seen+ ,errs :: [String] -- The errors you have seen } -stop :: S a -> Maybe (Either String a)-stop s | not $ null $ errs s = Just $ Left $ last $ errs s- | null $ args s = Just $ Right $ val s- | otherwise = Nothing+stop :: Mode a -> S a -> Maybe (Either String a)+stop mode S{..}+ | not $ null errs = Just $ Left $ last errs+ | null args = Just $ if argsCount >= mn then Right val else+ Left $ "Expected " ++ (if Just mn == mx then "exactly" else "at least") ++ show mn ++ " unnamed arguments, but got only " ++ show argsCount+ | otherwise = Nothing+ where (mn, mx) = argsRange mode err :: S a -> String -> S a err s x = s{errs=x:errs s}@@ -73,8 +55,8 @@ processFlags :: Mode a -> a -> [String] -> Either String a-processFlags mode val_ args_ = f $ S val_ args_ []- where f s = fromMaybe (f $ processFlag mode s) $ stop s+processFlags mode val_ args_ = f $ S val_ args_ 0 []+ where f s = fromMaybe (f $ processFlag mode s) $ stop mode s pickFlags long mode = [(filter (\x -> (length x > 1) == long) $ flagNames flag,(flagInfo flag,flag)) | flag <- modeFlags mode]@@ -117,21 +99,32 @@ processFlag mode s_@S{args="--":ys} = f s_{args=ys}- where f s | isJust $ stop s = s+ where f s | isJust $ stop mode s = s | otherwise = f $ processArg mode s processFlag mode s = processArg mode s -processArg mode s_@S{args=x:ys} =- case modeArgs mode of- Nothing -> err s $ "Unhandled argument, none expected: " ++ x- Just arg -> case argValue arg x (val s) of+processArg mode s_@S{args=x:ys, argsCount=count} = case argsPick mode count of+ Nothing -> err s $ "Unhandled argument, " ++ str ++ " expected: " ++ x+ where str = if count == 0 then "none" else "at most " ++ show count+ Just arg -> case argValue arg x (val s) of Left e -> err s $ "Unhandled argument, " ++ e ++ ": " ++ x Right v -> s{val=v} where- s = s_{args=ys}+ s = s_{args=ys, argsCount=count+1} +-- find the minimum and maximum allowed number of arguments (Nothing=infinite)+argsRange :: Mode a -> (Int, Maybe Int)+argsRange Mode{modeArgs=(lst,end)} = (mn,mx)+ where mn = length $ dropWhile (not . argRequire) $ reverse $ lst ++ maybeToList end+ mx = if isJust end then Nothing else Just $ length lst+++argsPick :: Mode a -> Int -> Maybe (Arg a)+argsPick Mode{modeArgs=(lst,end)} i = if i < length lst then Just $ lst !! i else end++ --------------------------------------------------------------------- -- UTILITIES @@ -154,4 +147,3 @@ (xs,_) -> Ambiguous $ map fst xs where match op = [(head ys,v) | (xs,v) <- names, let ys = filter (op value) xs, ys /= []]-
+ System/Console/CmdArgs/Explicit/SplitJoin.hs view
@@ -0,0 +1,54 @@+{-# LANGUAGE RecordWildCards #-}+module System.Console.CmdArgs.Explicit.SplitJoin(splitArgs, joinArgs) where++import Data.Char+import Data.Maybe+++-- | Given a sequence of arguments, join them together in a manner that could be used on+-- the command line, giving preference to the Windows @cmd@ shell quoting conventions.+--+-- For an alternative version, intended for actual running the result in a shell, see "System.Process.showCommandForUser"+joinArgs :: [String] -> String+joinArgs = unwords . map f+ where+ f x = q ++ g x ++ q+ where+ hasSpace = any isSpace x+ q = ['\"' | hasSpace || null x]++ g ('\\':'\"':xs) = '\\':'\\':'\\':'\"': g xs+ g "\\" | hasSpace = "\\\\"+ g ('\"':xs) = '\\':'\"': g xs+ g (x:xs) = x : g xs+ g [] = []+++data State = Init -- either I just started, or just emitted something+ | Norm -- I'm seeing characters+ | Quot -- I've seen a quote++-- | Given a string, split into the available arguments. The inverse of 'joinArgs'.+splitArgs :: String -> [String]+splitArgs = join . f Init+ where+ -- Nothing is start a new string+ -- Just x is accumulate onto the existing string+ join :: [Maybe Char] -> [String]+ join [] = []+ join xs = map fromJust a : join (drop 1 b)+ where (a,b) = break isNothing xs++ f Init (x:xs) | isSpace x = f Init xs+ f Init "\"\"" = [Nothing]+ f Init "\"" = [Nothing]+ f Init xs = f Norm xs+ f m ('\"':'\"':'\"':xs) = Just '\"' : f m xs+ f m ('\\':'\"':xs) = Just '\"' : f m xs+ f m ('\\':'\\':'\"':xs) = Just '\\' : f m ('\"':xs)+ f Norm ('\"':xs) = f Quot xs+ f Quot ('\"':'\"':xs) = Just '\"' : f Norm xs+ f Quot ('\"':xs) = f Norm xs+ f Norm (x:xs) | isSpace x = Nothing : f Init xs+ f m (x:xs) = Just x : f m xs+ f m [] = []
System/Console/CmdArgs/Explicit/Type.hs view
@@ -6,7 +6,8 @@ import Data.Char import Data.List import Data.Maybe-import Data.Monoid+import Data.Semigroup hiding (Arg)+import Prelude -- | A name, either the name of a flag (@--/foo/@) or the name of a mode.@@ -22,7 +23,7 @@ --------------------------------------------------------------------- -- UTILITY --- | Parse a boolean, accepts as True: true yes on enabled 1. +-- | Parse a boolean, accepts as True: true yes on enabled 1. parseBool :: String -> Maybe Bool parseBool s | ls `elem` true = Just True | ls `elem` false = Just False@@ -42,14 +43,17 @@ {groupUnnamed :: [a] -- ^ Normal items. ,groupHidden :: [a] -- ^ Items that are hidden (not displayed in the help message). ,groupNamed :: [(Help, [a])] -- ^ Items that have been grouped, along with a description of each group.- } deriving Show + } deriving Show instance Functor Group where fmap f (Group a b c) = Group (map f a) (map f b) (map (second $ map f) c) +instance Semigroup (Group a) where+ Group x1 x2 x3 <> Group y1 y2 y3 = Group (x1++y1) (x2++y2) (x3++y3)+ instance Monoid (Group a) where mempty = Group [] [] []- mappend (Group x1 x2 x3) (Group y1 y2 y3) = Group (x1++y1) (x2++y2) (x3++y3)+ mappend = (<>) -- | Convert a group into a list. fromGroup :: Group a -> [a]@@ -63,25 +67,28 @@ --------------------------------------------------------------------- -- TYPES -showRecord x ys = x ++ " {" ++ intercalate ", " ys ++ "}"-a *= b = a ++ " = " ++ show b----- | A mode. Each mode has three main features:+-- | A mode. Do not use the 'Mode' constructor directly, instead+-- use 'mode' to construct the 'Mode' and then record updates.+-- Each mode has three main features: -- -- * A list of submodes ('modeGroupModes') -- -- * A list of flags ('modeGroupFlags') -- -- * Optionally an unnamed argument ('modeArgs')+--+-- To produce the help information for a mode, either use 'helpText' or 'show'. data Mode a = Mode {modeGroupModes :: Group (Mode a) -- ^ The available sub-modes ,modeNames :: [Name] -- ^ The names assigned to this mode (for the root mode, this name is used as the program name) ,modeValue :: a -- ^ Value to start with- ,modeCheck :: a -> Either String a -- checking a value is correct+ ,modeCheck :: a -> Either String a -- ^ Check the value reprsented by a mode is correct, after applying all flags+ ,modeReform :: a -> Maybe [String] -- ^ Given a value, try to generate the input arguments.+ ,modeExpandAt :: Bool -- ^ Expand @\@@ arguments with 'expandArgsAt', defaults to 'True', only applied if using an 'IO' processing function.+ -- Only the root 'Mode's value will be used. ,modeHelp :: Help -- ^ Help text ,modeHelpSuffix :: [String] -- ^ A longer help suffix displayed after a mode- ,modeArgs :: Maybe (Arg a) -- ^ An unnamed argument+ ,modeArgs :: ([Arg a], Maybe (Arg a)) -- ^ The unnamed arguments, a series of arguments, followed optionally by one for all remaining slots ,modeGroupFlags :: Group (Flag a) -- ^ Groups of flags } @@ -97,8 +104,8 @@ -- -- -- > FlagReq FlagOpt FlagOptRare/FlagNone--- > -xfoo -x=foo -x=foo -x= -foo--- > -x foo -x=foo -x foo -x= foo+-- > -xfoo -x=foo -x=foo -x -foo+-- > -x foo -x=foo -x foo -x foo -- > -x=foo -x=foo -x=foo -x=foo -- > --xx foo --xx=foo --xx foo --xx foo -- > --xx=foo --xx=foo --xx=foo --xx=foo@@ -140,6 +147,7 @@ data Arg a = Arg {argValue :: Update a -- ^ A way of processing the argument. ,argType :: FlagHelp -- ^ The type of data for the argument, i.e. FILE\/DIR\/EXT+ ,argRequire :: Bool -- ^ Is at least one of these arguments required, the command line will fail if none are set } @@ -157,11 +165,11 @@ where checkGroup :: Group a -> Maybe String checkGroup x = msum- [check "Empty group name" $ all (not . null . fst) $ groupNamed x- ,check "Empty group contents" $ all (not . null . snd) $ groupNamed x]+ [check "Empty group name" $ not $ any (null . fst) $ groupNamed x+ ,check "Empty group contents" $ not $ any (null . snd) $ groupNamed x] checkNames :: String -> [Name] -> Maybe String- checkNames msg xs = check "Empty names" (all (not . null) xs) `mplus` do+ checkNames msg xs = check "Empty names" (not (any null xs)) `mplus` do bad <- listToMaybe $ xs \\ nub xs let dupe = filter (== bad) xs return $ "Sanity check failed, multiple " ++ msg ++ ": " ++ unwords (map show dupe)@@ -174,11 +182,14 @@ --------------------------------------------------------------------- -- REMAP +-- | Like functor, but where the the argument isn't just covariant. class Remap m where+ -- | Convert between two values. remap :: (a -> b) -- ^ Embed a value -> (b -> (a, a -> b)) -- ^ Extract the mode and give a way of re-embedding -> m a -> m b +-- | Restricted version of 'remap' where the values are isomorphic. remap2 :: Remap m => (a -> b) -> (b -> a) -> m a -> m b remap2 f g = remap f (\x -> (g x, f)) @@ -187,7 +198,8 @@ {modeGroupModes = fmap (remap f g) $ modeGroupModes x ,modeValue = f $ modeValue x ,modeCheck = \v -> let (a,b) = g v in fmap b $ modeCheck x a- ,modeArgs = fmap (remap f g) $ modeArgs x+ ,modeReform = modeReform x . fst . g+ ,modeArgs = (fmap (remap f g) *** fmap (remap f g)) $ modeArgs x ,modeGroupFlags = fmap (remap f g) $ modeGroupFlags x} instance Remap Flag where@@ -196,20 +208,27 @@ instance Remap Arg where remap f g x = x{argValue = remapUpdate f g $ argValue x} +-- | Version of 'remap' for the 'Update' type alias.+remapUpdate :: (a -> b) -> (b -> (a, a -> b)) -> Update a -> Update b remapUpdate f g upd = \s v -> let (a,b) = g v in fmap b $ upd s a --------------------------------------------------------------------- -- MODE/MODES CREATORS +-- | Create an empty mode specifying only 'modeValue'. All other fields will usually be populated+-- using record updates.+modeEmpty :: a -> Mode a+modeEmpty x = Mode mempty [] x Right (const Nothing) True "" [] ([],Nothing) mempty+ -- | Create a mode with a name, an initial value, some help text, a way of processing arguments -- and a list of flags. mode :: Name -> a -> Help -> Arg a -> [Flag a] -> Mode a-mode name value help arg flags = Mode (toGroup []) [name] value Right help [] (Just arg) $ toGroup flags+mode name value help arg flags = (modeEmpty value){modeNames=[name], modeHelp=help, modeArgs=([],Just arg), modeGroupFlags=toGroup flags} -- | Create a list of modes, with a program name, an initial value, some help text and the child modes. modes :: String -> a -> Help -> [Mode a] -> Mode a-modes name value help xs = Mode (toGroup xs) [name] value Right help [] Nothing $ toGroup []+modes name value help xs = (modeEmpty value){modeNames=[name], modeHelp=help, modeGroupModes=toGroup xs} ---------------------------------------------------------------------@@ -233,7 +252,7 @@ -- | Create an argument flag, with an update function and the type of the argument. flagArg :: Update a -> FlagHelp -> Arg a-flagArg upd typ = Arg upd typ+flagArg upd typ = Arg upd typ False -- | Create a boolean flag, with a list of flag names, an update function and some help text. flagBool :: [Name] -> (Bool -> a -> a) -> Help -> Flag a
System/Console/CmdArgs/GetOpt.hs view
@@ -9,6 +9,7 @@ ) where import System.Console.CmdArgs.Explicit+import System.Console.GetOpt(OptDescr(..), ArgDescr(..)) -- | What to do with options following non-options.@@ -16,39 +17,15 @@ -- /Changes:/ Only 'Permute' is allowed, both @RequireOrder@ and @ReturnInOrder@ -- have been removed. data ArgOrder a = Permute----- | Each 'OptDescr' describes a single option/flag.------ The arguments to 'Option' are:------ * list of short option characters------ * list of long option strings (without "--", may not be 1 character long)------ * argument descriptor------ * explanation of option for userdata-data OptDescr a = Option- [Char]- [String]- (ArgDescr a)- String----- | 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+instance Functor ArgOrder where+ fmap _ Permute = Permute -- | Return a string describing the usage of a command, derived from--- the header (first argument) and the options described by the +-- the header (first argument) and the options described by the -- second argument. usageInfo :: String -> [OptDescr a] -> String-usageInfo desc flags = show $ convert desc flags+usageInfo desc flags = unlines $ desc : drop 2 (lines $ show $ convert "" flags) -- | Process the command-line, and return the list of values that matched@@ -58,7 +35,7 @@ -- -- * The option descriptions (see 'OptDescr') ----- * The actual command line arguments (presumably got from +-- * The actual command line arguments (presumably got from -- 'System.Environment.getArgs'). -- -- 'getOpt' returns a triple consisting of the option arguments, a list
+ System/Console/CmdArgs/Helper.hs view
@@ -0,0 +1,327 @@+{-# LANGUAGE RecordWildCards, TypeSynonymInstances, FlexibleInstances #-}++-- | Module for implementing CmdArgs helpers. A CmdArgs helper is an external program,+-- that helps a user construct the command line arguments. To use a helper set the+-- environment variable @$CMDARGS_HELPER@ (or @$CMDARGS_HELPER_/YOURPROGRAM/@) to+-- one of:+--+-- * @echo /foo/@ will cause @/foo/@ to be used as the command arguments.+--+-- * @cmdargs-browser@ will cause a web browser to appear to help entering the arguments.+-- For this command to work, you will need to install the @cmdargs-browser@ package:+-- <http://hackage.haskell.org/package/cmdargs-browser>+module System.Console.CmdArgs.Helper(+ -- * Called by the main program+ execute,+ -- * Called by the helper program+ Unknown, receive, reply, comment+ ) where+-- Should really be under Explicit, but want to export it top-level as Helper++import System.Console.CmdArgs.Explicit.Type+import System.Console.CmdArgs.Explicit.SplitJoin+import System.Process+import Control.Exception+import Control.Monad+import Data.Char+import Data.IORef+import Data.List+import Data.Maybe+import System.Exit+import System.IO+import System.IO.Unsafe+++hOut h x = do+ hPutStrLn h x+ hFlush h+++-- | Run a remote command line entry.+execute+ :: String -- ^ Name of the command to run, e.g. @echo argument@, @cmdargs-browser@+ -> Mode a -- ^ Mode to run remotely+ -> [String] -- ^ Initial set of command line flags (not supported by all helpers)+ -> IO (Either String [String]) -- ^ Either an error message, or a list of flags to use+execute cmd mode args+ | "echo" == takeWhile (not . isSpace) cmd = return $ Right $ splitArgs $ drop 4 cmd+ | otherwise = withBuffering stdout NoBuffering $ do+ (Just hin, Just hout, _, _) <- createProcess (shell cmd){std_in=CreatePipe, std_out=CreatePipe}+ -- none of the buffering seems necessary in practice, but better safe than sorry+ hSetBuffering hin LineBuffering+ hSetBuffering hout LineBuffering+ (m, ans) <- saveMode mode+ hOut hin m+ loop ans hin hout+ where+ loop ans hin hout = do+ x <- hGetLine hout+ if "Result " `isPrefixOf` x then+ return $ read $ drop 7 x+ else if "Send " `isPrefixOf` x then do+ hOut hin =<< ans (drop 5 x)+ loop ans hin hout+ else if "#" `isPrefixOf` x then do+ hOut stdout x+ loop ans hin hout+ else+ return $ Left $ "Unexpected message from program: " ++ show x+++withBuffering hndl mode act = bracket+ (do old <- hGetBuffering hndl; hSetBuffering hndl mode; return old)+ (hSetBuffering hndl)+ (const act)+++-- | Unknown value, representing the values stored within the 'Mode' structure. While the values+-- are not observable, they behave identically to the original values.+newtype Unknown = Unknown {fromUnknown :: Value} -- wrap Value so the Pack instance doesn't leak+++-- | Receive information about the mode to display.+receive :: IO (Mode Unknown)+receive = do+ m <- getLine+ return $ remap2 Unknown fromUnknown $ loadMode m $ \msg -> unsafePerformIO $ do+ hOut stdout $ "Send " ++ msg+ getLine+++-- | Send a reply with either an error, or a list of flags to use. This function exits the helper program.+reply :: Either String [String] -> IO ()+reply x = do+ hOut stdout $ "Result " ++ show x+ exitWith ExitSuccess+++-- | Send a comment which will be displayed on the calling console, mainly useful for debugging.+comment :: String -> IO ()+comment x = hOut stdout $ "# " ++ x+++---------------------------------------------------------------------+-- IO MAP++data IOMap a = IOMap (IORef (Int,[(Int,a)]))++newIOMap :: IO (IOMap a)+newIOMap = fmap IOMap $ newIORef (0, [])++addIOMap :: IOMap a -> a -> IO Int+addIOMap (IOMap ref) x = atomicModifyIORef ref $ \(i,xs) -> let j = i+1 in ((j,(j,x):xs), j)++getIOMap :: IOMap a -> Int -> IO a+getIOMap (IOMap ref) i = do (_,xs) <- readIORef ref; return $ fromJust $ lookup i xs+++---------------------------------------------------------------------+-- SERIALISE A MODE++newtype Value = Value Int+++{-# NOINLINE toValue #-}+toValue :: Mode a -> Mode Value+-- fairly safe, use of a table and pointers from one process to another, but referentially transparent+toValue x = unsafePerformIO $ do+ -- the ref accumulates, so is a space leak+ -- but it will all disappear after the helper goes, so not too much of an issue+ mp <- newIOMap+ let embed x = unsafePerformIO $ fmap Value $ addIOMap mp x+ proj (Value x) = unsafePerformIO $ getIOMap mp x+ return $ remap2 embed proj x+++saveMode :: Mode a -> IO (String, String -> IO String) -- (value, ask questions from stdin)+saveMode m = do+ mp <- newIOMap+ res <- add mp $ pack $ toValue m+ return $ (show res, fmap show . get mp . read)+ where+ add :: IOMap (Pack -> Pack) -> Pack -> IO Pack+ add mp x = flip transformM x $ \x -> case x of+ Func (NoShow f) -> do i <- addIOMap mp f; return $ FuncId i+ x -> return x++ get :: IOMap (Pack -> Pack) -> (Int,Pack) -> IO Pack+ get mp (i,x) = do+ f <- getIOMap mp i+ add mp $ f x+++loadMode :: String -> (String -> String) -> Mode Value -- given serialised, question asker, give me a value+loadMode x f = unpack $ rep $ read x+ where+ rep :: Pack -> Pack+ rep x = flip transform x $ \x -> case x of+ FuncId i -> Func $ NoShow $ \y -> rep $ read $ f $ show (i,y)+ x -> x+++-- Support data types++data Pack = Ctor String [(String, Pack)]+ | List [Pack]+ | Char Char+ | Int Int+ | Func (NoShow (Pack -> Pack))+ | FuncId Int -- Never passed to pack/unpack, always transfromed away by saveMode/loadMode+ | String String+ | None -- ^ Never generated, only used for reading in bad cases+ deriving (Show,Read)++newtype NoShow a = NoShow a+instance Show (NoShow a) where showsPrec = error "Cannot show value of type NoShow"+instance Read (NoShow a) where readsPrec = error "Cannot read value of type NoShow"+++transformM, descendM :: Monad m => (Pack -> m Pack) -> Pack -> m Pack+transformM f x = f =<< descendM (transformM f) x+descendM f x = let (a,b) = uniplate x in liftM b $ mapM f a++transform, descend :: (Pack -> Pack) -> Pack -> Pack+transform f = f . descend (transform f)+descend f x = let (a,b) = uniplate x in b $ map f a++uniplate :: Pack -> ([Pack], [Pack] -> Pack)+uniplate (List xs) = (xs, List)+uniplate (Ctor x ys) = (map snd ys, Ctor x . zip (map fst ys))+uniplate x = ([], const x)+++class Packer a where+ pack :: a -> Pack+ unpack :: Pack -> a++add a b = (a, pack b)+ctor x (Ctor y xs) | x == y = xs+ctor _ _ = []+get a b = unpack $ fromMaybe None $ lookup a b+++-- General instances++instance Packer a => Packer [a] where+ pack xs = if length ys == length zs && not (null ys) then String zs else List ys+ where ys = map (pack) xs+ zs = [x | Char x <- ys]++ unpack (String xs) = unpack $ List $ map Char xs+ unpack (List xs) = map (unpack) xs+ unpack _ = []++instance (Packer a, Packer b) => Packer (a -> b) where+ pack f = Func $ NoShow $ pack . f . unpack+ unpack (Func (NoShow f)) = unpack . f . pack++instance Packer Value where+ pack (Value x) = pack x+ unpack x = Value $ unpack x++instance Packer Char where+ pack = Char+ unpack (Char x) = x+ unpack _ = ' '++instance Packer Int where+ pack = Int+ unpack (Int x) = x+ unpack _ = -1++instance (Packer a, Packer b) => Packer (a,b) where+ pack (a,b) = Ctor "(,)" [add "fst" a, add "snd" b]+ unpack x = (get "fst" y, get "snd" y)+ where y = ctor "(,)" x++instance Packer a => Packer (Maybe a) where+ pack Nothing = Ctor "Nothing" []+ pack (Just x) = Ctor "Just" [add "fromJust" x]+ unpack x@(Ctor "Just" _) = Just $ get "fromJust" $ ctor "Just" x+ unpack _ = Nothing++instance (Packer a, Packer b) => Packer (Either a b) where+ pack (Left x) = Ctor "Left" [add "fromLeft" x]+ pack (Right x) = Ctor "Right" [add "fromRight" x]+ unpack x@(Ctor "Left" _) = Left $ get "fromLeft" $ ctor "Left" x+ unpack x@(Ctor "Right" _) = Right $ get "fromRight" $ ctor "Right" x+ unpack _ = Left $ unpack None++instance Packer Bool where+ pack True = Ctor "True" []+ pack _ = Ctor "False" []+ unpack (Ctor "True" _) = True+ unpack _ = False+++-- CmdArgs specific++instance Packer a => Packer (Group a) where+ pack Group{..} = Ctor "Group"+ [add "groupUnnamed" groupUnnamed+ ,add "groupHidden" groupHidden+ ,add "groupNamed" groupNamed]+ unpack x = let y = ctor "Group" x in Group+ {groupUnnamed = get "groupUnnamed" y+ ,groupHidden = get "groupHidden" y+ ,groupNamed = get "groupNamed" y}++instance Packer a => Packer (Mode a) where+ pack Mode{..} = Ctor "Mode"+ [add "modeGroupModes" modeGroupModes+ ,add "modeNames" modeNames+ ,add "modeHelp" modeHelp+ ,add "modeHelpSuffix" modeHelpSuffix+ ,add "modeArgs" modeArgs+ ,add "modeGroupFlags" modeGroupFlags+ ,add "modeValue" modeValue+ ,add "modeCheck" modeCheck+ ,add "modeReform" modeReform+ ,add "modeExpandAt" modeExpandAt]+ unpack x = let y = ctor "Mode" x in Mode+ {modeGroupModes = get "modeGroupModes" y+ ,modeNames = get "modeNames" y+ ,modeHelp = get "modeHelp" y+ ,modeHelpSuffix = get "modeHelpSuffix" y+ ,modeArgs = get "modeArgs" y+ ,modeGroupFlags = get "modeGroupFlags" y+ ,modeValue = get "modeValue" y+ ,modeCheck = get "modeCheck" y+ ,modeReform = get "modeReform" y+ ,modeExpandAt = get "modeExpandAt" y}++instance Packer a => Packer (Flag a) where+ pack Flag{..} = Ctor "Flag"+ [add "flagNames" flagNames+ ,add "flagInfo" flagInfo+ ,add "flagType" flagType+ ,add "flagHelp" flagHelp+ ,add "flagValue" flagValue]+ unpack x = let y = ctor "Flag" x in Flag+ {flagNames = get "flagNames" y+ ,flagInfo = get "flagInfo" y+ ,flagType = get "flagType" y+ ,flagHelp = get "flagHelp" y+ ,flagValue = get "flagValue" y}++instance Packer a => Packer (Arg a) where+ pack Arg{..} = Ctor "Arg"+ [add "argType" argType+ ,add "argRequire" argRequire+ ,add "argValue" argValue]+ unpack x = let y = ctor "Arg" x in Arg+ {argType = get "argType" y+ ,argRequire = get "argRequire" y+ ,argValue = get "argValue" y}++instance Packer FlagInfo where+ pack FlagReq = Ctor "FlagReq" []+ pack (FlagOpt x) = Ctor "FlagOpt" [add "fromFlagOpt" x]+ pack (FlagOptRare x) = Ctor "FlagOptRare" [add "fromFlagOpt" x]+ pack FlagNone = Ctor "FlagNone" []+ unpack x@(Ctor name _) = case name of+ "FlagReq" -> FlagReq+ "FlagOpt" -> FlagOpt $ get "fromFlagOpt" $ ctor name x+ "FlagOptRare" -> FlagOptRare $ get "fromFlagOpt" $ ctor name x+ "FlagNone" -> FlagNone+ unpack _ = FlagNone
System/Console/CmdArgs/Implicit.hs view
@@ -6,20 +6,21 @@ @data Sample = Sample {hello :: String} deriving (Show, Data, Typeable)@ - @sample = Sample{hello = 'def' '&=' 'help' \"World argument\" '&=' 'opt' \"world\"}@- @ '&=' summary \"Sample v1\"@+@+sample = Sample{hello = 'def' '&=' 'help' \"World argument\" '&=' 'opt' \"world\"}+ '&=' 'summary' \"Sample v1\"+@ @main = print =<< 'cmdArgs' sample@ - Attributes are used to control a number of behaviours:- + * The help message: 'help', 'typ', 'details', 'summary', 'program', 'groupname'- + * Flag behaviour: 'opt', 'enum', 'verbosity', 'ignore'- + * Flag name assignment: 'name', 'explicit'- + * Controlling non-flag arguments: 'args', 'argPos' * multi-mode programs: 'modes', 'auto'@@ -43,10 +44,32 @@ Even using this scheme, sometimes GHC's optimisations may share values who have the same annotation. To disable sharing you may need to specify @\{\-\# OPTIONS_GHC -fno-cse \#\-\}@ in the module you define the flags.++ /Pure annotations/: Alternatively, you may use pure annotations, which are+ referentially transparent, but less type safe and more verbose. The initial+ example may be written as:++ @sample = 'record' Sample{} [hello := 'def' '+=' 'help' \"World argument\" '+=' 'opt' \"world\"]@+ @ '+=' 'summary' \"Sample v1\"@++ @main = print =<< (cmdArgs_ sample :: IO Sample)@++ All the examples are written using impure annotations. To convert to pure+ annotations follow the rules:++ > Ctor {field1 = value1 &= ann1, field2 = value2} &= ann2 ==> record Ctor{} [field1 := value1 += ann1, field2 := value2] += ann2+ > Ctor (value1 &= ann1) value2 &= ann2 ==> record Ctor{} [atom value1 += ann1, atom value2] += ann2+ > modes [Ctor1{...}, Ctor2{...}] ==> modes_ [record Ctor1{} [...], record Ctor2{} [...]]+ > Ctor {field1 = enum [X &= ann, Y]} ==> record Ctor{} [enum_ field1 [atom X += ann, atom Y]]++ If you are willing to use TemplateHaskell, you can write in the impure syntax,+ but have your code automatically translated to the pure style. For more details see+ "System.Console.CmdArgs.Quote".+ -} module System.Console.CmdArgs.Implicit( -- * Running command lines- cmdArgs, cmdArgsMode, cmdArgsRun, cmdArgs_, cmdArgsMode_, cmdArgsApply, CmdArgs(..),+ cmdArgs, cmdArgsMode, cmdArgsRun, cmdArgs_, cmdArgsMode_, cmdArgsApply, CmdArgs(..), -- cmdArgsReform, -- * Constructing command lines -- | Attributes can work on a flag (inside a field), on a mode (outside the record), -- or on all modes (outside the 'modes' call).@@ -66,9 +89,10 @@ ) where import Data.Data+import Data.Maybe import Data.Generics.Any import System.Exit-import System.Console.CmdArgs.Explicit(Mode,processArgs,remap)+import System.Console.CmdArgs.Explicit(Mode,processArgs,remap,modeReform) import System.Console.CmdArgs.Implicit.Ann import System.Console.CmdArgs.Annotate hiding ((&=)) import qualified System.Console.CmdArgs.Annotate as A((&=))@@ -82,12 +106,18 @@ -- | Take impurely annotated records and run the corresponding command line. -- Shortcut for @'cmdArgsRun' . 'cmdArgsMode'@.+--+-- To use 'cmdArgs' with custom command line arguments see+-- 'System.Environment.withArgs'. cmdArgs :: Data a => a -> IO a cmdArgs = cmdArgsRun . cmdArgsMode -- | Take purely annotated records and run the corresponding command line. -- Shortcut for @'cmdArgsRun' . 'cmdArgsMode_'@.+--+-- To use 'cmdArgs_' with custom command line arguments see+-- 'System.Environment.withArgs'. cmdArgs_ :: Data a => Annotate Ann -> IO a cmdArgs_ = cmdArgsRun . cmdArgsMode_ @@ -143,13 +173,28 @@ -- it will set the verbosity (see 'setVerbosity'). cmdArgsApply :: CmdArgs a -> IO a cmdArgsApply CmdArgs{..}- | Just x <- cmdArgsHelp = do putStrLn x; exitSuccess- | Just x <- cmdArgsVersion = do putStrLn x; exitSuccess+ | Just x <- cmdArgsHelp = do putStr x; exitSuccess+ | Just x <- cmdArgsVersion = do putStr x; exitSuccess | otherwise = do maybe (return ()) setVerbosity cmdArgsVerbosity return cmdArgsValue +-- | Produce command line arguments that would generate the given value. This+-- function is useful for taking a value resulting from a command line,+-- modifying it (perhaps changing the value of a flag) and generating fresh+-- command line arguments.+--+-- > forall mode values constructed by cmdArgsMode/cmdArgsMode:+-- > forall args which successfully parse with mode+-- > let x = processValue mode args+-- > processValue mode (cmdArgsReform mode $ fromRight x) == x+_cmdArgsReform :: Mode (CmdArgs a) -> CmdArgs a -> [String]+_cmdArgsReform m x = fromMaybe (error err) $ modeReform m x+ where err = "System.Console.CmdArgs.Implicit.cmdArgsReform: cannot reform the arguments, perhaps the mode was not " +++ "generated by cmdArgsMode/cmdArgsMode_ ?"++ -- | Modes: \"I want a program with multiple modes, like darcs or cabal.\" -- -- Takes a list of modes, and creates a mode which includes them all.@@ -163,13 +208,21 @@ -- | Flag: \"I want several different flags to set this one field to different values.\" -- -- This annotation takes a type which is an enumeration, and provides multiple--- separate flags to set the field to each value.+-- separate flags to set the field to each value. The first element in the list+-- is used as the value of the field. -- -- > data State = On | Off deriving Data -- > data Mode = Mode {state :: State} -- > cmdArgs $ Mode {state = enum [On &= help "Turn on",Off &= help "Turn off"]} -- > --on Turn on -- > --off Turn off+--+-- This annotation can be used to allow multiple flags within a field:+--+-- > data Mode = Mode {state :: [State]}+-- > cmdArgs $ Mode {state = enum [[] &= ignore, [On] &= help "Turn on", [Off] &= help "Turn off"]}+--+-- Now @--on --off@ would produce @Mode [On,Off]@. enum :: Data val => [val] -> val enum = many @@ -181,10 +234,10 @@ (&=) = (A.&=) +-- | Like 'enum', but using the pure annotations. enum_ :: (Data c, Data f) => (c -> f) -> [Annotate Ann] -> Annotate Ann enum_ = (:=+) +-- | Like 'modes', but using the pure annotations. modes_ :: [Annotate Ann] -> Annotate Ann modes_ = many_--
System/Console/CmdArgs/Implicit/Ann.hs view
@@ -23,4 +23,8 @@ | ProgSummary String | ProgProgram String | ProgVerbosity+ | ProgHelpArg [Ann]+ | ProgVersionArg [Ann]+ | ProgVerbosityArgs [Ann] [Ann]+ | ProgNoAtExpand deriving (Eq,Ord,Show,Data,Typeable)
System/Console/CmdArgs/Implicit/Global.hs view
@@ -1,13 +1,15 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE PatternGuards, RecordWildCards #-} module System.Console.CmdArgs.Implicit.Global(global) where import System.Console.CmdArgs.Implicit.Local+import System.Console.CmdArgs.Implicit.Reform import System.Console.CmdArgs.Implicit.Type import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Text import System.Console.CmdArgs.Default +import Control.Arrow import Control.Monad import Data.Char import Data.Function@@ -17,44 +19,59 @@ global :: Prog_ -> Mode (CmdArgs Any)-global x = setHelp x $ collapse $ assignGroups $ assignNames $ extraFlags x+global x = setReform (reform y) $ setHelp y $ setProgOpts x $ collapse $ assignGroups y+ where y = assignNames $ extraFlags x +setProgOpts :: Prog_ -> Mode a -> Mode a+setProgOpts p m = m{modeExpandAt = not $ progNoAtExpand p+ ,modeGroupModes = fmap (setProgOpts p) $ modeGroupModes m}++ --------------------------------------------------------------------- -- COLLAPSE THE FLAGS/MODES UPWARDS collapse :: Prog_ -> Mode (CmdArgs Any)-collapse x | length ms == 1 = (head ms){modeNames=[progProgram x]}+collapse x | length ms == 1 = (snd $ head ms){modeNames=[progProgram x]} | length auto > 1 = err "prog" "Multiple automatic modes"- | otherwise = (head $ map zeroMode auto ++ map emptyMode ms)- {modeNames=[progProgram x], modeGroupModes = toGroup ms, modeHelp = progHelp x}+ | otherwise = (head $ map zeroMode auto ++ map (emptyMode . snd) ms)+ {modeNames=[progProgram x], modeGroupModes=grouped, modeHelp=progHelp x} where- ms = map collapseMode $ progModes x- auto = [m | (m,True) <- zip ms $ map modeDefault $ progModes x]+ grouped = Group (pick Nothing) [] [(g, pick $ Just g) | g <- nub $ mapMaybe (modeGroup . fst) ms]+ pick x = [m | (m_,m) <- ms, modeGroup m_ == x] + ms = map (id &&& collapseMode) $ progModes x+ auto = [m | (m_,m) <- ms, modeDefault m_] + -- | A mode devoid of all it's contents emptyMode :: Mode (CmdArgs Any) -> Mode (CmdArgs Any) emptyMode x = x {modeCheck = \x -> if cmdArgsHasValue x then Left "No mode given and no default mode" else Right x ,modeGroupFlags = groupUncommonDelete $ modeGroupFlags x- ,modeArgs=Nothing, modeHelpSuffix=[]}+ ,modeArgs=([],Nothing), modeHelpSuffix=[]} -- | A mode whose help hides all it's contents zeroMode :: Mode (CmdArgs Any) -> Mode (CmdArgs Any) zeroMode x = x {modeGroupFlags = groupUncommonHide $ modeGroupFlags x- ,modeArgs=fmap (\x -> x{argType=""}) $ modeArgs x+ ,modeArgs = let zeroArg x = x{argType=""} in map zeroArg *** fmap zeroArg $ modeArgs x ,modeHelpSuffix=[]} collapseMode :: Mode_ -> Mode (CmdArgs Any) collapseMode x =+ applyFixups (map flagFixup $ modeFlags_ x) $ collapseArgs [x | x@Arg_{} <- modeFlags_ x] $ collapseFlags [x | x@Flag_{} <- modeFlags_ x] $ modeMode x +applyFixups :: [Fixup] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)+applyFixups xs m = m{modeCheck = either Left (Right . fmap fix) . modeCheck m}+ where fix a = foldr ($) a [x | Fixup x <- xs]++ collapseFlags :: [Flag_] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any) collapseFlags xs x = x{modeGroupFlags = Group (pick Nothing) [] [(g, pick $ Just g) | g <- groups]} where@@ -64,7 +81,7 @@ collapseArgs :: [Flag_] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any) collapseArgs [] x = x-collapseArgs xs x = x{modeCheck=chk, modeArgs = Just $ flagArg upd hlp}+collapseArgs xs x = x{modeCheck=chk, modeArgs = ([], Just $ flagArg upd hlp)} where argUpd = argValue . flagArg_ @@ -105,10 +122,6 @@ GT -> take 1 rep ++ f (i+1) (x:xs) -incArgsSeen x = x{cmdArgsPrivate = CmdArgsPrivate $ getArgsSeen x + 1}-getArgsSeen CmdArgs{cmdArgsPrivate = CmdArgsPrivate i} = i-- --------------------------------------------------------------------- -- DEAL WITH GROUPS @@ -147,31 +160,54 @@ extraFlags :: Prog_ -> Prog_ extraFlags p = p{progModes = map f $ progModes p}- where f m = m{modeFlags_ = modeFlags_ m ++ map (\x -> def{flagFlag=x, flagExplicit=True, flagGroup=grp}) flags}+ where f m = m{modeFlags_ = modeFlags_ m ++ flags} grp = if length (progModes p) > 1 then Just commonGroup else Nothing- flags = flagHelpFormat undefined : flagVersion vers : if progVerbosity p then flagsVerbosity verb else []- vers x = x{cmdArgsVersion = Just $ progSumm p}+ wrap x = def{flagFlag=x, flagExplicit=True, flagGroup=grp}+ flags = changeBuiltin_ (progHelpArg p) (wrap $ flagHelpFormat $ error "flagHelpFormat undefined") +++ changeBuiltin_ (progVersionArg p) (wrap $ flagVersion vers) +++ [wrap $ flagNumericVersion $ \x -> x{cmdArgsVersion = Just $ unlines v}+ | Just v <- [progNumericVersionOutput p]] +++ changeBuiltin_ (fst $ progVerbosityArgs p) (wrap loud) +++ changeBuiltin_ (snd $ progVerbosityArgs p) (wrap quiet)+ [loud,quiet] = flagsVerbosity verb+ vers x = x{cmdArgsVersion = Just $ unlines $ progVersionOutput p} verb v x = x{cmdArgsVerbosity = Just v} +changeBuiltin :: Maybe Builtin_ -> Flag a -> [Flag a]+changeBuiltin Nothing _ = []+changeBuiltin (Just Builtin_{..}) x = [x+ {flagNames = builtinNames ++ if builtinExplicit then [] else flagNames x+ ,flagHelp = fromMaybe (flagHelp x) builtinHelp}]++changeBuiltin_ :: Maybe Builtin_ -> Flag_ -> [Flag_]+changeBuiltin_ Nothing _ = []+changeBuiltin_ (Just b) x = [x{flagFlag=y, flagGroup = builtinGroup b `mplus` flagGroup x}+ | y <- changeBuiltin (Just b) $ flagFlag x]++ setHelp :: Prog_ -> Mode (CmdArgs Any) -> Mode (CmdArgs Any) setHelp p = mapModes0 add "" where mapModes0 f pre m = f pre $ mapModes1 f pre m mapModes1 f pre m = m{modeGroupModes = fmap (mapModes0 f (pre ++ head (modeNames m) ++ " ")) $ modeGroupModes m} - add pre m = changeHelp m $ \hlp txt x -> x{cmdArgsHelp=Just $ showText txt $ msg hlp}- where msg hlp = Line (progSumm p) : Line "" : helpText hlp (prepare m{modeNames = map (pre++) $ modeNames m})+ add pre m = changeHelp p m $ \hlp txt x -> x{cmdArgsHelp=Just $ showText txt $ msg hlp}+ where msg hlp = helpText (progHelpOutput p) hlp (prepare m{modeNames = map (pre++) $ modeNames m}) prepare = mapModes1 (\_ m -> m{modeGroupFlags = groupCommonHide $ modeGroupFlags m}) "" -changeHelp :: Mode a -> (HelpFormat -> TextFormat -> a -> a) -> Mode a-changeHelp m upd = m{modeGroupFlags = fmap f $ modeGroupFlags m}- where hlp = flagHelpFormat upd- f flg = if flagNames hlp == flagNames flg then hlp else flg+changeHelp :: Prog_ -> Mode a -> (HelpFormat -> TextFormat -> a -> a) -> Mode a+changeHelp p m upd = m{modeGroupFlags = fmap f $ modeGroupFlags m}+ where hlp = changeBuiltin (progHelpArg p) $ flagHelpFormat upd+ f flg = if concatMap flagNames hlp == flagNames flg then head hlp else flg +setReform :: (a -> Maybe [String]) -> Mode a -> Mode a+setReform f m = m{modeReform = f, modeGroupModes = fmap (setReform f) $ modeGroupModes m}++ --------------------------------------------------------------------- -- ASSIGN NAMES @@ -193,7 +229,7 @@ isFlag_ _ = False -asName s = map (\x -> if x == '_' then '-' else toLower x) $ if last s == '_' then init s else s +asName s = map (\x -> if x == '_' then '-' else toLower x) $ if last s == '_' then init s else s -- have are already assigned, want are a list of ones I might want data Names = Names {have :: [String], want :: [String]}
System/Console/CmdArgs/Implicit/Local.hs view
@@ -5,32 +5,63 @@ -- constraints. module System.Console.CmdArgs.Implicit.Local( local, err,- Prog_(..), progSumm, Mode_(..), Flag_(..), isFlag_+ Prog_(..), Builtin_(..), Mode_(..), Flag_(..), Fixup(..), isFlag_,+ progHelpOutput, progVersionOutput, progNumericVersionOutput ) where import System.Console.CmdArgs.Implicit.Ann import System.Console.CmdArgs.Implicit.Type-import System.Console.CmdArgs.Implicit.Read+import System.Console.CmdArgs.Implicit.Reader import System.Console.CmdArgs.Explicit import System.Console.CmdArgs.Annotate import System.Console.CmdArgs.Default+import qualified Data.Generics.Any.Prelude as A +import Control.Monad import Data.Char import Data.Generics.Any import Data.Maybe+import Data.List data Prog_ = Prog_ {progModes :: [Mode_]- ,progSummary :: Maybe String+ ,progSummary :: Maybe [String] ,progProgram :: String ,progHelp :: String -- only for multiple mode programs- ,progVerbosity :: Bool+ ,progVerbosityArgs :: (Maybe Builtin_, Maybe Builtin_) -- (verbose, quiet)+ ,progHelpArg :: Maybe Builtin_+ ,progVersionArg :: Maybe Builtin_+ ,progNoAtExpand :: Bool } deriving Show instance Default Prog_ where- def = Prog_ def def def def def-progSumm x = fromMaybe ("The " ++ progProgram x ++ " program") $ progSummary x+ def = Prog_ def def def def def (Just def) (Just def) def +progOutput f x = fromMaybe ["The " ++ progProgram x ++ " program"] $+ (builtinSummary =<< f x) `mplus` progSummary x++progHelpOutput = progOutput progHelpArg+progVersionOutput = progOutput progVersionArg+progNumericVersionOutput x = fmap return $ parseVersion =<< listToMaybe (progVersionOutput x)++-- | Find numbers starting after space/comma, v+parseVersion :: String -> Maybe String+parseVersion xs = listToMaybe+ [y | x <- words $ map (\x -> if x `elem` ",;" then ' ' else x) xs+ , let y = fromMaybe x $ stripPrefix "v" x+ , length (takeWhile isDigit y) >= 1]+++data Builtin_ = Builtin_+ {builtinNames :: [String]+ ,builtinExplicit :: Bool+ ,builtinHelp :: Maybe String+ ,builtinGroup :: Maybe String+ ,builtinSummary :: Maybe [String]+ } deriving Show+instance Default Builtin_ where+ def = Builtin_ def def def def def+ data Mode_ = Mode_ {modeFlags_ :: [Flag_] ,modeMode :: Mode (CmdArgs Any)@@ -39,8 +70,7 @@ ,modeExplicit :: Bool } deriving Show instance Default Mode_ where- def = Mode_ [] m def def def- where m = Mode (toGroup []) [] undefined Right "" [] Nothing (toGroup [])+ def = Mode_ [] (modeEmpty $ error "Mode_ undefined") def def def data Flag_ = Flag_@@ -49,16 +79,23 @@ ,flagExplicit :: Bool ,flagGroup :: Maybe String ,flagEnum :: Maybe String -- if you are an enum, what is your string value+ ,flagFixup :: Fixup } | Arg_ {flagArg_ :: Arg (CmdArgs Any) ,flagArgPos :: Maybe Int ,flagArgOpt :: Maybe String+ ,flagFixup :: Fixup } deriving Show instance Default Flag_ where- def = Flag_ "" undefined def def def+ def = Flag_ "" (error "Flag_ undefined") def def def def +newtype Fixup = Fixup (Any -> Any)++instance Default Fixup where def = Fixup id+instance Show Fixup where show _ = "Fixup"+ isFlag_ Flag_{} = True isFlag_ _ = False @@ -88,52 +125,77 @@ mode_ :: Capture Ann -> [Mode_] mode_ (Ann Ignore _) = [] mode_ (Ann a b) = map (modeAnn a) $ mode_ b-mode_ o@(Ctor x ys) = [withMode def{modeFlags_=concat $ zipWith flag_ (fields x) ys} $ \x -> x{modeValue=embed $ fromCapture o}]+mode_ o@(Ctor x ys) = [withMode def{modeFlags_=flgs} $ \x -> x{modeValue=embed $ fixup $ fromCapture o}]+ where flgs = concat $ zipWith flag_ (fields x) ys+ fixup x = foldl (\x (Fixup f) -> f x) x $ map flagFixup flgs mode_ x = err "mode" $ show x flag_ :: String -> Capture Ann -> [Flag_] flag_ name (Ann Ignore _) = [] flag_ name (Ann a b) = map (flagAnn a) $ flag_ name b-flag_ name (Value x) = [def{flagField=name, flagFlag = remap embed reembed $ value_ name x}]+flag_ name (Value x) = let (fix,flg) = value_ name x in [def{flagField=name, flagFlag=remap embed reembed flg, flagFixup=fix}] flag_ name x@Ctor{} = flag_ name $ Value $ fromCapture x-flag_ name (Many xs) = map (enum_ name) xs+flag_ name (Many xs) = concatMap (enum_ name) xs flag_ name x = errFlag name $ show x -enum_ :: String -> Capture Ann -> Flag_-enum_ name (Ann a b) = flagAnn a $ enum_ name b-enum_ name (Value x) = def{flagField=name, flagFlag = flagNone [] (fmap $ setField (name,x)) "", flagEnum=Just $ ctor x}+enum_ :: String -> Capture Ann -> [Flag_]+enum_ name (Ann Ignore _) = []+enum_ name (Ann a b) = map (flagAnn a) $ enum_ name b+enum_ name (Value x) = [def{flagField=name, flagFlag = flagNone [] (fmap upd) "", flagEnum=Just $ ctor x}]+ where upd v | not (A.isString x) && A.isList x = setField (name, getField name v `A.append` x) v+ | otherwise = setField (name,x) v enum_ name x@Ctor{} = enum_ name $ Value $ fromCapture x enum_ name x = errFlag name $ show x -value_ :: String -> Any -> Flag Any+-- Fixup (ends up in modeCheck) and the flag itself+value_ :: String -> Any -> (Fixup, Flag Any) value_ name x | isNothing mty = errFlag name $ show x- | isReadBool ty =- let upd b x = setField (name,addContainer ty (getField name x) (Any b)) x- in flagBool [] upd ""+ | readerBool ty =+ let f (Right x) = x+ upd b x = setField (name, f $ readerRead ty (getField name x) $ show b) x+ in (fixup, flagBool [] upd "") | otherwise =- let upd s x = fmap (\c -> setField (name,c) x) $ reader ty s $ getField name x- in flagReq [] upd (readHelp ty) ""+ let upd s x = fmap (\c -> setField (name,c) x) $ readerRead ty (getField name x) s+ in (fixup, flagReq [] upd (readerHelp ty) "") where- mty = toReadContainer x+ mty = reader x ty = fromJust mty+ fixup = Fixup $ \x -> setField (name,readerFixup ty $ getField name x) x --------------------------------------------------------------------- -- CAPTURE THE ANNOTATIONS progAnn :: Ann -> Prog_ -> Prog_-progAnn (ProgSummary a) x = x{progSummary=Just a}+progAnn (ProgSummary a) x = x{progSummary=Just $ lines a} progAnn (ProgProgram a) x = x{progProgram=a}-progAnn ProgVerbosity x = x{progVerbosity=True}+progAnn ProgVerbosity x = x{progVerbosityArgs=let f sel = Just $ fromMaybe def $ sel $ progVerbosityArgs x in (f fst, f snd)} progAnn (Help a) x | length (progModes x) > 1 = x{progHelp=a}+progAnn (ProgHelpArg a) x = x{progHelpArg = builtinAnns (progHelpArg x) a}+progAnn (ProgVersionArg a) x = x{progVersionArg = builtinAnns (progVersionArg x) a}+progAnn (ProgVerbosityArgs a b) x = x{progVerbosityArgs=(builtinAnns (Just $ fromMaybe def $ fst $ progVerbosityArgs x) a, builtinAnns (Just $ fromMaybe def $ snd $ progVerbosityArgs x) b)}+progAnn ProgNoAtExpand x = x{progNoAtExpand=True} progAnn a x | length (progModes x) == 1 = x{progModes = map (modeAnn a) $ progModes x} progAnn a x = err "program" $ show a +builtinAnns = foldl (flip builtinAnn)++builtinAnn :: Ann -> Maybe Builtin_ -> Maybe Builtin_+builtinAnn _ Nothing = Nothing+builtinAnn Ignore _ = Nothing+builtinAnn Explicit (Just x) = Just x{builtinExplicit=True}+builtinAnn (Name a) (Just x) = Just x{builtinNames=a : builtinNames x}+builtinAnn (Help a) (Just x) = Just x{builtinHelp=Just a}+builtinAnn (GroupName a) (Just x) = Just x{builtinGroup=Just a}+builtinAnn (ProgSummary a) (Just x) = Just x{builtinSummary=Just $ lines a}+builtinAnn a x = err "builtin" $ show a++ modeAnn :: Ann -> Mode_ -> Mode_ modeAnn (Help a) x = withMode x $ \x -> x{modeHelp=a} modeAnn (ModeHelpSuffix a) x = withMode x $ \x -> x{modeHelpSuffix=a}@@ -158,9 +220,9 @@ flagAnn a x = errFlag (head $ words $ show x) $ show a toArg :: Flag_ -> Maybe Int -> Flag_-toArg (Flag_ fld x False Nothing Nothing) pos+toArg (Flag_ fld x False Nothing Nothing fix) pos | null (flagNames x), null (flagHelp x), Just y <- opt $ flagInfo x- = Arg_ (Arg (flagValue x) (flagType x)) pos y+ = Arg_ (Arg (flagValue x) (flagType x) (isNothing y)) pos y fix where opt FlagReq = Just Nothing opt (FlagOpt x) = Just (Just x)
− System/Console/CmdArgs/Implicit/Read.hs
@@ -1,137 +0,0 @@--module System.Console.CmdArgs.Implicit.Read(isReadBool, toReadContainer, reader, addContainer, readHelp) where--import Data.Generics.Any-import qualified Data.Generics.Any.Prelude as A-import System.Console.CmdArgs.Explicit-import Data.Char-import Data.Either-import Data.List---data ReadContainer- = ReadList ReadAtom- | ReadMaybe ReadAtom- | ReadAtom ReadAtom--data ReadAtom- = ReadBool- | ReadInt- | ReadInteger- | ReadFloat- | ReadDouble- | ReadString- | ReadEnum [(String,Any)]- | ReadTuple [ReadAtom]--isReadBool x = case fromReadContainer x of- ReadBool{} -> True- _ -> False--fromReadContainer :: ReadContainer -> ReadAtom-fromReadContainer (ReadList x) = x-fromReadContainer (ReadMaybe x) = x-fromReadContainer (ReadAtom x) = x---toReadContainer :: Any -> Maybe ReadContainer-toReadContainer x = case typeShell x of- "[]" | typeName x /= "[Char]" -> fmap ReadList $ toReadAtom $ A.fromList x- "Maybe" -> fmap ReadMaybe $ toReadAtom $ A.fromMaybe x- _ -> fmap ReadAtom $ toReadAtom x---toReadAtom :: Any -> Maybe ReadAtom-toReadAtom x = case typeName x of- "Bool" -> Just ReadBool- "Int" -> Just ReadInt- "Integer" -> Just ReadInteger- "Float" -> Just ReadFloat- "Double" -> Just ReadDouble- "[Char]" -> Just ReadString- _ | A.isTuple x -> fmap ReadTuple $ mapM toReadAtom $ children $ compose0 x $ typeShell x- _ -> toReadEnum x---toReadEnum :: Any -> Maybe ReadAtom-toReadEnum x- | isAlgType x && all ((==) 0 . arity . compose0 x) cs- = Just $ ReadEnum [(map toLower c, compose0 x c) | c <- cs]- | otherwise = Nothing- where cs = ctors x----- | Both Any will be the same type as ReadContainer-reader :: ReadContainer -> String -> Any -> Either String Any-reader t s x = fmap (addContainer t x) $ readAtom (fromReadContainer t) s----- | If c is the container type, and a is the atom type:--- Type (c a) -> c a -> a -> c a-addContainer :: ReadContainer -> Any -> Any -> Any-addContainer (ReadAtom _) _ x = x-addContainer (ReadMaybe _) o x = A.just_ o x-addContainer (ReadList _) o x = A.append o $ A.cons x $ A.nil_ o----- | The Any will be the type as ReadAtom-readAtom :: ReadAtom -> String -> Either String Any-readAtom ty s = case ty of- ReadBool -> maybe (Left $ "Could not read as boolean, " ++ show s) (Right . Any) $ parseBool s- ReadInt -> f (0::Int)- ReadInteger -> f (0::Integer)- ReadFloat -> f (0::Float)- ReadDouble -> f (0::Double)- ReadString -> Right $ Any s- ReadEnum xs -> readEnum (map toLower s) xs- ReadTuple _ -> readTuple ty s- where- f t = case reads s of- [(x,"")] -> Right $ Any $ x `asTypeOf` t- _ -> Left $ "Could not read as type " ++ show (typeOf $ Any t) ++ ", " ++ show s---readEnum:: String -> [(String,a)] -> Either String a-readEnum a xs | null ys = Left $ "Could not read, expected one of: " ++ unwords (map fst xs)- | length ys > 1 = Left $ "Ambiguous read, could be any of: " ++ unwords (map fst ys)- | otherwise = Right $ snd $ head ys- where ys = filter (\x -> a `isPrefixOf` fst x) xs---readTuple :: ReadAtom -> String -> Either String Any-readTuple ty s- | length ss /= length ts = Left "Incorrect number of comma separated fields for tuple"- | not $ null left = Left $ head left- | otherwise = Right $ gen right- where- (left,right) = partitionEithers $ zipWith readAtom ts ss- (ts,gen) = flatten ty- ss = split s---split :: String -> [String]-split = lines . map (\x -> if x == ',' then '\n' else x)--flatten :: ReadAtom -> ([ReadAtom], [Any] -> Any)-flatten (ReadTuple xs) = (concat ns, A.tuple . zipWith ($) fs . unconcat ns)- where (ns,fs) = unzip $ map flatten xs-flatten x = ([x], \[a] -> a)---unconcat :: [[w]] -> [a] -> [[a]]-unconcat [] [] = []-unconcat (w:ws) xs = x1 : unconcat ws x2- where (x1,x2) = splitAt (length w) xs---readHelp :: ReadContainer -> String-readHelp = f . fromReadContainer- where- f ReadBool = "BOOL"- f ReadInt = "INT"- f ReadInteger = "INT"- f ReadFloat = "NUM"- f ReadDouble = "NUM"- f ReadString = "ITEM"- f (ReadEnum xs) = map toUpper $ typeShell $ snd $ head xs- f (ReadTuple xs) = intercalate "," $ map f xs
+ System/Console/CmdArgs/Implicit/Reader.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE PatternGuards #-}++module System.Console.CmdArgs.Implicit.Reader(Reader(..), reader) where++import Data.Generics.Any+import qualified Data.Generics.Any.Prelude as A+import System.Console.CmdArgs.Explicit+import Data.Char+import Data.Int+import Data.Word+import Data.List+import Data.Maybe+++data Reader = Reader+ {readerHelp :: String+ ,readerBool :: Bool+ ,readerParts :: Int+ ,readerFixup :: Any -> Any -- If a list, then 'reverse', otherwise nothing, so we can build up using cons in O(n)+ ,readerRead :: Any -> String -> Either String Any+ }++-- reader has an actual value of type Any that can be inspected+-- reader_ has a value of type _|_ instead+readerRead_ r = readerRead r $ error "Invariant broken: reader/reader_"+++reader :: Any -> Maybe Reader+reader x | A.isList x && not (A.isString x) = do+ r <- reader_ $ A.fromList x+ return r{readerRead = \o s -> fmap (`A.cons` o) $ readerRead_ r s, readerFixup = A.reverse}+reader x | isAlgType x, [ctor] <- ctors x, [child] <- children x = do+ -- newtype wrapper, just forward it+ r <- reader child+ let down = head . children+ let up o c = recompose o [c]+ return r{readerFixup = \x -> up x $ readerFixup r $ down x+ ,readerRead = \x -> either Left (Right . up x) . readerRead r (down x)+ }+reader x = reader_ x+++reader_ :: Any -> Maybe Reader+reader_ x | A.isString x = Just $ Reader "ITEM" False 1 id $ const $ Right . Any+++reader_ x | typeName x == "Bool" = Just $ Reader "BOOL" True 1 id $ const $ \s ->+ maybe (Left $ "Could not read as boolean, " ++ show s) (Right . Any) $ parseBool s+++reader_ x | res:_ <- catMaybes+ [f "INT" (0::Integer), f "NUM" (0::Float), f "NUM" (0::Double)+ ,f "INT" (0::Int), f "INT" (0::Int8), f "INT" (0::Int16), f "INT" (0::Int32), f "INT" (0::Int64)+ ,f "NAT" (0::Word), f "NAT" (0::Word8), f "NAT" (0::Word16), f "NAT" (0::Word32), f "NAT" (0::Word64)+ ] = Just res+ where+ ty = typeOf x+ f hlp t | typeOf (Any t) /= ty = Nothing+ | otherwise = Just $ Reader hlp False 1 id $ const $ \s -> case reads s of+ [(x,"")] -> Right $ Any $ x `asTypeOf` t+ _ -> Left $ "Could not read as type " ++ show (typeOf $ Any t) ++ ", " ++ show s+++reader_ x | A.isList x = do+ r <- reader_ $ A.fromList x+ return $ r{readerRead = const $ fmap (A.list_ x) . readerRead_ r}+++reader_ x | A.isMaybe x = do+ r <- reader_ $ A.fromMaybe x+ return $ r{readerRead = const $ fmap (A.just_ x) . readerRead_ r}+++reader_ x | isAlgType x && length xs > 1 && all ((==) 0 . arity . snd) xs+ = Just $ Reader (map toUpper $ typeShell x) (typeName x == "Bool") 1 id $ const $ rd . map toLower+ where+ xs = [(map toLower c, compose0 x c) | c <- ctors x]++ rd s | null ys = Left $ "Could not read " ++ show s ++ ", expected one of: " ++ unwords (map fst xs)+ | Just (_,x) <- find ((==) s . fst) ys = Right x+ | length ys > 1 = Left $ "Ambiguous read for " ++ show s ++ ", could be any of: " ++ unwords (map fst ys)+ | otherwise = Right $ snd $ head ys+ where ys = filter (isPrefixOf s . fst) xs+++reader_ x | isAlgType x, [c] <- ctors x, x <- compose0 x c = do+ let cs = children x+ rs <- mapM reader_ cs+ let n = sum $ map readerParts rs+ return $ Reader (uncommas $ map readerHelp rs) (map readerBool rs == [True]) n id $ const $ \s ->+ let ss = commas s in+ if n == 1 then fmap (recompose x . return) $ readerRead_ (head $ filter ((==) 1 . readerParts) rs) s+ else if length ss /= n then Left "Incorrect number of commas for fields"+ else fmap (recompose x) $ sequenceEither $ zipWith readerRead_ rs $ map uncommas $ takes (map readerParts rs) ss+++reader_ _ = Nothing+++uncommas = intercalate ","+commas = lines . map (\x -> if x == ',' then '\n' else x)+++takes [] _ = []+takes (i:is) xs = a : takes is b+ where (a,b) = splitAt i xs++sequenceEither = foldr f (Right [])+ where f (Left x) _ = Left x+ f _ (Left x) = Left x+ f (Right x) (Right xs) = Right (x:xs)
+ System/Console/CmdArgs/Implicit/Reform.hs view
@@ -0,0 +1,42 @@+{-# LANGUAGE RecordWildCards #-}++module System.Console.CmdArgs.Implicit.Reform(reform) where++import System.Console.CmdArgs.Implicit.Local+import System.Console.CmdArgs.Implicit.Type+import System.Console.CmdArgs.Verbosity++import Data.Generics.Any+import Data.List+import Data.Maybe+++reform :: Prog_ -> CmdArgs Any -> Maybe [String]+reform Prog_{..} CmdArgs{..} = Just $+ f "help" progHelpArg (isJust cmdArgsHelp) +++ f "version" progVersionArg (isJust cmdArgsVersion) +++ f "verbose" (fst progVerbosityArgs) (cmdArgsVerbosity == Just Loud) +++ f "quiet" (snd progVerbosityArgs) (cmdArgsVerbosity == Just Quiet)+ where+ f ex (Just x) True = pickArg $ builtinNames x ++ [ex]+ f _ _ _ = []+++pickArg :: [String] -> [String]+pickArg xs = case partition ((==) 1 . length) xs of+ (_, x:_) -> ["--" ++ x]+ (x:_, _) -> ["-" ++ x]+ _ -> []++{-++data Prog_ = Prog_+ {progModes :: [Mode_]+ ,progSummary :: Maybe [String]+ ,progProgram :: String+ ,progHelp :: String -- only for multiple mode programs+ ,progVerbosityArgs :: (Maybe Builtin_, Maybe Builtin_)+ ,progHelpArg :: Maybe Builtin_+ ,progVersionArg :: Maybe Builtin_+ } deriving Show+-}
System/Console/CmdArgs/Implicit/Type.hs view
@@ -4,7 +4,8 @@ module System.Console.CmdArgs.Implicit.Type( -- cmdArgs_privateArgsSeen is exported, otherwise Haddock -- gets confused when using RecordWildCards- CmdArgs(..), CmdArgsPrivate(..), cmdArgsHasValue, embed, reembed+ CmdArgs(..), cmdArgsHasValue, embed, reembed,+ CmdArgsPrivate, incArgsSeen, getArgsSeen ) where import System.Console.CmdArgs.Verbosity@@ -17,22 +18,16 @@ -- @--version@, @--quiet@ and @--verbose@. data CmdArgs a = CmdArgs {cmdArgsValue :: a -- ^ The underlying value being wrapped.- ,cmdArgsHelp :: Maybe String -- ^ @Just@ if @--help@ is given, then gives the help message for display.- ,cmdArgsVersion :: Maybe String -- ^ @Just@ if @--verion@ is given, then gives the version message for display.+ ,cmdArgsHelp :: Maybe String -- ^ @Just@ if @--help@ is given, then gives the help message for display, including a trailing newline.+ ,cmdArgsVersion :: Maybe String -- ^ @Just@ if @--version@ is given, then gives the version message for display, including a trailing newline. ,cmdArgsVerbosity :: Maybe Verbosity -- ^ @Just@ if @--quiet@ or @--verbose@ is given, then gives the verbosity to use. ,cmdArgsPrivate :: CmdArgsPrivate -- ^ Private: Only exported due to Haddock limitations. }- deriving (Show,Data,Typeable)+ deriving (Show,Eq,Ord,Data,Typeable) cmdArgsHasValue :: CmdArgs a -> Bool cmdArgsHasValue x = isNothing (cmdArgsHelp x) && isNothing (cmdArgsVersion x) -data CmdArgsPrivate = CmdArgsPrivate- Int -- ^ The number of arguments that have been seen- deriving (Data,Typeable)--instance Show CmdArgsPrivate where show _ = "CmdArgsPrivate"- instance Functor CmdArgs where fmap f x = x{cmdArgsValue = f $ cmdArgsValue x} @@ -43,3 +38,12 @@ reembed :: CmdArgs a -> (a, a -> CmdArgs a) reembed x = (cmdArgsValue x, \y -> x{cmdArgsValue=y}) ++data CmdArgsPrivate = CmdArgsPrivate+ Int -- ^ The number of arguments that have been seen+ deriving (Eq,Ord,Data,Typeable)++incArgsSeen x@CmdArgs{cmdArgsPrivate = CmdArgsPrivate i} = x{cmdArgsPrivate = CmdArgsPrivate (i+1)}+getArgsSeen CmdArgs{cmdArgsPrivate = CmdArgsPrivate i} = i++instance Show CmdArgsPrivate where show _ = "CmdArgsPrivate"
System/Console/CmdArgs/Implicit/UI.hs view
@@ -11,13 +11,26 @@ import Data.Typeable --- | Flag: \"I want users to be able to omit the value for this flag.\"+-- | Flag: \"I want users to be able to omit the value associated with this flag.\" -- -- Make the value of a flag optional. If @--flag@ is given, it will -- be treated as @--flag=/this_argument/@. -- -- > {hello = def &= opt "foo"} -- > -h --hello[=VALUE] (default=foo)+--+-- Note that all flags in CmdArgs are optional, and if omitted will use their default value.+-- Those annotated with @opt@ also allow the flag to be present without an associated value.+-- As an example:+--+-- > {hello = "DEFAULT" &= opt "OPTIONAL"}+--+-- > $ main+-- > {hello = "DEFAULT"}+-- > $ main --hello+-- > {hello = "OPTIONAL"}+-- > $ main --hello=VALUE+-- > {hello = "VALUE"} opt :: (Show a, Typeable a) => a -> Ann opt x = FlagOptional $ case cast x of Just y -> y@@ -77,6 +90,8 @@ -- | Flag: \"Put non-flag arguments here.\" --+-- All argument flags not captured by 'argPos' are returned by 'args'.+-- -- > {hello = def &= args} args :: Ann args = FlagArgs@@ -114,7 +129,8 @@ -- | Modes: \"My program name\/version\/copyright is ...\" -- -- One line summary of the entire program, the first line of--- @--help@ and the only line of @--version@.+-- @--help@ and the only line of @--version@. If the string contains a+-- version number component will also provide @--numeric-version@. -- -- > Sample{..} &= summary "CmdArgs v0.0, (C) Neil Mitchell 1981" summary :: String -> Ann@@ -167,3 +183,41 @@ -- Add @--verbose@ and @--quiet@ flags. verbosity :: Ann verbosity = ProgVerbosity+++-- | Modes: \"Customise the help argument.\"+--+-- Add extra options to a help argument, such as 'help', 'name', 'ignore' or 'explicit'.+--+-- > Sample{..} &= helpArg [explicit, name "h"]+helpArg :: [Ann] -> Ann+helpArg = ProgHelpArg+++-- | Modes: \"Customise the version argument.\"+--+-- Add extra options to a version argument, such as 'help', 'name', 'ignore', 'summary' or 'explicit'.+--+-- > Sample{..} &= versionArg [ignore]+versionArg :: [Ann] -> Ann+versionArg = ProgVersionArg++-- | Modes: \"Customise the verbosity arguments.\"+--+-- Add extra options to a verbosity arguments (@--verbose@ and @--quiet@),+-- such as 'help', 'name', 'ignore' or 'explicit'. The verbose options come+-- first, followed by the quiet options.+--+-- > Sample{..} &= verbosityArgs [ignore] [name "silent", explicit]+verbosityArgs :: [Ann] -> [Ann] -> Ann+verbosityArgs = ProgVerbosityArgs+++-- | Program: \"Turn off \@ expansion.\"+--+-- Usually arguments starting with \@ are treated as a file containing+-- a set of arguments. This annotation turns off that behaviour.+--+-- > Sample{..} &= noAtExpand+noAtExpand :: Ann+noAtExpand = ProgNoAtExpand
+ System/Console/CmdArgs/Quote.hs view
@@ -0,0 +1,213 @@+{-# LANGUAGE TemplateHaskell, PatternGuards, MagicHash #-}++-- | This module provides a quotation feature to let you write command line+-- arguments in the impure style, but have them translated into the pure style,+-- as per "System.Console.CmdArgs.Implicit". An example:+--+-- > {-# LANGUAGE TemplateHaskell, DeriveDataTypeable, MagicHash #-}+-- > import System.Console.CmdArgs.Implicit+-- > import System.Console.CmdArgs.Quote+-- >+-- > data Sample = Sample {hello :: String} deriving (Show, Data, Typeable)+-- >+-- > $(cmdArgsQuote [d|+-- > sample = Sample{hello = def &=# help "World argument" &=# opt "world"}+-- > &=# summary "Sample v1"+-- >+-- > run = cmdArgs# sample :: IO Sample+-- > |])+-- >+-- > main = print =<< run+--+-- Inside 'cmdArgsQuote' you supply the command line parser using attributes in the+-- impure style. If you run with @-ddump-splices@ (to see the Template Haskell output),+-- you would see:+--+-- > run = cmdArgs_+-- > (record Sample{} [hello := def += help "World argument" += opt "world"]+-- > += summary "Sample v1")+-- > :: IO Sample+--+-- /Stubs/+--+-- To define the original parser you may use either the standard impure annotations ('(&=)', 'modes'), or+-- the stub annotations versions defined in this module ('(&=#)', 'modes'). The stub versions do not include+-- a "Data" constraint, so can be used in situations where the Data instance is not yet available - typically+-- when defining the parser in the same module as the data type on GHC 7.2 and above. The stub versions should+-- never be used outside 'cmdArgsQuote' and will always raise an error.+--+-- /Explicit types/+--+-- There will be a limited number of situations where an impure parser will require additional types, typically+-- on the result of 'cmdArgs' if the result is used without a fixed type - for example if you 'show' it. Most users+-- will not need to add any types. In some cases you may need to remove some explicit types, where the intermediate+-- type of the annotations has changed - but again, this change should be rare.+--+-- /Completeness/+--+-- The translation is not complete, although works for all practical instances I've tried. The translation works+-- by first expanding out the expression (inlining every function defined within the quote, inlining let bindings),+-- then performs the translation. This scheme leads to two consequences: 1) Any expensive computation executed inside+-- the quotation to produce the command line flags may be duplicated (a very unlikely scenario). 2) As I do not yet+-- have expansion rules for all possible expressions, the expansion (and subsequently the translation) may fail.+-- I am interested in any bug reports where the feature does not work as intended.+module System.Console.CmdArgs.Quote(+ -- * Template Haskell quotation function+ cmdArgsQuote,+ -- * Stub versions of the impure annotations+ (&=#), modes#, cmdArgsMode#, cmdArgs#, enum#+ ) where++import Language.Haskell.TH+import Control.Arrow+import Control.Monad+import Data.Data+import Data.Maybe+import System.Console.CmdArgs.Implicit++stub name = error $+ "System.Console.CmdArgs.Quote." ++ name +++ ": this function is provided only for use inside cmdArgsQuote, and should never be called"++-- | Version of '&=' without a 'Data' context, only to be used within 'cmdArgsQuote'.+(&=#) :: a -> Ann -> a+(&=#) = stub "(&=#)"++-- | Version of 'modes' without a 'Data' context, only to be used within 'cmdArgsQuote'.+modes# :: [a] -> a+modes# = stub "modes#"++-- | Version of 'cmdArgsMode' without a 'Data' context, only to be used within 'cmdArgsQuote'.+cmdArgsMode# :: a -> Mode (CmdArgs a)+cmdArgsMode# = stub "cmdArgsMode#"++-- | Version of 'cmdArgs' without a 'Data' context, only to be used within 'cmdArgsQuote'.+cmdArgs# :: a -> IO a+cmdArgs# = stub "cmdArgs#"++-- | Version of 'enum' without a 'Data' context, only to be used within 'cmdArgsQuote'.+enum# :: [a] -> a+enum# = stub "enum#"+++-- | Quotation function to turn an impure version of "System.Console.CmdArgs.Implicit" into a pure one.+-- For details see "System.Console.CmdArgs.Quote".+cmdArgsQuote :: Q [Dec] -> Q [Dec]+cmdArgsQuote x = do+ x <- x+ translate $ rename $ simplify $ inline x+++-- | Apply the rewrite rules+translate :: [Dec] -> Q [Dec]+translate = descendBiM f+ where+ dull = ['Just, 'Left, 'Right, '(:)] -- Prelude constructors of non-zero arity++ f (RecConE x xs) = return $+ let args = [anns (InfixE (Just $ VarE lbl) (ConE '(:=)) (Just val)) as | (lbl,x) <- xs, let (val, as) = asAnns x]+ in VarE 'record `AppE` RecConE x [] `AppE` ListE args++ f x | (ConE x, xs@(_:_)) <- asApps x, x `notElem` dull = do+ names <- forM [1..length xs] $ \i -> newName $ "_" ++ nameBase x ++ show i+ let (vals, ass) = unzip $ map asAnns xs+ bind = [ValD (VarP name) (NormalB val) [] | (name,val) <- zip names vals]+ args = [anns (VarE 'atom `AppE` VarE name) as | (name,as) <- zip names ass]+ return $ LetE bind $ VarE 'record `AppE` (ConE x `apps` map VarE names) `AppE` ListE args++ f x = descendM f x++ apps x [] = x+ apps x (y:ys) = apps (x `AppE` y) ys++ asApps (AppE x y) = let (a,b) = asApps x in (a,b++[y])+ asApps x = (x,[])++ anns x [] = x+ anns x (a:as) = anns (InfixE (Just x) (VarE '(+=)) (Just a)) as++ asAnns (InfixE (Just x) (VarE op) (Just y)) | op == '(+=) = let (a,b) = asAnns x in (a,b++[y])+ asAnns (AppE (AppE (VarE op) x) y) | op == '(+=) = let (a,b) = asAnns x in (a,b++[y])+ asAnns x = (x, [])+++-- | Move from the old names to the new names, sufficient for where that is the full translation+rename :: [Dec] -> [Dec]+rename = transformBi f+ where+ rep = let f a b c = [(a,c),(b,c)] in concat+ [f '(&=) '(&=#) '(+=)+ ,f 'modes 'modes# 'modes_+ ,f 'enum 'enum# 'enum_+ ,f 'cmdArgsMode 'cmdArgsMode# 'cmdArgsMode_+ ,f 'cmdArgs 'cmdArgs# 'cmdArgs_]++ f (VarE x) | Just x <- lookup x rep = VarE x+ f x = x+++-- | Simplify the syntax tree - things like application of a lambda+simplify :: [Dec] -> [Dec]+simplify = transformBi f+ where+ f (AppE (LamE [VarP v] bod) x) = f $ subst v x bod+ f x = x++ subst v x bod = transform f bod+ where f (VarE v2) | v == v2 = x+ f x = x+++-- | Evaluate through all locally defined functions and let expressions, at most once per defn+inline :: [Dec] -> [Dec]+inline xs = map (dec $ addEnv xs []) xs+ where+ newEnv = concatMap $ \x -> case x of+ FunD x [Clause ps (NormalB e) ds] -> [(x, LamE ps $ let_ ds e)]+ ValD (VarP x) (NormalB e) ds -> [(x, let_ ds e)]+ _ -> []++ addEnv xs env = without [] (newEnv xs) ++ env+ where+ -- create an environment where everything in ns is missing, recursively drop one thing each time+ without ns new = [(n, exp (new2 ++ env) e) | (n,e) <- new, n `notElem` ns, let new2 = without (n:ns) new]+++ dec env (FunD n cs) = FunD n $ map (clause env) cs+ dec env (ValD p x ds) = ValD p (body (addEnv ds env) x) ds++ clause env (Clause ps x ds) = Clause ps (body (addEnv ds env) x) ds++ body env (GuardedB xs) = GuardedB $ map (second $ exp env) xs+ body env (NormalB x) = NormalB $ exp env x++ -- FIXME: propagating the env ignores variables shadowed by LamE/CaseE+ exp env (LetE ds x) = LetE ds $ exp (addEnv ds env) x+ exp env (VarE x) | Just x <- lookup x env = x+ exp env x = descend (exp env) x++ let_ ds e = if null ds then e else LetE ds e+++---------------------------------------------------------------------+-- MINI UNIPLATE - Avoid the dependency just for one small module++descendBi :: (Data a, Data b) => (b -> b) -> a -> a+descendBi f x | Just f <- cast f = f x+ | otherwise = gmapT (descendBi f) x++descend :: Data a => (a -> a) -> a -> a+descend f = gmapT (descendBi f)++transform :: Data a => (a -> a) -> a -> a+transform f = f . descend (transform f)++transformBi :: (Data a, Data b) => (b -> b) -> a -> a+transformBi f = descendBi (transform f)++descendBiM :: (Data a, Data b, Monad m) => (b -> m b) -> a -> m a+descendBiM f x | Just x <- cast x = liftM (fromJust . cast) $ f x -- guaranteed safe+ | otherwise = gmapM (descendBiM f) x++descendM :: (Data a, Monad m) => (a -> m a) -> a -> m a+descendM f = gmapM (descendBiM f)
System/Console/CmdArgs/Test/All.hs view
@@ -6,12 +6,14 @@ import qualified System.Console.CmdArgs.Test.Explicit as Explicit import qualified System.Console.CmdArgs.Test.Implicit as Implicit import qualified System.Console.CmdArgs.Test.GetOpt as GetOpt+import qualified System.Console.CmdArgs.Test.SplitJoin as SplitJoin test :: IO () test = do Explicit.test GetOpt.test Implicit.test+ SplitJoin.test putStrLn "\nTest completed" demo :: [Mode Demo]
System/Console/CmdArgs/Test/Explicit.hs view
@@ -8,7 +8,7 @@ demo = [newDemo act dem] -act xs | ("help","") `elem` xs = print $ helpText def dem+act xs | ("help","") `elem` xs = print $ helpText [] def dem | otherwise = print xs dem :: Mode [(String,String)]@@ -33,6 +33,10 @@ checkGood m ["fred","bob"] ["fred","bob"] checkGood m ["--","--test"] ["--test"] checkGood m [] []+ checkComp m [] (0,0) []+ checkComp m ["--"] (0,2) []+ checkComp m ["bob"] (0,3) []+ checkComp m ["-"] (0,1) [CompleteValue "-"] testFlags = do let m = name "Flags" $ mode "" [] "" (flagArg (upd "") "")@@ -58,10 +62,18 @@ checkGood m ["-tm"] ["test","more"] checkGood m ["--col=red"] ["colorred"] checkGood m ["--col","red","-t"] ["colorred","test"]+ checkComp m ["--tes"] (0,5) [CompleteValue "--test"]+ checkComp m ["--color","--tes"] (1,5) []+ checkComp m ["--more","--tes"] (1,5) [CompleteValue "--test"]+ checkComp m ["--moo","--tes"] (1,5) [CompleteValue "--test"]+ checkComp m ["--col"] (0,5) [CompleteValue "--color"]+ checkComp m ["--bob"] (0,5) [CompleteValue "--bobby",CompleteValue "--bob"]+ checkComp m ["-"] (0,1) $ map CompleteValue $ words "--test --more --color --bob -x -"+ checkComp m ["--"] (0,2) $ map CompleteValue $ words "--test --more --color --bob --xxx" testModes = do let m = name "Modes" $ modes "" [] ""- [(mode "test" ["test"] "" undefined [flagNone ["bob"] ("bob":) ""]){modeArgs=Nothing}+ [(mode "test" ["test"] "" undefined [flagNone ["bob"] ("bob":) ""]){modeArgs=([],Nothing)} ,mode "dist" ["dist"] "" (flagArg (upd "") "") [flagNone ["bob"] ("bob":) "", flagReq ["bill"] (upd "bill") "" ""]] checkGood m [] [] checkFail m ["--bob"]@@ -91,3 +103,9 @@ Left err -> failure "Failed when should have succeeded" [("Name",n),("Args",show xs),("Error",err)] Right a | reverse a /= ys -> failure "Wrong parse" [("Name",n),("Args",show xs),("Wanted",show ys),("Got",show $ reverse a)] _ -> success++checkComp :: (String,Mode [String]) -> [String] -> (Int,Int) -> [Complete] -> IO ()+checkComp (n,m) xs ab want+ | want == got = success+ | otherwise = failure "Bad completions" [("Name",n),("Args",show xs),("Index",show ab),("Wanted",show want),("Got",show got)]+ where got = complete m xs ab
System/Console/CmdArgs/Test/Implicit/Diffy.hs view
@@ -1,6 +1,8 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, TemplateHaskell, MagicHash #-}+{-# OPTIONS_GHC -fno-warn-missing-fields #-} module System.Console.CmdArgs.Test.Implicit.Diffy where import System.Console.CmdArgs+import System.Console.CmdArgs.Quote import System.Console.CmdArgs.Test.Implicit.Util data Diffy = Create {src :: Maybe FilePath, out :: FilePath}@@ -22,14 +24,37 @@ mode = cmdArgsMode $ modes [create,diff] &= help "Create and compare differences" &= program "diffy" &= summary "Diffy v1.0" ++$(cmdArgsQuote+ [d|+ outFlags_ x = x &=# help "Output file" &=# typFile++ create_ = Create+ {src = Nothing &=# help "Source directory" &=# typDir+ ,out = outFlags_ "ls.txt"+ } &=# help "Create a fingerprint"++ diff_ = Diff+ {old = "" &=# typ "OLDFILE" &=# argPos 0+ ,new = "" &=# typ "NEWFILE" &=# argPos 1+ ,out = outFlags_ "diff.txt"+ } &=# help "Perform a diff"++ mode_ = cmdArgsMode# $ modes# [create_,diff_] &=# help "Create and compare differences" &=# program "diffy" &=# summary "Diffy v1.0"+ |])+++-- STOP MANUAL+ test = do- let Tester{..} = tester "Diffy" mode+ let Tester{..} = testers "Diffy" [mode,mode_] fails []- isHelp ["--help"] []+ isHelp ["--help"] ["diffy [COMMAND] ... [OPTIONS]"] -- FIXME: Should know that root is not valid, thus no brackets on [COMMAND] isHelp ["create","--help"] [] isHelp ["diff","--help"] [] isHelpNot ["--help"] ["diffy"] isVersion ["--version"] "Diffy v1.0"+ isVersion ["--numeric-version"] "1.0" ["create"] === create fails ["create","file1"] fails ["create","--quiet"]@@ -42,4 +67,6 @@ ["diff","foo1","foo2"] === diff{old="foo1",new="foo2"} fails ["diff","foo1"] fails ["diff","foo1","foo2","foo3"]-+ completion [] (0,0) [CompleteValue "create",CompleteValue "diff",CompleteValue "--out",CompleteValue "--help",CompleteValue "--version",CompleteValue "--numeric-version"]+ completion ["d"] (0,1) [CompleteValue "diff"]+ completion ["dd"] (0,2) []
System/Console/CmdArgs/Test/Implicit/HLint.hs view
@@ -9,7 +9,7 @@ {report :: [FilePath] ,hint :: [FilePath] ,color :: Bool- ,ignore :: [String]+ ,ignore_ :: [String] ,show_ :: Bool ,extension :: [String] ,language :: [String]@@ -28,7 +28,7 @@ {report = def &= opt "report.html" &= typFile &= help "Generate a report in HTML" ,hint = def &= typFile &= help "Hint/ignore file to use" ,color = def &= name "c" &= name "colour" &= help "Color the output (requires ANSI terminal)"- ,ignore = def &= typ "MESSAGE" &= help "Ignore a particular hint"+ ,ignore_ = def &= typ "MESSAGE" &= help "Ignore a particular hint" ,show_ = def &= help "Show all ignored ideas" ,extension = def &= typ "EXT" &= help "File extensions to search (defaults to hs and lhs)" ,language = def &= name "X" &= typ "LANG" &= help "Language extension (Arrows, NoCPP)"@@ -39,7 +39,7 @@ ,datadir = def &= typDir &= help "Override the data directory" ,cpp_define = def &= typ "NAME[=VALUE]" &= help "CPP #define" ,cpp_include = def &= typDir &= help "CPP include path"- ,files = def &= args &= typ "FILES/DIRS"+ ,files = def &= args &= typ "FILE/DIR" } &= verbosity &= help "Suggest improvements to Haskell source code" &=@@ -49,6 +49,8 @@ mode = cmdArgsMode hlint +-- STOP MANUAL+ test = do let Tester{..} = tester "HLint" mode [] === hlint@@ -59,6 +61,9 @@ isVerbosity [] Normal isHelp ["-?"] ["HLint v0.0.0, (C) Neil Mitchell"] isHelp ["--help"] [" hlint src --report"]+ isVersion ["--version"] "HLint v0.0.0, (C) Neil Mitchell"+ isVersion ["-V"] "HLint v0.0.0, (C) Neil Mitchell"+ isVersion ["--numeric-version"] "0.0.0" ["--colo"] === hlint{color=True} ["--colour","--colour=false"] === hlint ["--colour=true"] === hlint{color=True}@@ -70,5 +75,4 @@ ["--cpp-define=val","x"] === hlint{cpp_define=["val"],files=["x"]} fails ["--cpp-define"] ["--cpp-define","val","x","y"] === hlint{cpp_define=["val"],files=["x","y"]}--+ completion ["T"] (0,1) [CompleteFile "" "T", CompleteDir "" "T"]
System/Console/CmdArgs/Test/Implicit/Maker.hs view
@@ -31,9 +31,11 @@ ,files = def &= args } &= help "Build the project" &= auto -mode = cmdArgsMode $ modes [build,wipe,test_] &= help "Build helper program" &= program "maker" &= summary "Maker v1.0"+mode = cmdArgsMode $ modes [build,wipe,test_] &= help "Build helper program" &= program "maker" &= summary "Maker v1.0\nMake it" -mode_ = cmdArgsMode_ $ modes_ [build,wipe,test_] += help "Build helper program" += program "maker" += summary "Maker v1.0"+-- STOP MANUAL++mode_ = cmdArgsMode_ $ modes_ [build,wipe,test_] += help "Build helper program" += program "maker" += summary "Maker v1.0\nMake it" where threads_ = threads := def += help "Number of threads to use" += name "j" += typ "NUM" @@ -45,7 +47,7 @@ ] += help "Run the test suite" build = record Build{}- [threads_ + [threads_ ,enum_ method [atom Release += help "Release build" ,atom Debug += help "Debug build"@@ -57,6 +59,7 @@ test = do let Tester{..} = testers "Maker" [mode,mode_] [] === build+ isHelp ["--help"] ["Maker v1.0","Make it"] isHelp ["-?=one"] ["Common flags:"] isHelpNot ["-?=one"] [" -d --debug Debug build"] isHelp ["-?=all"] ["maker [build] [OPTIONS] [ITEM]"]
System/Console/CmdArgs/Test/Implicit/Tests.hs view
@@ -1,33 +1,32 @@-{-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}-{-# OPTIONS_GHC -fno-warn-missing-fields -fno-warn-unused-binds #-}+{-# LANGUAGE DeriveDataTypeable, RecordWildCards, TemplateHaskell, MagicHash #-}+{-# OPTIONS_GHC -fno-warn-missing-fields -fno-warn-unused-binds -fno-cse #-} -module System.Console.CmdArgs.Test.Implicit.Tests where+module System.Console.CmdArgs.Test.Implicit.Tests(test, demos) where import System.Console.CmdArgs import System.Console.CmdArgs.Explicit(modeHelp) import System.Console.CmdArgs.Test.Implicit.Util---test = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> test9 >> test10 >>- test11 >> test12 >> test13-demos = zipWith f [1..]- [toDemo mode1, toDemo mode2, toDemo mode3, toDemo mode4, toDemo mode5, toDemo mode6- ,toDemo mode7, toDemo mode8, toDemo mode9, toDemo mode10, toDemo mode11, toDemo mode12- ,toDemo mode13]- where f i x = x{modeHelp = "Testing various corner cases (" ++ show i ++ ")"}+import System.Console.CmdArgs.Quote+import Data.Int+import Data.Ratio -- from bug #256 and #231 data Test1 = Test1 {maybeInt :: Maybe Int, listDouble :: [Double], maybeStr :: Maybe String, float :: Float- ,bool :: Bool, maybeBool :: Maybe Bool, listBool :: [Bool]}+ ,bool :: Bool, maybeBool :: Maybe Bool, listBool :: [Bool], int64 :: Int64} deriving (Show,Eq,Data,Typeable) -def1 = Test1 def def def (def &= args) def def def+def1 = Test1 def def def (def &= args) def def def def mode1 = cmdArgsMode def1 +$(cmdArgsQuote [d|+ mode1_ = cmdArgsMode# def1_+ def1_ = Test1 def def def (def &=# args) def def def def+ |])+ test1 = do- let Tester{..} = tester "Test1" mode1+ let Tester{..} = testers "Test1" [mode1,mode1_] [] === def1 ["--maybeint=12"] === def1{maybeInt = Just 12} ["--maybeint=12","--maybeint=14"] === def1{maybeInt = Just 14}@@ -43,8 +42,9 @@ ["--maybebool"] === def1{maybeBool=Just True} ["--maybebool=off"] === def1{maybeBool=Just False} ["--listbool","--listbool=true","--listbool=false"] === def1{listBool=[True,True,False]}+ ["--int64=12"] === def1{int64=12} fails ["--listbool=fred"]- invalid $ \_ -> def1{listBool = def &= opt "yes"}+ invalid $ const def1{listBool = def &= opt "yes"} -- from bug #230@@ -67,8 +67,11 @@ mode3 = cmdArgsMode $ Test3 (def &= argPos 1) (def &= argPos 2 &= opt "foo") (def &= args) +$(cmdArgsQuote [d| mode3_ = cmdArgsMode# $ Test3 (def &=# argPos 1) (def &=# argPos 2 &=# opt "foo") (def &=# args) |])++ test3 = do- let Tester{..} = tester "Test3" mode3+ let Tester{..} = testers "Test3" [mode3,mode3_] fails [] fails ["a"] ["a","1"] === Test3 [1] ["foo"] ["a"]@@ -228,13 +231,15 @@ ["t"] === Test12B --- the ignore annotation+-- the ignore annotation and versionArg [summary] data Test13 = Test13A {foo13 :: Int, bar13 :: Either Int Int} | Test13B {foo13 :: Int} | Test13C {foo13 :: Int} deriving (Eq,Show,Data,Typeable) mode13 = cmdArgsMode $ modes [Test13A 1 (Left 1 &= ignore), Test13B 1 &= ignore, Test13C{}]+ &= versionArg [summary "Version text here"]+ &= summary "Help text here" test13 = do let Tester{..} = tester "Test13" mode13@@ -242,3 +247,173 @@ fails ["test13a --bar13=1"] ["test13a","--foo13=13"] === Test13A 13 (Left 1) ["test13c","--foo13=13"] === Test13C 13+ isHelp ["--help"] ["Help text here"]+ isVersion ["--version"] "Version text here"+ fails ["--numeric-version"]++-- check a list becomes modes not an enum+data Test14 = Test14A | Test14B | Test14C deriving (Eq,Show,Data,Typeable)++mode14 = cmdArgsMode $ modes [Test14A, Test14B, Test14C]++test14 = do+ let Tester{..} = tester "Test14" mode14+ fails []+ ["test14a"] === Test14A+ fails ["--test14a"]++-- custom help flags+data Test15 = Test15 {test15a :: Bool} deriving (Eq,Show,Data,Typeable)++mode15 = cmdArgsMode $ Test15 (False &= name "help")+ &= helpArg [groupname "GROUP", name "h", name "nohelp", explicit, help "whatever\nstuff"] &= versionArg [ignore]+ &= verbosityArgs [ignore] [explicit,name "silent"]++$(cmdArgsQuote [d|+ mode15_ = cmdArgsMode# $ Test15 (False &=# name "help")+ &=# helpArg [groupname "GROUP", name "h", name "nohelp", explicit, help "whatever\nstuff"] &=# versionArg [ignore]+ &=# verbosityArgs [ignore] [explicit,name "silent"]+ |])++test15 = do+ let Tester{..} = testers "Test15" [mode15,mode15_]+ invalid $ \_ -> Test15 (False &= name "help")+ ["--help"] === Test15 True+ ["-t"] === Test15 True+ fails ["-?"]+ isHelp ["--nohelp"] [" -h --nohelp whatever"]+ isHelp ["-h"] []+ isHelp ["-h"] ["GROUP:"]+ fails ["--version"]+ fails ["--numeric-version"]+ fails ["--verbose"]+ fails ["--quiet"]+ isVerbosity ["--help","--silent"] Quiet++-- check newtype support+newtype MyInt = MyInt Int deriving (Eq,Show,Data,Typeable)++data Test16 = Test16 {test16a :: MyInt, test16b :: [MyInt]} deriving (Eq,Show,Data,Typeable)++mode16 = cmdArgsMode $ Test16 (MyInt 12) [] &= summary "The Glorious Glasgow Haskell Compilation System, version 7.6.3"++test16 = do+ let Tester{..} = tester "Test16" mode16+ [] === Test16 (MyInt 12) []+ isVersion ["--numeric-version"] "7.6.3"+ fails ["--test16a"]+ ["--test16a=5"] === Test16 (MyInt 5) []+ ["--test16b=5","--test16b=82"] === Test16 (MyInt 12) [MyInt 5, MyInt 82]++-- #552, @ directives not expanded after -- symbols+-- not actually checked because this path doesn't go through processArgs+data Test17 = Test17 {test17_ :: [String]} deriving (Eq,Show,Data,Typeable)++mode17 = cmdArgsMode $ Test17 ([] &= args) &= noAtExpand &= summary "bzip2 3.5-windows version"++test17 = do+ let Tester{..} = tester "Test17" mode17+ [] === Test17 []+ ["test","of","this"] === Test17 ["test","of","this"]+ ["test","--","@foo"] === Test17 ["test","@foo"]+ isVersion ["--numeric-version"] "3.5-windows"+++data Debuggable = This | That deriving (Eq,Show,Data,Typeable)+data Test18 = Test18 {test18_ :: [Debuggable]} deriving (Eq,Show,Data,Typeable)++mode18 = cmdArgsMode $ Test18 $ enum [[] &= ignore, [This] &= name "debug-this", [That] &= name "debug-that"]++test18 = do+ let Tester{..} = tester "Test18" mode18+ [] === Test18 []+ ["--debug-this","--debug-that","--debug-this"] === Test18 [This,That,This]++-- #610, check performance for long lists (took ~20s before)++data Test19 = Test19 {test19_ :: [String]} deriving (Eq,Show,Data,Typeable)++mode19 = cmdArgsMode $ Test19 ([] &= args)++test19 = do+ let Tester{..} = tester "Test19" mode19+ let args = map show [1..1000]+ args === Test19 args+++-- #615, newtype wrappers of lists/Maybe should accumulate properly++newtype Test20A = Test20A [String] deriving (Eq,Show,Data,Typeable)+data Test20 = Test20 {test20_ :: Test20A} deriving (Eq,Show,Data,Typeable)++mode20 = cmdArgsMode $ Test20 (Test20A [] &= args)++test20 = do+ let Tester{..} = tester "Test20" mode20+ ["a","b","c"] === Test20 (Test20A ["a","b","c"])+++-- #626, don't reverse values too much++newtype Test21A = Test21A [String] deriving (Eq,Show,Data,Typeable)+data Test21 = Test21 {test21A :: Test21A, test21B :: [String], test21C :: [Int]} deriving (Eq,Show,Data,Typeable)++mode21 = cmdArgsMode $ Test21 (Test21A ["a","b","c"]) ["A","B","C"] [1,2,3]++test21 = do+ let Tester{..} = tester "Test21" mode21+ [] === Test21 (Test21A ["a","b","c"]) ["A","B","C"] [1,2,3]++-- #10, don't break elm-server++data Test22 = Test22 {port :: Int, runtime :: Maybe FilePath} deriving (Data,Typeable,Show,Eq)++mode22 = cmdArgsMode $ Test22+ { port = 8000 &= help "set the port of the server"+ , runtime = Nothing &= typFile+ &= help "Specify a custom location for Elm's runtime system."+ } &= help "Quickly reload Elm projects in your browser. Just refresh to recompile.\n\+ \It serves static files and freshly recompiled Elm files."+ &= helpArg [explicit, name "help", name "h"]+ &= versionArg [ explicit, name "version", name "v"+ , summary "0.12.0.1"+ ]+ &= summary "Elm Server 0.11.0.1, (c) Evan Czaplicki 2011-2014"++test22 = do+ let Tester{..} = tester "Test22" mode22+ [] === Test22 8000 Nothing+ isVersion ["-v"] "0.12.0.1"+ isVersion ["--version"] "0.12.0.1"+ isVersion ["--numeric-version"] "0.12.0.1"+ isHelp ["--help"] ["Elm Server 0.11.0.1, (c) Evan Czaplicki 2011-2014"]+ isHelp ["--h"] ["Elm Server 0.11.0.1, (c) Evan Czaplicki 2011-2014"]+ fails ["-?"]+ ["--port=20"] === Test22 20 Nothing+ ["--runtime=20"] === Test22 8000 (Just "20")+ fails ["bob"]++-- # 24, doesn't work with Ratio++data Test23 = Test23 {test23A :: Ratio Int} deriving (Show, Data, Typeable, Eq)++mode23 = cmdArgsMode $ Test23 {test23A = 4 % 7 }++test23 = do+ let Tester{..} = tester "Test23" mode23+ [] === Test23 (4 % 7)+ ["--test23=1,6"] === Test23 (1 % 6)+++-- For some reason, these must be at the end, otherwise the Template Haskell+-- stage restriction kicks in.++test = test1 >> test2 >> test3 >> test4 >> test5 >> test6 >> test7 >> test8 >> test9 >> test10 >>+ test11 >> test12 >> test13 >> test14 >> test15 >> test16 >> test18 >> test19 >> test20 >>+ test21 >> test22 >> test23+demos = zipWith f [1..]+ [toDemo mode1, toDemo mode2, toDemo mode3, toDemo mode4, toDemo mode5, toDemo mode6+ ,toDemo mode7, toDemo mode8, toDemo mode9, toDemo mode10, toDemo mode11, toDemo mode12+ ,toDemo mode13, toDemo mode14, toDemo mode15, toDemo mode16, toDemo mode17, toDemo mode18+ ,toDemo mode19, toDemo mode20, toDemo mode21, toDemo mode22, toDemo mode23]+ where f i x = x{modeHelp = "Testing various corner cases (" ++ show i ++ ")"}
System/Console/CmdArgs/Test/Implicit/Util.hs view
@@ -1,6 +1,9 @@ {-# LANGUAGE PatternGuards #-} -module System.Console.CmdArgs.Test.Implicit.Util where+module System.Console.CmdArgs.Test.Implicit.Util(+ module System.Console.CmdArgs.Test.Implicit.Util,+ Complete(..)+ ) where import System.Console.CmdArgs.Implicit import System.Console.CmdArgs.Explicit@@ -29,48 +32,74 @@ ,isHelpNot :: [String] -> [String] -> IO () ,isVersion :: [String] -> String -> IO () ,isVerbosity :: [String] -> Verbosity -> IO ()+ ,completion :: [String] -> (Int,Int) -> [Complete] -> IO () } testers :: (Show a, Eq a) => String -> [Mode (CmdArgs a)] -> Tester a testers name = foldr1 f . map (tester name) where- f (Tester x1 x2 x3 x4 x5 x6) (Tester y1 y2 y3 y4 y5 y6) =- Tester (f2 x1 y1) (f1 x2 y2) (f2 x3 y3) (f2 x4 y4) (f2 x5 y5) (f2 x6 y6)+ f (Tester x1 x2 x3 x4 x5 x6 x7) (Tester y1 y2 y3 y4 y5 y6 y7) =+ Tester (f2 x1 y1) (f1 x2 y2) (f2 x3 y3) (f2 x4 y4) (f2 x5 y5) (f2 x6 y6) (f3 x7 y7) f1 x y a = x a >> y a f2 x y a b = x a b >> y a b+ f3 x y a b c = x a b c >> y a b c tester :: (Show a, Eq a) => String -> Mode (CmdArgs a) -> Tester a-tester name m = Tester (===) fails isHelp isHelpNot isVersion isVerbosity+tester name m = Tester (===) fails isHelp isHelpNot isVersion isVerbosity completion where failed msg args xs = failure msg $ ("Name","Implicit "++name):("Args",show args):xs - (===) args v = case process m args of+ f args cont = case process m args of+ Left x -> cont $ Left x+ Right x -> cont $ Right x+{-+ o@(Right x)+ | x2 == Right x -> cont $ Right x+ | otherwise -> do+ failed "Reform failed" args [("Reformed",show args2),("Expected",show o),("Got",show x2)]+ error "failure!"+ cont $ Right x+ where args2 = cmdArgsReform m x+ x2 = process m args2+-}++ (===) args v = f args $ \x -> case x of Left x -> failed "Failed when should have succeeded" args [("Error",x)] Right x | cmdArgsValue x /= v -> failed "Wrong parse" args [("Expected",show v),("Got",show x)] | otherwise -> success - fails args = case process m args of+ fails args = f args $ \x -> case x of Left x -> success- Right x -> failed "Succeeded when should have failed" args [("Result",show x)]+ Right x -> failed "Succeeded 52 should have failed" args [("Result",show x)] - isHelp args want = case process m args of+ showGot sel x = [("Got",show got) | Right x <- [x], Just got <- [sel x]]++ isHelp args want = f args $ \x -> case x of Right x | Just got <- cmdArgsHelp x, match want (lines got) -> success- _ -> failed "Failed on isHelp" args []+ _ -> failed "Failed on isHelp" args $+ ("Want",show want) : showGot cmdArgsHelp x - isHelpNot args want = case process m args of+ isHelpNot args want = f args $ \x -> case x of Right x | Just got <- cmdArgsHelp x, not $ match want (lines got) -> success _ -> failed "Failed on isHelpNot" args [] - isVersion args want = case process m args of- Right x | Just got <- cmdArgsVersion x, match [want] [got] -> success- _ -> failed "Failed on isVersion" args []+ isVersion args want = f args $ \x -> case x of+ Right x | Just got <- cmdArgsVersion x, (want ++ "\n") == got -> success+ _ -> failed "Failed on isVersion" args $+ ("Want",show $ want ++ "\n") : showGot cmdArgsVersion x - isVerbosity args v = case process m args of+ isVerbosity args v = f args $ \x -> case x of Right x | fromMaybe Normal (cmdArgsVerbosity x) == v -> success _ -> failed "Failed on isVerbosity" args [] + completion args pos res+ | res == ans = success+ | otherwise = failed "Failed on completion" args [("Position",show pos),("Want",shw res),("Got",shw ans)]+ where ans = complete m args pos+ shw = intercalate ", " . lines . show + match :: [String] -> [String] -> Bool match want got = any f $ tails got where f xs = length xs >= length want && and (zipWith matchLine want xs)@@ -81,4 +110,3 @@ matchLine (x:xs) (y:ys) | x == y = matchLine xs ys matchLine [] [] = True matchLine _ _ = False-
+ System/Console/CmdArgs/Test/SplitJoin.hs view
@@ -0,0 +1,149 @@+{-# LANGUAGE QuasiQuotes #-}++module System.Console.CmdArgs.Test.SplitJoin(test) where++import System.Console.CmdArgs.Explicit+import System.Console.CmdArgs.Test.Util+import Control.Monad++++test = do+ forM_ tests $ \(src,parsed) -> do+ let a = splitArgs src+ b1 = joinArgs parsed+ b2 = joinArgs $ splitArgs b1+ if a == parsed then return () else failure "splitArgs" [("Given ",src),("Expected",show parsed),("Found ",show a)]+ if b1 == b2 then return () else failure "joinArgs" [("Given ",show parsed),("Expected",b1),("Found ",b2)]+ success++{-+newtype CmdLine = CmdLine String deriving Show++instance Arbitrary CmdLine where+ arbitrary = fmap CmdLine $ listOf $ elements "abcd \\/\'\""++generateTests :: IO ()+generateTests = withTempFile $ \src -> do+ writeFile src "import System.Environment\nmain = print =<< getArgs\n"+ quickCheckWith stdArgs{chatty=False} $ \(CmdLine x) -> unsafePerformIO $ do+ putStr $ ",(,) " ++ (show x) ++ " "+ system $ "runghc \"" ++ src ++ "\" " ++ x+ return True+++withTempFile :: (FilePath -> IO a) -> IO a+withTempFile f = bracket+ (do (file,h) <- openTempFile "." "cmdargs.hs"; hClose h; return file)+ removeFile+ f+-}++-- Pregenerate the QuickCheck tests and run them through the system console+-- Not done each time for three reasons+-- * Avoids an extra dependency on QuickCheck + process+-- * Slow to run through the command line+-- * Can't figure out how to read the output, without adding more escaping (which breaks the test)+tests =+ [f "" []+ ,f "c" ["c"]+ ,f "b" ["b"]+ ,f "\\" ["\\"]+ ,f "'//" ["'//"]+ ,f "a" ["a"]+ ,f "cda" ["cda"]+ ,f "b'" ["b'"]+ ,f "" []+ ,f " " []+ ,f "/b" ["/b"]+ ,f "\"b/\"d a'b'b" ["b/d","a'b'b"]+ ,f "d'c a\"/\\" ["d'c","a/\\"]+ ,f "d" ["d"]+ ,f "bb' " ["bb'"]+ ,f "b'\\" ["b'\\"]+ ,f "\"\\ac" ["\\ac"]+ ,f "\\'\"abbb\"c/''' \\ c" ["\\'abbbc/'''","\\","c"]+ ,f "/bbdbb a " ["/bbdbb","a"]+ ,f "b\" d" ["b d"]+ ,f "" []+ ,f "\\cc/''\\b\\ccc\\'\\b\\" ["\\cc/''\\b\\ccc\\'\\b\\"]+ ,f "/" ["/"]+ ,f "///\"b\\c/b\"cd//c'\"" ["///b\\c/bcd//c'"]+ ,f "\\\"d\\\\' /d\\\\/bb'a /\\d" ["\"d\\\\'","/d\\\\/bb'a","/\\d"]+ ,f "c/ \\''/c b\\'" ["c/","\\''/c","b\\'"]+ ,f "dd'b\\\\\\' /c'aaa\"" ["dd'b\\\\\\'","/c'aaa"]+ ,f "b'd''\\/ b\\'b'db/'cd " ["b'd''\\/","b\\'b'db/'cd"]+ ,f "a\"ba\\/\\ " ["aba\\/\\ "]+ ,f "b\"'dd'c /b/c\"bbd \"\"\\ad'\"c\\\"" ["b'dd'c /b/cbbd","\\ad'c\""]+ ,f "da 'c\\\\acd/'dbaaa///dccbc a \\" ["da","'c\\\\acd/'dbaaa///dccbc","a","\\"]+ ,f "a'ac \"da\"" ["a'ac","da"]+ ,f "\"'\\\"/\"\"b\\b \"'\"\"ccd'a\"/c /da " ["'\"/\"b\\b","'\"ccd'a/c /da "]+ ,f "d\"\\c\\\\cb c/\"aa' b\"\\/d \"'c c/" ["d\\c\\\\cb c/aa'","b\\/d 'c","c/"]+ ,f "dbc\\/\"\"//c/\"accda" ["dbc\\///c/accda"]+ ,f "aca a'' \\ c b'\\/d\\" ["aca","a''","\\","c","b'\\/d\\"]+ ,f "dc\"bc/a\\ccdd\\\\aad\\c'ab '\\cddcdba" ["dcbc/a\\ccdd\\\\aad\\c'ab '\\cddcdba"]+ ,f " c'\"ba \"b\\dc\"" ["c'ba b\\dc"]+ ,f "a\\acd/a \"'c /'c'" ["a\\acd/a","'c /'c'"]+ ,f " ac ddc/\"\"a/\\bd\\d c'cac\"c\\a/a''c" ["ac","ddc/a/\\bd\\d","c'cacc\\a/a''c"]+ ,f "b/cd\"//bb\"/daaab/ b b \"' d\"a\" 'd b" ["b/cd//bb/daaab/","b","b","' da 'd b"]+ ,f "a\"cc'cd\"\\'ad '\"dcc acb\"\\\\" ["acc'cd\\'ad","'dcc acb\\\\"]+ ,f "/bc/bc'/\"d \"a/\"\\ad aba\\da" ["/bc/bc'/d a/\\ad aba\\da"]+ ,f "b\\a" ["b\\a"]+ ,f "/dc ''c'a\"'/'\\ /'cd\\'d/'db/b\"' cabacaaa\"\"dd" ["/dc","''c'a'/'\\ /'cd\\'d/'db/b'","cabacaaadd"]+ ,f "\"ac\\\"c'/c'b\"b\"b'd\"c\"\"" ["ac\"c'/c'bbb'dc"]+ ,f "/ 'ccc\"d\\dc'\"'\\ b" ["/","'cccd\\dc''\\","b"]+ ,f " '\"/\\cc\\/c '\\\\" ["'/\\cc\\/c '\\\\"]+ ,f "\\ \\' ' /d \"cc\\\\//da\"d'a/a\"ca\\\\\"\\cb c\"d'b 'acb" ["\\","\\'","'","/d","cc\\\\//dad'a/aca\\\\cb","cd'b 'acb"]+ ,f "a\"\"d'\"a\"\\ \\c db'da/d\\c\"a/ aa c/db" ["ad'a\\","\\c","db'da/d\\ca/ aa c/db"]+ ,f " d\\" ["d\\"]+ ,f "d c b'/\\/'\"/'a'aa\"a\"/ad\\/" ["d","c","b'/\\/'/'a'aaa/ad\\/"]+ ,f " a \\' /" ["a","\\'","/"]+ ,f "'/ c" ["'/","c"]+ ,f "acd 'bcab /ba'daa'/ba/\"dcdadbcacb" ["acd","'bcab","/ba'daa'/ba/dcdadbcacb"]+ ,f "a\\\"dd'a c\"a\"\"ac\\" ["a\"dd'a","ca\"ac\\"]+ ,f "\"dba /'bb\\ d ba '/c' \"dd\\' cbcd c /b/\\b///" ["dba /'bb\\ d ba '/c' dd\\'","cbcd","c","/b/\\b///"]+ ,f "a'c/c \"ccb '/d\\abd/bc " ["a'c/c","ccb '/d\\abd/bc "]+ ,f "\\da\"\\//add\\\\ c" ["\\da\\//add\\\\ c"]+ ,f "c/\\\"// a/\"ac\"//''ba\"c/\\bc\\\"d\"bc/d" ["c/\"//","a/ac//''bac/\\bc\"dbc/d"]+ ,f "/d/ a dc'\\ \"" ["/d/","a","dc'\\",""]+ ,f " \"dc//b\\cd/ \\ac\"b\"b\"d\"\"\"dd\"\" ' a\\'/ \"/'/\\a/abd\\ddd" ["dc//b\\cd/ \\acbbd\"dd","'","a\\'/","/'/\\a/abd\\ddd"]+ ,f "\\' ' d\"b bbc" ["\\'","'","db bbc"]+ ,f "'ba\\a'db/bd d\\'b\\ \\/a'da' " ["'ba\\a'db/bd","d\\'b\\","\\/a'da'"]+ ,f "\\b\\cc\"\"d' dd ddcb\"d" ["\\b\\ccd'","dd","ddcbd"]+ ,f "d\"dc'\\d\"/'\\\"b\\c'c\" db' \\'b/\"a' / da'\"/ab'\\ c\\bc\\//dbcb\\" ["ddc'\\d/'\"b\\c'c db' \\'b/a'","/","da'/ab'\\ c\\bc\\//dbcb\\"]+ ,f " b ddbbbbc\"da\\c\"'\\" ["b","ddbbbbcda\\c'\\"]+ ,f "b/\"d dacd'/'\\\"''a a /'\\c'b ab\\ dda\\c'abdd'a\"//d \\\\\\ d\"\"" ["b/d dacd'/'\"''a a /'\\c'b ab\\ dda\\c'abdd'a//d","\\\\\\","d"]+ ,f "/c\"\" dd'a'/b\\/'\"'/" ["/c","dd'a'/b\\/''/"]+ ,f "/\"'\"\"'cc a a\\dd''\\'b" ["/'\"'cc","a","a\\dd''\\'b"]+ ,f "c\"dcd''aba\" \" /'" ["cdcd''aba"," /'"]+ ,f "'\"/''\\\\d'/ad\\baadabdca\\ /\\'''bd\\/\"'/' aca \\ \\a'\\ cd\"d /bdcd''cac" ["'/''\\\\d'/ad\\baadabdca\\ /\\'''bd\\/'/'","aca","\\","\\a'\\","cdd /bdcd''cac"]+ ,f "\" /\"da" [" /da"]+ ,f "'\"ca/'d/d/d\\ca\"/\"\" ddac cc\" ''a c''bd\"bc'dc\\/\"b\"a\\\"\"a/\\ " ["'ca/'d/d/d\\ca/","ddac","cc ''a c''bdbc'dc\\/ba\"a/\\ "]+ ,f "\\\\d'ad ' ''\"cd/a \"\"\\'\\\"'dc\\" ["\\\\d'ad","'","''cd/a \"\\'\"'dc\\"]+ ,f " ab c'\\a" ["ab","c'\\a"]+ ,f "b" ["b"]+ ,f "''c dc c\\'d'ab'd\"\\\"cca\"b'da\"dbcdbd\"cd'/d \\cd'\"d \"\"b cdc''/\\\"b'" ["''c","dc","c\\'d'ab'd\"ccab'dadbcdbdcd'/d","\\cd'd \"b","cdc''/\"b'"]+ ,f " \"'cb dbddbdd/" ["'cb dbddbdd/"]+ ,f "a/\"d// dd/cc/\"cc\"d\" d\\/a a \\c\" \\\\/\"\\ bcc'ac'\"\\c//d\"da/\\aac\\b\"c/'b\"\"bbd/\\" ["a/d// dd/cc/ccd","d\\/a","a","\\c \\\\/\\","bcc'ac'\\c//dda/\\aac\\bc/'b\"bbd/\\"]+ ,f "b\"ddccd\"a\"/ba\"" ["bddccda/ba"]+ ,f " \" c/b/'/bdd cb d'c a'\"'a d\\\\db//\\\"' c'/'c\\/aa" [" c/b/'/bdd cb d'c a''a","d\\\\db//\"'","c'/'c\\/aa"]+ ,f "\\caab" ["\\caab"]+ ,f "bb\"'\"/d'bad 'd\\/'\\b//\\\\ \\d''c\"c b\\b/\\" ["bb'/d'bad","'d\\/'\\b//\\\\","\\d''cc b\\b/\\"]+ ,f " c'a\" \\cab\"bd\"dcd\"/cb/\"\"b\"b'\"d" ["c'a \\cabbddcd/cb/bb'd"]+ ,f "\\/ \"c'ca" ["\\/","c'ca"]+ ,f " d' /c'bc\"'/'\\\\dca'cc\"'\"''/d cb//'a \"bd ab\"dcaadc\\\"'d\\\"/a\"a\\\"ba//b/ d/dbac/d\\caa\"bc/ " ["d'","/c'bc'/'\\\\dca'cc'''/d cb//'a bd","abdcaadc\"'d\"/aa\"ba//b/","d/dbac/d\\caabc/ "]+ ,f "/\"\\db'd/ ca\"ad b\\\\\"cd/a bbc\\ " ["/\\db'd/ caad","b\\cd/a bbc\\ "]+ ,f "cdc bd'/\"c''c d \\\"aa \\d\\ bb'b/ /b/a/c'acda\\'\"\"c \"bbbaa/'/a \\aca\"'/ac' " ["cdc","bd'/c''c d \"aa \\d\\ bb'b/ /b/a/c'acda\\'\"c","bbbaa/'/a \\aca'/ac'"]+ ,f "ad/'b\\d /cc\"\"ab \\ \"' ''b\\\"/\\ a\"'d\"\\ddacdbbabb b b //' acd\"c\\d'd\\b\"'\\\"aaba/bda/c'// \\b" ["ad/'b\\d","/ccab","\\","' ''b\"/\\ a'd\\ddacdbbabb b b //' acdc\\d'd\\b'\"aaba/bda/c'// \\b"]+ ,f "bac cc \"ac\"/ca/ '\"\" b/b d /cd'\\'bb\" \\ \"b '/ b c ' c''\"a/ad\\ " ["bac","cc","ac/ca/","'","b/b","d","/cd'\\'bb \\ b","'/","b","c","'","c''a/ad\\ "]+ ,f "baa' b'b''\\dab/'c" ["baa'","b'b''\\dab/'c"]+ ,f "cb\\\\ " ["cb\\\\"]+ ,f "/b'a''d\"b\" 'c'b ba\\'b\" bb" ["/b'a''db","'c'b","ba\\'b bb"]+ ,f "b /\"ca\\cbac " ["b","/ca\\cbac "]+ ,f " \"\"/\"bcaa\"\"a' \\/bb \"a\\\"'\"" ["/bcaa\"a'","\\/bb","a\"'"]+ ,f "\"c /''c\"\\badc/\\daa/\\ c\"a c\\ \\/cab \"b\"\\ ba\"\"/d/cd'a ad'c/ad\"' a\\d/d\\c\\'cdccd/\"a'/\"b///ac\"" ["c /''c\\badc/\\daa/\\","ca c\\ \\/cab b\\ ba\"/d/cd'a","ad'c/ad' a\\d/d\\c\\'cdccd/a'/b///ac"]+ ,f "/cbbd\"/b' /dd\"/c\\ca/'\"\\ cc \\d\"aca/\"b caa\\d\\'\"b'b dc\"cd\\'c\" 'd/ac\"cacc\"" ["/cbbd/b' /dd/c\\ca/'\\ cc \\daca/b caa\\d\\'b'b","dccd\\'c","'d/accacc"]+ ,f "bc/bd\\ca\\bcacca\"\"\\c/\\ /\"\"a/\"c'//b'\\d/a/'ab/cbd/cacb//b \\d\"aac\\d'\"/" ["bc/bd\\ca\\bcacca\\c/\\","/a/c'//b'\\d/a/'ab/cbd/cacb//b \\daac\\d'/"]+ ,f "bbac bdc/d\\\"/db\"dbdb\"a \" /\"/'a\\acacbcc c'//\\//b\"ca\"bcca c\\/aaa/c/bccbccaa \"\" cdccc/bddcbc c''" ["bbac","bdc/d\"/dbdbdba"," //'a\\acacbcc","c'//\\//bcabcca","c\\/aaa/c/bccbccaa","","cdccc/bddcbc","c''"]+ ]+ where f = (,)
System/Console/CmdArgs/Text.hs view
@@ -107,7 +107,7 @@ -- | Split the text into strips of no-more than the given width wrap :: Int -> String -> [String]-wrap width = combine . split+wrap width = concatMap (combine . split) . lines where split :: String -> [(String,Int)] -- string, amount of space after split "" = []@@ -131,18 +131,24 @@ map f xs ++ ["</table>"] where- cols = maximum [length x | Cols x <- xs]+ maxCols = maximum [length x | Cols x <- xs] - f (Line x) = tr $ td cols x- f (Cols xs) = tr $ concatMap (td 1) (init xs) ++ td (cols + 1 - length xs) (last xs)+ f (Line x) = tr $ td maxCols x+ f (Cols xs) = tr $ concatMap (td 1) (init xs) ++ td (maxCols + 1 - length xs) (last xs) tr x = "<tr>" ++ x ++ "</tr>" td cols x = "<td" ++ (if cols == 1 then "" else " colspan='" ++ show cols ++ "'")- ++ (if a /= "" then " style='padding-left:" ++ show (length a) ++ "ex;'" else "") +++ ++ (if null styles then "" else " style='" ++ unwords styles ++ "'") ++ ">" ++ if null b then " " else concatMap esc b ++ "</td>" where (a,b) = span isSpace x+ -- if the first letter of the contents is '-', assume this is a flag+ -- and be aware that HTML might try to line-break it, see #39+ isFlag = take 1 b == "-"+ styles = [ "padding-left:" ++ show (length a) ++ "ex;" | a /= "" ]+ ++ [ "white-space:nowrap;" | isFlag ] esc '&' = "&" esc '>' = ">" esc '<' = "<"+ esc '\n' = "<br />" esc x = [x]
cmdargs.cabal view
@@ -1,13 +1,13 @@-cabal-version: >= 1.6+cabal-version: 1.18 build-type: Simple name: cmdargs-version: 0.6+version: 0.10.22 license: BSD3 license-file: LICENSE category: Console author: Neil Mitchell <ndmitchell@gmail.com> maintainer: Neil Mitchell <ndmitchell@gmail.com>-copyright: Neil Mitchell 2009-2010+copyright: Neil Mitchell 2009-2023 synopsis: Command line argument processing description: This library provides an easy way to define command line parsers. Most users@@ -28,18 +28,44 @@ . For a general reference on what command line flags are commonly used, see <http://www.faqs.org/docs/artu/ch10s05.html>.-homepage: http://community.haskell.org/~ndm/cmdargs/-stability: Beta-extra-source-files:- cmdargs.htm+bug-reports: https://github.com/ndmitchell/cmdargs/issues+homepage: https://github.com/ndmitchell/cmdargs#readme+extra-doc-files:+ README.md+ CHANGES.txt+tested-with: GHC==9.2, GHC==9.0, GHC==8.10, GHC==8.8, GHC==8.6, GHC==8.4, GHC==8.2, GHC==8.0 +source-repository head+ type: git+ location: https://github.com/ndmitchell/cmdargs.git+ flag testprog- default: True+ default: False+ manual: True description: Build the test program +flag quotation+ default: True+ manual: True+ description: Build the Quote module+ library- build-depends: base == 4.*, mtl, filepath+ default-language: Haskell2010+ build-depends:+ base >= 4.4 && < 5,+ filepath,+ transformers >= 0.2,+ process >= 1.0 + if impl(ghc < 8.0)+ build-depends: semigroups >= 0.18++ if flag(quotation)+ build-depends: template-haskell+ exposed-modules: System.Console.CmdArgs.Quote+ -- See bug #539 for why this magic is required+ other-extensions: TemplateHaskell+ exposed-modules: System.Console.CmdArgs System.Console.CmdArgs.Annotate@@ -48,24 +74,33 @@ System.Console.CmdArgs.GetOpt System.Console.CmdArgs.Implicit System.Console.CmdArgs.Text+ System.Console.CmdArgs.Helper System.Console.CmdArgs.Verbosity other-modules: Data.Generics.Any Data.Generics.Any.Prelude+ System.Console.CmdArgs.Explicit.Complete+ System.Console.CmdArgs.Explicit.ExpandArgsAt System.Console.CmdArgs.Explicit.Help System.Console.CmdArgs.Explicit.Process+ System.Console.CmdArgs.Explicit.SplitJoin System.Console.CmdArgs.Explicit.Type System.Console.CmdArgs.Implicit.Ann- System.Console.CmdArgs.Implicit.Read- System.Console.CmdArgs.Implicit.Local System.Console.CmdArgs.Implicit.Global+ System.Console.CmdArgs.Implicit.Local+ System.Console.CmdArgs.Implicit.Reader+ System.Console.CmdArgs.Implicit.Reform System.Console.CmdArgs.Implicit.Type System.Console.CmdArgs.Implicit.UI executable cmdargs+ default-language: Haskell2010 main-is: Main.hs- if flag(testprog)+ other-extensions: TemplateHaskell+ build-depends:+ base, transformers, filepath, process, template-haskell+ if flag(testprog) && flag(quotation) buildable: True else buildable: False@@ -80,4 +115,5 @@ System.Console.CmdArgs.Test.Implicit.Maker System.Console.CmdArgs.Test.Implicit.Tests System.Console.CmdArgs.Test.Implicit.Util+ System.Console.CmdArgs.Test.SplitJoin System.Console.CmdArgs.Test.Util
− cmdargs.htm
@@ -1,432 +0,0 @@-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN"- "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">-<html>- <head>- <meta http-equiv="Content-Type" content="text/html;charset=utf-8" />- <title>CmdArgs: Easy Command Line Processing</title>- <style type="text/css">-pre, .cmdargs {- border: 2px solid gray;- padding: 1px;- padding-left: 5px;- margin-left: 10px;- background-color: #eee;-}--pre.define {- background-color: #ffb;- border-color: #cc0;-}--body {- font-family: sans-serif;-}--h1, h2, h3 {- font-family: serif;-}--h1 {- color: rgb(23,54,93);- border-bottom: 1px solid rgb(79,129,189);- padding-bottom: 2px;- font-variant: small-caps;- text-align: center;-}--a {- color: rgb(54,95,145);-}--h2 {- color: rgb(54,95,145);-}--h3 {- color: rgb(79,129,189);-}--p.rule {- background-color: #ffb;- padding: 3px;- margin-left: 50px;- margin-right: 50px;-}---.cmdargs {- display: block;- font-family: monospace;-}-.cmdargs td {- padding: 0px;- margin: 0px;-}- </style>- </head>- <body>--<h1>CmdArgs: Easy Command Line Processing</h1>--<p style="text-align:right;margin-bottom:25px;">- by <a href="http://community.haskell.org/~ndm/">Neil Mitchell</a>-</p>--<p>- <a href="http://community.haskell.org/~ndm/cmdargs/">CmdArgs</a> is a library for defining and parsing command lines. The focus of CmdArgs is allowing the concise definition of fully-featured command line argument processors, in a mainly declarative manner (i.e. little coding needed). CmdArgs also supports multiple mode programs, for example as used in <a href="http://darcs.net/">darcs</a> and <a href="http://haskell.org/cabal/">Cabal</a>.-</p><p>- This document explains how to write the "hello world" of command line processors, then how to extend it with features into a complex command line processor. Finally this document gives three samples, which the <tt>cmdargs</tt> program can run. The three samples are:-</p>-<ol>- <li><tt>hlint</tt> - the <a href="http://community.haskell.org/~ndm/hlint/">HLint</a> program.</li>- <li><tt>diffy</tt> - a program to compare the differences between directories.</li>- <li><tt>maker</tt> - a make style program.</li>-</ol>-<p>- For each example you are encouraged to look at it's source (see the <a href="http://community.haskell.org/~ndm/darcs/hlint">darcs repo</a>, or the bottom of this document) and run it (try <tt>cmdargs hlint --help</tt>). The HLint program is fairly standard in terms of it's argument processing, and previously used the <a href="http://haskell.org/ghc/docs/latest/html/libraries/base/System-Console-GetOpt.html">System.Console.GetOpt</a> library. Using GetOpt required 90 lines and a reasonable amount of duplication. Using CmdArgs the code requires 30 lines, and the logic is much simpler.-</p>-<h3>Acknowledgements</h3>-<p>- Thanks to Kevin Quick for substantial patches, and additional code contributions from Sebastian Fischer.-</p>---<h2>Hello World Example</h2>-<p>- The following code defines a complete command line argument processor:-</p>-<pre>-{-# LANGUAGE DeriveDataTypeable #-}-module Sample where-import System.Console.CmdArgs--data Sample = Sample {hello :: String}- deriving (Show, Data, Typeable)--sample = Sample{hello = def}--main = print =<< cmdArgs sample-</pre>-<p>- To use the CmdArgs library there are three steps:-</p>-<ol>- <li>Define a record data type (<tt>Sample</tt>) that contains a field for each argument. This type needs to have instances for <tt>Show</tt>, <tt>Data</tt> and <tt>Typeable</tt>.</li>- <li>Give a value of that type (<tt>sample</tt>) with default values (<tt>def</tt> is a default value of any type, but I could also have written <tt>""</tt>). This value is turned into a command line by calling the <tt>cmdArgs</tt> function.</li>-</ol>-<p>- Now we have a reasonably functional command line argument processor. Some sample interactions are:-</p>-<pre>-$ runhaskell Sample.hs --hello=world-Sample {hello = "world"}--$ runhaskell Sample.hs --version-The sample program--$ runhaskell Sample.hs --help-The sample program--sample [OPTIONS]-- -? --help Display help message- -V --version Print version information- -h --hello=ITEM-</pre>-<p>- CmdArgs uses defaults to automatically infer a command line parser for a value, and provides annotations to override any of the the defaults. CmdArgs automatically supports <tt>--help</tt> and <tt>--version</tt> flags, and optionally supports verbosity flags.-</p>--<h2>Specifying Attributes</h2>-<p>- In order to control the behaviour we can add attributes. For example to add an attribute specifying the help text for the <tt>--hello</tt> argument we can write:-</p>-<pre>-sample = Sample{hello = def &= help "Who to say hello to"}-</pre>-<p>- We can add additional attributes, for example to specify the type of the value expected by hello:-</p>-<pre>-sample = Sample {hello = def &= help "Who to say hello to" &= typ "WORLD"}-</pre>-<p>- Now when running <tt>--help</tt> the final line is:-</p>-<pre>- -h --hello=WORLD Who to say hello to-</pre>-<p>- There are many more attributes, detailed in the <a href="http://hackage.haskell.org/packages/archive/cmdargs/latest/doc/html/System-Console-CmdArgs.html#2">Haddock documentation</a>.-</p>---<h2>Multiple Modes</h2>-<p>- To specify a program with multiple modes, similar to <a href="http://darcs.net/">darcs</a>, we can supply a data type with multiple constructors, for example:-</p>-<pre>-data Sample = Hello {whom :: String}- | Goodbye- deriving (Show, Data, Typeable)--hello = Hello{whom = def}-goodbye = Goodbye--main = print =<< cmdArgs (modes [hello,goodbye])-</pre>-<p>- Compared to the first example, we now have multiple constructors, and a sample value for each constructor is passed to <tt>cmdArgs</tt>. Some sample interactions with this command line are:-</p>-<pre>-$ runhaskell Sample.hs hello --whom=world-Hello {whom = "world"}--$ runhaskell Sample.hs goodbye-Goodbye--$ runhaskell Sample.hs --help-The sample program--sample [OPTIONS]-- Common flags- -? --help Display help message- -V --version Print version information--sample hello [OPTIONS]-- -w --whom=ITEM--sample goodbye [OPTIONS]-</pre>-<p>- As before, the behaviour can be customised using attributes.-</p>--<h2>Larger Examples</h2>--<p>- For each of the following examples we first explain the purpose of the program, then give the source code, and finally the output of <tt>--help=HTML</tt>. The programs are intended to show sample uses of CmdArgs, and are available to experiment with through <tt>cmdargs <i>progname</i></tt>.-</p>--<h3>HLint</h3>--<p>- The <a href="http://community.haskell.org/~ndm/hlint/">HLint</a> program analyses a list of files, using various options to control the analysis. The command line processing is simple, but a few interesting points are:-</p>-<ul>- <li>The <tt>--report</tt> flag can be used to output a report in a standard location, but giving the flag a value changes where the file is output.</li>- <li>The <tt>color</tt> field is assigned two flag aliases, <tt>--colour</tt> and <tt>-c</tt>. Assigning the <tt>-c</tt> short flag explicitly stops either of the CPP fields using it.</li>- <li>The <tt>show_</tt> field would clash with <tt>show</tt> if given the expected name, but CmdArgs automatically strips the trailing underscore.</li>- <li>The <tt>cpp_define</tt> field has an underscore in it's name, which is transformed into a hyphen for the flag name.</li>-</ul>--<!-- BEGIN code hlint -->-<pre>-{-# LANGUAGE DeriveDataTypeable #-}-module HLint where-import System.Console.CmdArgs--data HLint = HLint- {report :: [FilePath]- ,hint :: [FilePath]- ,color :: Bool- ,ignore :: [String]- ,show_ :: Bool- ,extension :: [String]- ,language :: [String]- ,utf8 :: Bool- ,encoding :: String- ,find :: [FilePath]- ,test_ :: Bool- ,datadir :: [FilePath]- ,cpp_define :: [String]- ,cpp_include :: [FilePath]- ,files :: [FilePath]- }- deriving (Data,Typeable,Show,Eq)--hlint = HLint- {report = def &= opt "report.html" &= typFile &= help "Generate a report in HTML"- ,hint = def &= typFile &= help "Hint/ignore file to use"- ,color = def &= name "c" &= name "colour" &= help "Color the output (requires ANSI terminal)"- ,ignore = def &= typ "MESSAGE" &= help "Ignore a particular hint"- ,show_ = def &= help "Show all ignored ideas"- ,extension = def &= typ "EXT" &= help "File extensions to search (defaults to hs and lhs)"- ,language = def &= name "X" &= typ "LANG" &= help "Language extension (Arrows, NoCPP)"- ,utf8 = def &= help "Use UTF-8 text encoding"- ,encoding = def &= typ "ENC" &= help "Choose the text encoding"- ,find = def &= typFile &= help "Find hints in a Haskell file"- ,test_ = def &= help "Run in test mode"- ,datadir = def &= typDir &= help "Override the data directory"- ,cpp_define = def &= typ "NAME[=VALUE]" &= help "CPP #define"- ,cpp_include = def &= typDir &= help "CPP include path"- ,files = def &= args &= typ "FILES/DIRS"- } &=- verbosity &=- help "Suggest improvements to Haskell source code" &=- summary "HLint v0.0.0, (C) Neil Mitchell 2006-2010" &=- details ["Hlint gives hints on how to improve Haskell code",""- ,"To check all Haskell files in 'src' and generate a report type:"," hlint src --report"]--mode = cmdArgsMode hlint-</pre>-<!-- END -->-<!-- BEGIN help hlint -->-<table class='cmdargs'>-<tr><td colspan='3'>HLint v0.0.0, (C) Neil Mitchell 2006-2010</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3'>hlint [OPTIONS] [FILES/DIRS]</td></tr>-<tr><td colspan='3' style='padding-left:1ex;'>Suggest improvements to Haskell source code</td></tr>-<tr><td colspan='3'> </tr>-<tr><td style='padding-left:2ex;'>-?</td><td style='padding-left:1ex;'>--help</td><td style='padding-left:2ex;'>Display help message</td></tr>-<tr><td style='padding-left:2ex;'>-V</td><td style='padding-left:1ex;'>--version</td><td style='padding-left:2ex;'>Print version information</td></tr>-<tr><td style='padding-left:2ex;'>-v</td><td style='padding-left:1ex;'>--verbose</td><td style='padding-left:2ex;'>Loud verbosity</td></tr>-<tr><td style='padding-left:2ex;'>-q</td><td style='padding-left:1ex;'>--quiet</td><td style='padding-left:2ex;'>Quiet verbosity</td></tr>-<tr><td style='padding-left:2ex;'>-r</td><td style='padding-left:1ex;'>--report[=FILE]</td><td style='padding-left:2ex;'>Generate a report in HTML (default=report.html)</td></tr>-<tr><td style='padding-left:2ex;'>-h</td><td style='padding-left:1ex;'>--hint=FILE</td><td style='padding-left:2ex;'>Hint/ignore file to use</td></tr>-<tr><td style='padding-left:2ex;'>-c</td><td style='padding-left:1ex;'>--color --colour</td><td style='padding-left:2ex;'>Color the output (requires ANSI terminal)</td></tr>-<tr><td style='padding-left:2ex;'>-i</td><td style='padding-left:1ex;'>--ignore=MESSAGE</td><td style='padding-left:2ex;'>Ignore a particular hint</td></tr>-<tr><td style='padding-left:2ex;'>-s</td><td style='padding-left:1ex;'>--show</td><td style='padding-left:2ex;'>Show all ignored ideas</td></tr>-<tr><td style='padding-left:2ex;'> <td style='padding-left:1ex;'>--extension=EXT</td><td style='padding-left:2ex;'>File extensions to search (defaults to hs and lhs)</td></tr>-<tr><td style='padding-left:2ex;'>-X</td><td style='padding-left:1ex;'>--language=LANG</td><td style='padding-left:2ex;'>Language extension (Arrows, NoCPP)</td></tr>-<tr><td style='padding-left:2ex;'>-u</td><td style='padding-left:1ex;'>--utf8</td><td style='padding-left:2ex;'>Use UTF-8 text encoding</td></tr>-<tr><td style='padding-left:2ex;'> <td style='padding-left:1ex;'>--encoding=ENC</td><td style='padding-left:2ex;'>Choose the text encoding</td></tr>-<tr><td style='padding-left:2ex;'>-f</td><td style='padding-left:1ex;'>--find=FILE</td><td style='padding-left:2ex;'>Find hints in a Haskell file</td></tr>-<tr><td style='padding-left:2ex;'>-t</td><td style='padding-left:1ex;'>--test</td><td style='padding-left:2ex;'>Run in test mode</td></tr>-<tr><td style='padding-left:2ex;'>-d</td><td style='padding-left:1ex;'>--datadir=DIR</td><td style='padding-left:2ex;'>Override the data directory</td></tr>-<tr><td style='padding-left:2ex;'> <td style='padding-left:1ex;'>--cpp-define=NAME[=VALUE]</td><td style='padding-left:2ex;'>CPP #define</td></tr>-<tr><td style='padding-left:2ex;'> <td style='padding-left:1ex;'>--cpp-include=DIR</td><td style='padding-left:2ex;'>CPP include path</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3' style='padding-left:1ex;'>Hlint gives hints on how to improve Haskell code</td></tr>-<tr><td colspan='3' style='padding-left:1ex;'> </tr>-<tr><td colspan='3' style='padding-left:1ex;'>To check all Haskell files in 'src' and generate a report type:</td></tr>-<tr><td colspan='3' style='padding-left:3ex;'>hlint src --report</td></tr>-</table>-<!-- END -->--<h3>Diffy</h3>--<p>- The Diffy sample is a based on the idea of creating directory listings and comparing them. The tool can operate in two separate modes, <tt>create</tt> or <tt>diff</tt>. This sample is fictional, but the ideas are drawn from a real program. A few notable features:-</p>-<ul>- <li>There are multiple modes of execution, creating and diffing.</li>- <li>The diff mode takes exactly two arguments, the old file and the new file.</li>- <li>Default values are given for the <tt>out</tt> field, which are different in both modes.</li>-</ul>--<!-- BEGIN code diffy -->-<pre>-{-# LANGUAGE DeriveDataTypeable #-}-module Diffy where-import System.Console.CmdArgs--data Diffy = Create {src :: Maybe FilePath, out :: FilePath}- | Diff {old :: FilePath, new :: FilePath, out :: FilePath}- deriving (Data,Typeable,Show,Eq)--outFlags x = x &= help "Output file" &= typFile--create = Create- {src = def &= help "Source directory" &= typDir- ,out = outFlags "ls.txt"- } &= help "Create a fingerprint"--diff = Diff- {old = def &= typ "OLDFILE" &= argPos 0- ,new = def &= typ "NEWFILE" &= argPos 1- ,out = outFlags "diff.txt"- } &= help "Perform a diff"--mode = cmdArgsMode $ modes [create,diff] &= help "Create and compare differences" &= program "diffy" &= summary "Diffy v1.0"-</pre>-<!-- END -->-<!-- BEGIN help diffy -->-<table class='cmdargs'>-<tr><td colspan='3'>Diffy v1.0</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3'>diffy [OPTIONS]</td></tr>-<tr><td colspan='3' style='padding-left:1ex;'>Create and compare differences</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3' style='padding-left:1ex;'>Common flags</td></tr>-<tr><td style='padding-left:2ex;'>-?</td><td style='padding-left:1ex;'>--help</td><td style='padding-left:2ex;'>Display help message</td></tr>-<tr><td style='padding-left:2ex;'>-V</td><td style='padding-left:1ex;'>--version</td><td style='padding-left:2ex;'>Print version information</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3'>diffy create [OPTIONS]</td></tr>-<tr><td colspan='3' style='padding-left:1ex;'>Create a fingerprint</td></tr>-<tr><td colspan='3'> </tr>-<tr><td style='padding-left:2ex;'>-s</td><td style='padding-left:1ex;'>--src=DIR</td><td style='padding-left:2ex;'>Source directory</td></tr>-<tr><td style='padding-left:2ex;'>-o</td><td style='padding-left:1ex;'>--out=FILE</td><td style='padding-left:2ex;'>Output file</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3'>diffy diff [OPTIONS] OLDFILE NEWFILE</td></tr>-<tr><td colspan='3' style='padding-left:1ex;'>Perform a diff</td></tr>-<tr><td colspan='3'> </tr>-<tr><td style='padding-left:2ex;'>-o</td><td style='padding-left:1ex;'>--out=FILE</td><td style='padding-left:2ex;'>Output file</td></tr>-</table>-<!-- END -->--<h3>Maker</h3>--<p>- The Maker sample is based around a build system, where we can either build a project, clean the temporary files, or run a test. Some interesting features are:-</p>-<ul>- <li>The build mode is the default, so <tt>maker</tt> on it's own will be interpretted as a build command.</li>- <li>The build method is an enumeration.</li>- <li>The <tt>threads</tt> field is in two of the constructors, but not all three. It is given the short flag <tt>-j</tt>, rather than the default <tt>-t</tt>.</li>-</ul>---<!-- BEGIN code maker -->-<pre>-{-# LANGUAGE DeriveDataTypeable #-}-module Maker where-import System.Console.CmdArgs--data Method = Debug | Release | Profile- deriving (Data,Typeable,Show,Eq)--data Maker- = Wipe- | Test {threads :: Int, extra :: [String]}- | Build {threads :: Int, method :: Method, files :: [FilePath]}- deriving (Data,Typeable,Show,Eq)--threadsMsg x = x &= help "Number of threads to use" &= name "j" &= typ "NUM"--wipe = Wipe &= help "Clean all build objects"-</pre>-<!-- END -->-<!-- BEGIN help maker -->-<table class='cmdargs'>-<tr><td colspan='3'>Maker v1.0</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3'>maker [OPTIONS] </td></tr>-<tr><td colspan='3' style='padding-left:1ex;'>Build helper program</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3' style='padding-left:1ex;'>Common flags</td></tr>-<tr><td style='padding-left:2ex;'>-?</td><td style='padding-left:1ex;'>--help</td><td style='padding-left:2ex;'>Display help message</td></tr>-<tr><td style='padding-left:2ex;'>-V</td><td style='padding-left:1ex;'>--version</td><td style='padding-left:2ex;'>Print version information</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3'>maker [build] [OPTIONS] [ITEM]</td></tr>-<tr><td colspan='3' style='padding-left:1ex;'>Build the project</td></tr>-<tr><td colspan='3'> </tr>-<tr><td style='padding-left:2ex;'>-j</td><td style='padding-left:1ex;'>--threads=NUM</td><td style='padding-left:2ex;'>Number of threads to use</td></tr>-<tr><td style='padding-left:2ex;'>-r</td><td style='padding-left:1ex;'>--release</td><td style='padding-left:2ex;'>Release build</td></tr>-<tr><td style='padding-left:2ex;'>-d</td><td style='padding-left:1ex;'>--debug</td><td style='padding-left:2ex;'>Debug build</td></tr>-<tr><td style='padding-left:2ex;'>-p</td><td style='padding-left:1ex;'>--profile</td><td style='padding-left:2ex;'>Profile build</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3'>maker wipe [OPTIONS]</td></tr>-<tr><td colspan='3' style='padding-left:1ex;'>Clean all build objects</td></tr>-<tr><td colspan='3'> </tr>-<tr><td colspan='3'>maker test [OPTIONS] [ANY]</td></tr>-<tr><td colspan='3' style='padding-left:1ex;'>Run the test suite</td></tr>-<tr><td colspan='3'> </tr>-<tr><td style='padding-left:2ex;'>-j</td><td style='padding-left:1ex;'>--threads=NUM</td><td style='padding-left:2ex;'>Number of threads to use</td></tr>-</table>-<!-- END -->-- </body>-</html>