cmdargs-0.10.13/ 0000755 0000000 0000000 00000000000 12527643224 011471 5 ustar 00 0000000 0000000 cmdargs-0.10.13/Setup.hs 0000644 0000000 0000000 00000000106 12527643224 013122 0 ustar 00 0000000 0000000 #! /usr/bin/runhaskell
import Distribution.Simple
main = defaultMain
cmdargs-0.10.13/README.md 0000644 0000000 0000000 00000034664 12527643224 012765 0 ustar 00 0000000 0000000 # CmdArgs: Easy Command Line Processing [](https://hackage.haskell.org/package/cmdargs) [](https://travis-ci.org/ndmitchell/cmdargs)
CmdArgs is a Haskell library for defining command line parsers. The two features that make it a better choice than the standard getopt library 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 or Cabal.
A very simple example of a command line processor is:
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:
$ runhaskell Sample.hs --hello=world
Sample {hello = "world"}
$ runhaskell 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 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 (see the darcs repo, or the bottom of this document) 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 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:
{-# 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
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.
Now we have a reasonably functional command line argument processor. Some sample interactions are:
$ 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
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:
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:
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.
Multiple Modes
To specify a program with multiple modes, similar to darcs, we can supply a data type with multiple constructors, for example:
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:
$ 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]
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=HTML. The programs are intended to show sample uses of CmdArgs, and are available to experiment with through cmdargs progname.
HLint
The HLint 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.
{-# 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
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.
{-# 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"
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 interpretted 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.
{-# 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"
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
cmdargs-0.10.13/Main.hs 0000644 0000000 0000000 00000006406 12527643224 012717 0 ustar 00 0000000 0000000
module Main(main) where
import System.Console.CmdArgs.Test.All
import qualified System.Console.CmdArgs.Test.Implicit.Diffy as D
import qualified System.Console.CmdArgs.Test.Implicit.HLint as H
import qualified System.Console.CmdArgs.Test.Implicit.Maker as M
import System.Console.CmdArgs.Implicit(CmdArgs(..))
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Text
import System.Console.CmdArgs.Default
import Control.Monad
import Data.List
import Data.Maybe
import System.IO
data Args = Test
| Generate
| Help HelpFormat TextFormat
| Version
| Demo Demo
args = (modes "cmdargs" (Help def def) "CmdArgs demo program" ms){modeGroupFlags = toGroup flags}
where
flags = [flagHelpFormat $ \a b _ -> Help a b
,flagVersion $ const Version
,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
main = do
x <- processArgs args
let ver = "CmdArgs demo program, (C) Neil Mitchell"
case x of
Version -> putStrLn ver
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
generateManual :: IO ()
generateManual = do
src <- readFile "cmdargs.htm"
() <- length src `seq` return ()
res <- fmap unlines $ f $ lines src
() <- length res `seq` return ()
h <- openBinaryFile "cmdargs.htm" WriteMode
hPutStr h res
hClose h
where
f (x:xs) | ""] ++ zs
f [] = return []
f (x:xs) = fmap (x:) $ f xs
generateChunk :: [String] -> IO [String]
generateChunk ["help",x] = return $ case x of
"hlint" -> f H.mode
"diffy" -> f D.mode
"maker" -> f M.mode
where f = lines . fromJust . cmdArgsHelp . flip processValue ["--help=html"]
generateChunk ["code",x] = do
src <- readFile $ "System/Console/CmdArgs/Test/Implicit/" ++ x ++ ".hs"
return $ [""] ++ recode (lines src) ++ ["
"]
recode :: [String] -> [String]
recode = concatMap f . blanks . takeWhile (/= "-- STOP MANUAL")
where
blanks ("":"":xs) = blanks ("":xs)
blanks [""] = []
blanks [] = []
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]
cmdargs-0.10.13/LICENSE 0000644 0000000 0000000 00000002764 12527643224 012507 0 ustar 00 0000000 0000000 Copyright Neil Mitchell 2009-2015.
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are
met:
* Redistributions of source code must retain the above copyright
notice, this list of conditions and the following disclaimer.
* Redistributions in binary form must reproduce the above
copyright notice, this list of conditions and the following
disclaimer in the documentation and/or other materials provided
with the distribution.
* Neither the name of Neil Mitchell nor the names of other
contributors may be used to endorse or promote products derived
from this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT
LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
cmdargs-0.10.13/cmdargs.cabal 0000644 0000000 0000000 00000007633 12527643224 014106 0 ustar 00 0000000 0000000 cabal-version: >= 1.6
build-type: Simple
name: cmdargs
version: 0.10.13
license: BSD3
license-file: LICENSE
category: Console
author: Neil Mitchell
maintainer: Neil Mitchell
copyright: Neil Mitchell 2009-2015
synopsis: Command line argument processing
description:
This library provides an easy way to define command line parsers. Most users
will want to use the "System.Console.CmdArgs.Implicit" module, whose
documentation contains an example.
.
* "System.Console.CmdArgs.Explicit" provides a way to write command line
parsers for both single mode programs (most programs) and multiple
mode programs (e.g. darcs or cabal). Parsers are defined by constructing
a data structure.
.
* "System.Console.CmdArgs.Implicit" provides a way to concisely define
command line parsers, up to three times shorter than getopt. These parsers
are translated into the Explicit data type.
.
* "System.Console.CmdArgs.GetOpt" provides a wrapper allowing compatiblity
with existing getopt parsers, mapping to the Explicit data type.
.
For a general reference on what command line flags are commonly used,
see .
bug-reports: https://github.com/ndmitchell/cmdargs/issues
homepage: http://community.haskell.org/~ndm/cmdargs/
extra-source-files:
README.md
CHANGES.txt
tested-with: GHC==7.10.1, GHC==7.8.4, GHC==7.6.3, GHC==7.4.2, GHC==7.2.2
source-repository head
type: git
location: https://github.com/ndmitchell/cmdargs.git
flag testprog
default: False
description: Build the test program
flag quotation
default: True
description: Build the Quote module
library
build-depends:
base >= 4.4 && < 5,
filepath,
transformers >= 0.2,
process >= 1.0
if flag(quotation)
build-depends: template-haskell
exposed-modules: System.Console.CmdArgs.Quote
-- See bug #539 for why this magic is required
extensions: TemplateHaskell
exposed-modules:
System.Console.CmdArgs
System.Console.CmdArgs.Annotate
System.Console.CmdArgs.Default
System.Console.CmdArgs.Explicit
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.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
main-is: Main.hs
if flag(quotation)
extensions: TemplateHaskell
if flag(testprog) && flag(quotation)
buildable: True
else
buildable: False
other-modules:
System.Console.CmdArgs.Test.All
System.Console.CmdArgs.Test.Explicit
System.Console.CmdArgs.Test.GetOpt
System.Console.CmdArgs.Test.Implicit
System.Console.CmdArgs.Test.Implicit.Diffy
System.Console.CmdArgs.Test.Implicit.HLint
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-0.10.13/CHANGES.txt 0000644 0000000 0000000 00000010701 12527643224 013301 0 ustar 00 0000000 0000000 Changelog for CmdArgs
0.10.13
#24, support Ratio in some places
0.10.12
GHC 7.2 compatibility
0.10.11
#15, never put [brackets] around optional args in Explicit
0.10.10
#14, fix @ file arguments
0.10.9
#10, fix versionArgs (broken in 0.10.8)
0.10.8
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
#1, fix timestamps in .tar.gz dist file
0.10.6
#625, more documentation about args/argPos
#626, ensure initial lists don't get reversed (fix after #610)
0.10.5
#615, support lists inside a newtype
0.10.4
#610, make sure it is O(n) to append arguments, not O(n^2)
0.10.3
Append list items under an enum
Support &= ignore on enum fields
0.10.2
Relax upper bounds to be GHC 7.7 compatible
0.10.1
#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
Revert to 0.9.6, including modeExpandAt
0.9.7
Revert to 0.9.5, to fix up PVP breakage
0.9.6
#539, hopefully more fixes to compiling in profile mode
#522, add modeExpandAt and noAtExpand annotation
#522, don't @expand after --
0.9.5
Don't specify TH extension unless quotation is true
0.9.4
#539, specify the TH extension in the Cabal file
Allow transformers 0.3.*
Correct copyright in license and cabal file
0.9.3
Add expandArgsAt and support for @ flag file directives
0.9.2
Don't build the test program if quotation is turned off
0.9.1
Improve the documentation for the Explicit module
#433, propagate groupname on modes in the Implicit code
0.9
#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
#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
No changes, just a version bump to allow requiring the GHC fix
0.6.10
Change the annotate module to cope better with GHC's CSE
0.6.9
#422, support newtype value as the underlying type
0.6.8
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
#395, don't put two newlines after --help or --version
0.6.6
#392, support helpArgs [groupname "something"]
0.6.5
Don't fail with ambiguous enum if you exactly match a value
Put errors on stderr
0.6.4
Eliminate the filepath dependence
0.6.3
Switch mtl for transformers
0.6.2
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
Build on GHC 6.10, don't rely on record name disambiguation
0.6
Add ignore annotation for modes and flags
#350, make top-level help appear properly
0.5
#351, name/explicit attributes on mode were broken (regression)
0.4
#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
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
#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.1
Start of changelog
cmdargs-0.10.13/System/ 0000755 0000000 0000000 00000000000 12527643224 012755 5 ustar 00 0000000 0000000 cmdargs-0.10.13/System/Console/ 0000755 0000000 0000000 00000000000 12527643224 014357 5 ustar 00 0000000 0000000 cmdargs-0.10.13/System/Console/CmdArgs.hs 0000644 0000000 0000000 00000000263 12527643224 016234 0 ustar 00 0000000 0000000 -- | This module re-exports the implicit command line parser.
module System.Console.CmdArgs(module System.Console.CmdArgs.Implicit) where
import System.Console.CmdArgs.Implicit
cmdargs-0.10.13/System/Console/CmdArgs/ 0000755 0000000 0000000 00000000000 12527643224 015677 5 ustar 00 0000000 0000000 cmdargs-0.10.13/System/Console/CmdArgs/Verbosity.hs 0000644 0000000 0000000 00000003507 12527643224 020226 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
-- | A module to deal with verbosity, how \'chatty\' a program should be.
-- This module defines the 'Verbosity' data type, along with functions
-- for manipulating a global verbosity value.
module System.Console.CmdArgs.Verbosity(
Verbosity(..), setVerbosity, getVerbosity,
isNormal, isLoud,
whenNormal, whenLoud
) where
import Control.Monad
import Data.Data
import Data.IORef
import System.IO.Unsafe
-- | The verbosity data type
data Verbosity
= Quiet -- ^ Only output essential messages (typically errors)
| Normal -- ^ Output normal messages (typically errors and warnings)
| Loud -- ^ Output lots of messages (typically errors, warnings and status updates)
deriving (Eq,Ord,Bounded,Enum,Show,Read,Data,Typeable)
{-# NOINLINE ref #-}
ref :: IORef Verbosity
ref = unsafePerformIO $ newIORef Normal
-- | Set the global verbosity.
setVerbosity :: Verbosity -> IO ()
setVerbosity = writeIORef ref
-- | Get the global verbosity. Initially @Normal@ before any calls to 'setVerbosity'.
getVerbosity :: IO Verbosity
getVerbosity = readIORef ref
-- | Used to test if warnings should be output to the user.
-- @True@ if the verbosity is set to 'Normal' or 'Loud' (when @--quiet@ is /not/ specified).
isNormal :: IO Bool
isNormal = fmap (>=Normal) getVerbosity
-- | Used to test if status updates should be output to the user.
-- @True@ if the verbosity is set to 'Loud' (when @--verbose@ is specified).
isLoud :: IO Bool
isLoud = fmap (>=Loud) getVerbosity
-- | An action to perform if the verbosity is normal or higher, based on 'isNormal'.
whenNormal :: IO () -> IO ()
whenNormal act = do
b <- isNormal
when b act
-- | An action to perform if the verbosity is loud, based on 'isLoud'.
whenLoud :: IO () -> IO ()
whenLoud act = do
b <- isLoud
when b act
cmdargs-0.10.13/System/Console/CmdArgs/Text.hs 0000644 0000000 0000000 00000013120 12527643224 017154 0 ustar 00 0000000 0000000
-- | A module to represent text with very basic formatting. Values are of
-- type ['Text'] and shown with 'showText'.
--
-- As an example of the formatting:
--
-- > [Line "Cooking for hungry people."
-- > ,Line "Welcome to my cookery recipe program, I sure hope you enjoy using it!"
-- > ,Line ""
-- > ,Cols ["Omlette"," A tasty eggy treat."]
-- > ,Cols [" -m"," --mushrooms"," Some mushrooms, or in fact any other ingredients you have in the cupboards"]
-- > ,Cols [" -e"," --eggs", " But always you need eggs"]
-- > ,Line ""
-- > ,Cols ["Spagetti Bolognaise", " An Italian delight."]
-- > ,Cols [" -s"," --spagetti"," The first word in the name"]
-- > ,Cols [" -b"," --bolognaise"," The second word in the name"]
-- > ,Cols [" -d"," --dolmio"," The magic ingredient!"]
-- > ,Line ""
-- > ,Line " The author of this program explicitly disclaims any liability for poisoning people who get their recipes off the internet."]
--
-- With @putStrLn ('showText' ('Wrap' 50) demo)@ gives:
--
-- > Cooking for hungry people.
-- > Welcome to my cookery recipe program, I sure hope
-- > you enjoy using it!
-- >
-- > Omlette A tasty eggy treat.
-- > -m --mushrooms Some mushrooms, or in fact
-- > any other ingredients you have
-- > in the cupboards
-- > -e --eggs But always you need eggs
-- >
-- > Spagetti Bolognaise An Italian delight.
-- > -s --spagetti The first word in the name
-- > -b --bolognaise The second word in the name
-- > -d --dolmio The magic ingredient!
-- >
-- > The author of this program explicitly
-- > disclaims any liability for poisoning people
-- > who get their recipes off the internet.
module System.Console.CmdArgs.Text(TextFormat(..), defaultWrap, Text(..), showText) where
import Data.Char
import Data.Function
import Data.List
import Data.Maybe
import System.Console.CmdArgs.Default
-- | Wrap with the default width of 80 characters.
defaultWrap :: TextFormat
defaultWrap = Wrap 80
-- | How to output the text.
data TextFormat = HTML -- ^ Display as HTML.
| Wrap Int -- ^ Display as text wrapped at a certain width (see 'defaultWrap').
deriving (Read,Show,Eq,Ord)
instance Default TextFormat where def = defaultWrap
-- | The data type representing some text, typically used as @[Text]@. The formatting
-- is described by:
--
-- * 'Line' values represent a paragraph of text, and may be wrapped depending on the 'TextFormat'.
-- If a 'Line' value is wrapped then all leading space will be treated as an indent.
--
-- * 'Cols' values represent columns of text. Within any @[Text]@ all columns of the same length
-- are grouped in tabs, with the final column being wrapped if necessary. All columns are placed
-- adjacent with no space between them - for this reason most columns will start with a space.
data Text = Line String -- a single line
| Cols [String] -- a single line with columns (always indented by 2 spaces)
instance Show Text where
showList = showString . showText defaultWrap
show x = showText defaultWrap [x]
-- | Show some text using the given formatting.
showText :: TextFormat -> [Text] -> String
showText HTML = showHTML
showText (Wrap x) = showWrap x
---------------------------------------------------------------------
-- TEXT OUTPUT
showWrap :: Int -> [Text] -> String
showWrap width xs = unlines $ concatMap f xs
where
cs :: [(Int,[Int])]
cs = map (\x -> (fst $ head x, map maximum $ transpose $ map snd x)) $
groupBy ((==) `on` fst) $ sortBy (compare `on` fst)
[(length x, map length $ init x) | Cols x <- xs]
pad n x = x ++ replicate (n - length x) ' '
f (Line x) = map (a++) $ wrap1 (width - length a) b
where (a,b) = span isSpace x
f (Cols xs) = concat (zipWith pad ys xs ++ [z1]) : map (replicate n ' '++) zs
where ys = fromJust $ lookup (length xs) cs
n = sum ys + length (takeWhile isSpace $ last xs)
z1:zs = wrap1 (width - n) (last xs)
wrap1 width x = ["" | null res] ++ res
where res = wrap width x
-- | Split the text into strips of no-more than the given width
wrap :: Int -> String -> [String]
wrap width = combine . split
where
split :: String -> [(String,Int)] -- string, amount of space after
split "" = []
split x = (a,length c) : split d
where (a,b) = break isSpace x
(c,d) = span isSpace b
-- combine two adjacent chunks while they are less than width
combine :: [(String,Int)] -> [String]
combine ((a,b):(c,d):xs) | length a + b + length c < width = combine $ (a ++ replicate b ' ' ++ c,d):xs
combine (x:xs) = fst x : combine xs
combine [] = []
---------------------------------------------------------------------
-- HTML OUTPUT
showHTML :: [Text] -> String
showHTML xs = unlines $
[""]
where
cols = 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)
tr x = "" ++ x ++ "
"
td cols x = "" ++ if null b then " " else concatMap esc b ++ ""
where (a,b) = span isSpace x
esc '&' = "&"
esc '>' = ">"
esc '<' = "<"
esc x = [x]
cmdargs-0.10.13/System/Console/CmdArgs/Quote.hs 0000644 0000000 0000000 00000020741 12527643224 017334 0 ustar 00 0000000 0000000 {-# 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)
cmdargs-0.10.13/System/Console/CmdArgs/Implicit.hs 0000644 0000000 0000000 00000022562 12527643224 020014 0 ustar 00 0000000 0000000 {-# LANGUAGE RecordWildCards, PatternGuards #-}
{-|
This module provides simple command line argument processing.
The main function of interest is 'cmdArgs'.
A simple example is:
@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@
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'
/Supported Types/: Each field in the record must be one of the supported
atomic types (@String@, @Int@, @Integer@, @Float@, @Double@, @Bool@, an
enumeration, a tuple of atomic types) or a list (@[]@) or @Maybe@ wrapping
at atomic type.
/Missing Fields/: If a field is shared by multiple modes, it may be omitted
in subsequent modes, and will default to the previous value.
/Purity/: Values created with annotations are not pure - the first
time they are computed they will include the annotations, but subsequently
they will not. If you wish to run the above example in a more robust way:
@sample = 'cmdArgsMode' $ Sample{hello = ... -- as before@
@main = print =<< 'cmdArgsRun' sample@
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(..), -- 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).
module System.Console.CmdArgs.Implicit.UI,
-- ** Impure
(&=), modes, enum,
-- ** Pure
(+=), record, atom, Annotate((:=)), enum_, modes_,
-- * Re-exported for convenience
-- | Provides a few opaque types (for writing type signatures),
-- verbosity control, default values with 'def' and the
-- @Data@/@Typeable@ type classes.
module System.Console.CmdArgs.Verbosity,
module System.Console.CmdArgs.Default,
Ann, Mode,
Data, Typeable
) where
import Data.Data
import Data.Maybe
import Data.Generics.Any
import System.Exit
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((&=))
import System.Console.CmdArgs.Implicit.Type
import System.Console.CmdArgs.Implicit.Local
import System.Console.CmdArgs.Implicit.Global
import System.Console.CmdArgs.Implicit.UI
import System.Console.CmdArgs.Verbosity
import System.Console.CmdArgs.Default
-- | 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_
cmdArgsCapture :: Data a => Capture Ann -> Mode (CmdArgs a)
cmdArgsCapture = remap embed proj . global . local
where embed = fmap fromAny
proj x = (fmap Any x, embed)
-- | Take impurely annotated records and turn them in to a 'Mode' value, that can
-- make use of the "System.Console.CmdArgs.Explicit" functions (i.e. 'process').
--
-- Annotated records are impure, and will only contain annotations on
-- their first use. The result of this function is pure, and can be reused.
cmdArgsMode :: Data a => a -> Mode (CmdArgs a)
cmdArgsMode = cmdArgsCapture . capture
-- | Take purely annotated records and turn them in to a 'Mode' value, that can
-- make use of the "System.Console.CmdArgs.Explicit" functions (i.e. 'process').
cmdArgsMode_ :: Data a => Annotate Ann -> Mode (CmdArgs a)
cmdArgsMode_ = cmdArgsCapture . capture_
-- | Run a Mode structure. This function reads the command line arguments
-- and then performs as follows:
--
-- * If invalid arguments are given, it will display the error message
-- and exit.
--
-- * If @--help@ is given, it will display the help message and exit.
--
-- * If @--version@ is given, it will display the version and exit.
--
-- * In all other circumstances the program will return a value.
--
-- * Additionally, if either @--quiet@ or @--verbose@ is given (see 'verbosity')
-- it will set the verbosity (see 'setVerbosity').
cmdArgsRun :: Mode (CmdArgs a) -> IO a
cmdArgsRun m = cmdArgsApply =<< processArgs m
-- | Perform the necessary actions dictated by a 'CmdArgs' structure.
--
-- * If 'cmdArgsHelp' is @Just@, it will display the help message and exit.
--
-- * If 'cmdArgsVersion' is @Just@, it will display the version and exit.
--
-- * In all other circumstances it will return a value.
--
-- * Additionally, if 'cmdArgsVerbosity' is @Just@ (see 'verbosity')
-- it will set the verbosity (see 'setVerbosity').
cmdArgsApply :: CmdArgs a -> IO a
cmdArgsApply CmdArgs{..}
| 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.
-- If you want one of the modes to be chosen by default, see 'auto'.
--
-- > data Modes = Mode1 | Mode2 | Mode3 deriving Data
-- > cmdArgs $ modes [Mode1,Mode2,Mode3]
modes :: Data val => [val] -> val
modes = many
-- | 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. 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
-- | Add an annotation to a value. Note that if the value is evaluated
-- more than once the annotation will only be available the first time.
{-# INLINE (&=) #-}
(&=) :: Data val => val -> Ann -> val
(&=) = (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_
cmdargs-0.10.13/System/Console/CmdArgs/Helper.hs 0000644 0000000 0000000 00000025704 12527643224 017462 0 ustar 00 0000000 0000000 {-# 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:
--
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
cmdargs-0.10.13/System/Console/CmdArgs/GetOpt.hs 0000644 0000000 0000000 00000006447 12527643224 017450 0 ustar 00 0000000 0000000
-- | This provides a compatiblity wrapper to the @System.Console.GetOpt@ module in @base@.
-- That module is essentially a Haskell port of the GNU @getopt@ library.
--
-- /Changes:/ The changes from @GetOpt@ are listed in the documentation for each function.
module System.Console.CmdArgs.GetOpt(
convert, getOpt, getOpt', usageInfo,
ArgOrder(..), OptDescr(..), ArgDescr(..)
) where
import System.Console.CmdArgs.Explicit
-- | What to do with options following non-options.
--
-- /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
-- | Return a string describing the usage of a command, derived from
-- the header (first argument) and the options described by the
-- second argument.
usageInfo :: String -> [OptDescr a] -> String
usageInfo desc flags = unlines $ desc : drop 2 (lines $ show $ convert "" flags)
-- | Process the command-line, and return the list of values that matched
-- (and those that didn\'t). The arguments are:
--
-- * The order requirements (see 'ArgOrder')
--
-- * The option descriptions (see 'OptDescr')
--
-- * The actual command line arguments (presumably got from
-- 'System.Environment.getArgs').
--
-- 'getOpt' returns a triple consisting of the option arguments, a list
-- of non-options, and a list of error messages.
--
-- /Changes:/ The list of errors will contain at most one entry, and if an
-- error is present then the other two lists will be empty.
getOpt :: ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String])
getOpt _ flags args =
case process (convert "" flags) args of
Left x -> ([],[],[x])
Right (a,b) -> (a,b,[])
-- | /Changes:/ This is exactly the same as 'getOpt', but the 3rd element of the
-- tuple (second last) will be an empty list.
getOpt' :: ArgOrder a -> [OptDescr a] -> [String] -> ([a], [String], [String], [String])
getOpt' x y z = (a,b,[],c)
where (a,b,c) = getOpt x y z
-- | Given a help text and a list of option descriptions, generate a 'Mode'.
convert :: String -> [OptDescr a] -> Mode ([a],[String])
convert help flags = mode "program" ([],[]) help args (map f flags)
where
args = flagArg (\x (a,b) -> Right (a,b++[x])) "ARG"
f (Option short long x help) = case x of
NoArg x -> flagNone names (\(a,b) -> (a++[x],b)) help
ReqArg op x -> flagReq names (\x (a,b) -> Right (a++[op x],b)) x help
OptArg op x -> flagOpt "" names (\x (a,b) -> Right (a++[op $ if null x then Nothing else Just x],b)) x help
where names = map return short ++ long
cmdargs-0.10.13/System/Console/CmdArgs/Explicit.hs 0000644 0000000 0000000 00000020777 12527643224 020031 0 ustar 00 0000000 0000000 {-# LANGUAGE ScopedTypeVariables #-}
{-|
This module constructs command lines. You may either use the helper functions
('flagNone', 'flagOpt', 'mode' etc.) or construct the type directly. These
types are intended to give all the necessary power to the person constructing
a command line parser.
For people constructing simpler command line parsers, the module
"System.Console.CmdArgs.Implicit" may be more appropriate.
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
@
And this can be invoked by:
@
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.
/Modes/: The Explicit module allows multiple mode programs by placing additional modes
in 'modeGroupModes'. Every mode is allowed sub-modes, and thus multiple levels of mode
may be created. Given a mode @x@ with sub-modes @xs@, if the first argument corresponds
to the name of a sub-mode, then that sub-mode will be applied. If not, then the arguments
will be processed by mode @x@. Consequently, if you wish to force the user to explicitly
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
process, processArgs, processValue,
-- * Constructing command lines
module System.Console.CmdArgs.Explicit.Type,
flagHelpSimple, flagHelpFormat, flagVersion, flagNumericVersion, flagsVerbosity,
-- * Displaying 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
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 -> run =<< (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 -> run args
where
run args = case process m args of
Left x -> do hPutStrLn stderr x; exitFailure
Right x -> return x
readMay :: Read a => String -> Maybe a
readMay s = case [x | (x,t) <- reads s, ("","") <- lex t] of
[x] -> Just x
_ -> Nothing
-- | Process a list of flags (usually obtained from @'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. Implemeneted in terms of 'process'. This function
-- does not take account of any environment variables that may be set
-- (see 'processArgs').
processValue :: Mode a -> [String] -> a
processValue m xs = case process m xs of
Left x -> error x
Right x -> x
-- | Create a help flag triggered by @-?@/@--help@.
flagHelpSimple :: (a -> a) -> Flag a
flagHelpSimple f = flagNone ["help","?"] f "Display help message"
-- | Create a help flag triggered by @-?@/@--help@. The user
-- may optionally modify help by specifying the format, such as:
--
-- > --help=all - help for all modes
-- > --help=html - help in HTML format
-- > --help=100 - wrap the text at 100 characters
-- > --help=100,one - full text wrapped at 100 characters
flagHelpFormat :: (HelpFormat -> TextFormat -> a -> a) -> Flag a
flagHelpFormat f = (flagOpt "" ["help","?"] upd "" "Display help message"){flagInfo = FlagOptRare ""}
where
upd s v = case format s of
Left e -> Left e
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)
where
sep = words . map (\x -> if x `elem` ":," then ' ' else toLower x)
f x (a,b) = case x of
"all" -> Right (HelpFormatAll,b)
"one" -> Right (HelpFormatOne,b)
"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 "
-- | 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
-- @-q@/@--quiet@
flagsVerbosity :: (Verbosity -> a -> a) -> [Flag a]
flagsVerbosity f =
[flagNone ["verbose","v"] (f Loud) "Loud verbosity"
,flagNone ["quiet","q"] (f Quiet) "Quiet verbosity"]
cmdargs-0.10.13/System/Console/CmdArgs/Default.hs 0000644 0000000 0000000 00000004525 12527643224 017625 0 ustar 00 0000000 0000000
-- | This module provides default values for many types.
-- 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
-- | Provide a default value, such as @()@, @False@, @0@, @[]@, @Nothing@.
def :: a
instance Default () where def = ()
instance Default Bool where def = False
instance Default Int where def = 0
instance Default Integer where def = 0
instance Default Float where def = 0
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)
instance (Default a1,Default a2,Default a3) => Default (a1,a2,a3) where def = (def,def,def)
instance (Default a1,Default a2,Default a3,Default a4) => Default (a1,a2,a3,a4) where def = (def,def,def,def)
instance (Default a1,Default a2,Default a3,Default a4,Default a5) => Default (a1,a2,a3,a4,a5) where def = (def,def,def,def,def)
instance (Default a1,Default a2,Default a3,Default a4,Default a5,Default a6) => Default (a1,a2,a3,a4,a5,a6) where def = (def,def,def,def,def,def)
instance (Default a1,Default a2,Default a3,Default a4,Default a5,Default a6,Default a7) => Default (a1,a2,a3,a4,a5,a6,a7) where def = (def,def,def,def,def,def,def)
instance (Default a1,Default a2,Default a3,Default a4,Default a5,Default a6,Default a7,Default a8) => Default (a1,a2,a3,a4,a5,a6,a7,a8) where def = (def,def,def,def,def,def,def,def)
instance (Default a1,Default a2,Default a3,Default a4,Default a5,Default a6,Default a7,Default a8,Default a9) => Default (a1,a2,a3,a4,a5,a6,a7,a8,a9) where def = (def,def,def,def,def,def,def,def,def)
instance (Default a1,Default a2,Default a3,Default a4,Default a5,Default a6,Default a7,Default a8,Default a9,Default a10) => Default (a1,a2,a3,a4,a5,a6,a7,a8,a9,a10) where def = (def,def,def,def,def,def,def,def,def,def)
cmdargs-0.10.13/System/Console/CmdArgs/Annotate.hs 0000644 0000000 0000000 00000022163 12527643224 020010 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards, ScopedTypeVariables, ExistentialQuantification, DeriveDataTypeable #-}
-- | This module captures annotations on a value, and builds a 'Capture' value.
-- This module has two ways of writing annotations:
--
-- /Impure/: The impure method of writing annotations is susceptible to over-optimisation by GHC
-- - sometimes @\{\-\# OPTIONS_GHC -fno-cse \#\-\}@ will be required.
--
-- /Pure/: The pure method is more verbose, and lacks some type safety.
--
-- As an example of the two styles:
--
-- > data Foo = Foo {foo :: Int, bar :: Int}
--
-- @ impure = 'capture' $ Foo {foo = 12, bar = 'many' [1 '&=' \"inner\", 2]} '&=' \"top\"@
--
-- @ pure = 'capture_' $ 'record' Foo{} [foo := 12, bar :=+ ['atom' 1 '+=' \"inner\", 'atom' 2]] '+=' \"top\"@
--
-- Both evaluate to:
--
-- > Capture (Ann "top") (Ctor (Foo 12 1) [Value 12, Many [Ann "inner" (Value 1), Value 2]]
module System.Console.CmdArgs.Annotate(
-- * Capture framework
Capture(..), Any(..), fromCapture, defaultMissing,
-- * Impure
capture, many, (&=),
-- * Pure
capture_, many_, (+=), atom, record, Annotate((:=),(:=+))
) where
import Control.Monad
import Control.Monad.Trans.State
import Data.Data(Data,Typeable)
import Data.List
import Data.Maybe
import Data.IORef
import System.IO.Unsafe
import Control.Exception
import Data.Generics.Any
infixl 2 &=, +=
infix 3 :=
-- | The result of capturing some annotations.
data Capture ann
= Many [Capture ann] -- ^ Many values collapsed ('many' or 'many_')
| Ann ann (Capture ann) -- ^ An annotation attached to a value ('&=' or '+=')
| Value Any -- ^ A value (just a value, or 'atom')
| Missing Any -- ^ A missing field (a 'RecConError' exception, or missing from 'record')
| Ctor Any [Capture ann] -- ^ A constructor (a constructor, or 'record')
deriving Show
instance Functor Capture where
fmap f (Many xs) = Many $ map (fmap f) xs
fmap f (Ann a x) = Ann (f a) $ fmap f x
fmap f (Value x) = Value x
fmap f (Missing x) = Missing x
fmap f (Ctor x xs) = Ctor x $ map (fmap f) xs
-- | Return the value inside a capture.
fromCapture :: Capture ann -> Any
fromCapture (Many (x:_)) = fromCapture x
fromCapture (Ann _ x) = fromCapture x
fromCapture (Value x) = x
fromCapture (Missing x) = x
fromCapture (Ctor x _) = x
-- | Remove all Missing values by using any previous instances as default values
defaultMissing :: Capture ann -> Capture ann
defaultMissing x = evalState (f Nothing Nothing x) []
where
f ctor field (Many xs) = fmap Many $ mapM (f ctor field) xs
f ctor field (Ann a x) = fmap (Ann a) $ f ctor field x
f ctor field (Value x) = return $ Value x
f (Just ctor) (Just field) (Missing x) = do
s <- get
return $ head $
[x2 | (ctor2,field2,x2) <- s, typeOf ctor == typeOf ctor2, field == field2] ++
err ("missing value encountered, no field for " ++ field ++ " (of type " ++ show x ++ ")")
f _ _ (Missing x) = err $ "missing value encountered, but not as a field (of type " ++ show x ++ ")"
f _ _ (Ctor x xs) | length (fields x) == length xs = do
ys <- zipWithM (g x) (fields x) xs
return $ Ctor (recompose x $ map fromCapture ys) ys
f _ _ (Ctor x xs) = fmap (Ctor x) $ mapM (f Nothing Nothing) xs
g ctor field x = do
y <- f (Just ctor) (Just field) x
modify ((ctor,field,y):)
return y
err x = error $ "System.Console.CmdArgs.Annotate.defaultMissing, " ++ x
---------------------------------------------------------------------
-- IMPURE BIT
-- test = show $ capture $ many [Just ((66::Int) &= P 1 &= P 2), Nothing &= P 8] &= P 3
{-
Notes On Purity
---------------
There is a risk that things that are unsafe will be inlined. That can generally be
removed by NOININE on everything.
There is also a risk that things get commoned up. For example:
foo = trace "1" 1
bar = trace "1" 1
main = do
evaluate foo
evaluate bar
Will print "1" only once, since foo and bar share the same pattern. However, if
anything in the value is a lambda they are not seen as equal. We exploit this by
defining const_ and id_ as per this module.
Now anything wrapped in id_ looks different from anything else.
-}
{-
The idea is to keep a stack of either continuations, or values
If you encounter 'many' you become a value
If you encounter '&=' you increase the continuation
-}
{-# NOINLINE ref #-}
ref :: IORef [Either (Capture Any -> Capture Any) (Capture Any)]
ref = unsafePerformIO $ newIORef []
push = modifyIORef ref (Left id :)
pop = do x:xs <- readIORef ref; writeIORef ref xs; return x
change f = modifyIORef ref $ \x -> case x of Left g : rest -> f g : rest ; _ -> error "Internal error in Capture"
add f = change $ \x -> Left $ x . f
set x = change $ \f -> Right $ f x
-- | Collapse multiple values in to one.
{-# NOINLINE many #-}
many :: Data val => [val] -> val
many xs = unsafePerformIO $ do
ys <- mapM (force . Any) xs
set $ Many ys
return $ head xs
{-# NOINLINE addAnn #-}
addAnn :: (Data val, Data ann) => val -> ann -> val
addAnn x y = unsafePerformIO $ do
add (Ann $ Any y)
evaluate x
return x
-- | Capture a value. Note that if the value is evaluated
-- more than once the result may be different, i.e.
--
-- > capture x /= capture x
{-# NOINLINE capture #-}
capture :: (Data val, Data ann) => val -> Capture ann
capture x = unsafePerformIO $ fmap (fmap fromAny) $ force $ Any x
force :: Any -> IO (Capture Any)
force x@(Any xx) = do
push
res <- try $ evaluate xx
y <- pop
case y of
_ | Left (_ :: RecConError) <- res -> return $ Missing x
Right r -> return r
Left f | not $ isAlgType x -> return $ f $ Value x
| otherwise -> do
cs <- mapM force $ children x
return $ f $ Ctor x cs
-- | Add an annotation to a value.
--
-- It is recommended that anyone making use of this function redefine
-- it with a more restrictive type signature to control the type of the
-- annotation (the second argument). Any redefinitions of this function
-- should add an INLINE pragma, to reduce the chance of incorrect
-- optimisations.
{-# INLINE (&=) #-}
(&=) :: (Data val, Data ann) => val -> ann -> val
(&=) x y = addAnn (id_ x) (id_ y)
{-# INLINE id_ #-}
id_ :: a -> a
id_ x = case unit of () -> x
where unit = reverse "" `seq` ()
---------------------------------------------------------------------
-- PURE PART
-- | This type represents an annotated value. The type of the underlying value is not specified.
data Annotate ann
= forall c f . (Data c, Data f) => (c -> f) := f -- ^ Construct a field, @fieldname := value@.
| forall c f . (Data c, Data f) => (c -> f) :=+ [Annotate ann] -- ^ Add annotations to a field.
| AAnn ann (Annotate ann)
| 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.
(+=) :: Annotate ann -> ann -> Annotate ann
(+=) = flip AAnn
-- | Collapse many annotated values in to one.
many_ :: [Annotate a] -> Annotate a
many_ = AMany
-- | Lift a pure value to an annotation.
atom :: Data val => val -> Annotate ann
atom = AAtom . Any
-- | Create a constructor/record. The first argument should be
-- the type of field, the second should be a list of fields constructed
-- originally defined by @:=@ or @:=+@.
--
-- 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 ann] -> Annotate ann
record a b = ACtor (Any a) b
-- | Capture the annotations from an annotated value.
capture_ :: Show a => Annotate a -> Capture a
capture_ (AAnn a x) = Ann a (capture_ x)
capture_ (AMany xs) = Many (map capture_ xs)
capture_ (AAtom x) = Value x
capture_ (_ := c) = Value $ Any c
capture_ (_ :=+ c) = Many $ map capture_ c
capture_ (ACtor x xs)
| not $ null rep = error $ "Some fields got repeated under " ++ show x ++ "." ++ ctor x ++ ": " ++ show rep
| otherwise = Ctor x2 xs2
where
x2 = recompose x $ map fromCapture xs2
xs2 = [fromMaybe (Missing c) $ lookup i is | let is = zip inds $ map capture_ xs, (i,c) <- zip [0..] $ children x]
inds = zipWith fromMaybe [0..] $ map (fieldIndex x) xs
rep = inds \\ nub inds
fieldIndex :: Any -> Annotate a -> Maybe Int
fieldIndex ctor (AAnn a x) = fieldIndex ctor x
fieldIndex ctor (f := _) = fieldIndex ctor (f :=+ [])
fieldIndex ctor (f :=+ _) | isJust res = res
| otherwise = error $ "Couldn't resolve field for " ++ show ctor
where c = recompose ctor [Any $ throwInt i `asTypeOf` x | (i,Any x) <- zip [0..] (children ctor)]
res = catchInt $ f $ fromAny c
fieldIndex _ _ = Nothing
data ExceptionInt = ExceptionInt Int deriving (Show, Typeable)
instance Exception ExceptionInt
throwInt :: Int -> a
throwInt i = throw (ExceptionInt i)
{-# NOINLINE catchInt #-}
catchInt :: a -> Maybe Int
catchInt x = unsafePerformIO $ do
y <- try (evaluate x)
return $ case y of
Left (ExceptionInt z) -> Just z
_ -> Nothing
cmdargs-0.10.13/System/Console/CmdArgs/Test/ 0000755 0000000 0000000 00000000000 12527643224 016616 5 ustar 00 0000000 0000000 cmdargs-0.10.13/System/Console/CmdArgs/Test/Util.hs 0000644 0000000 0000000 00000001624 12527643224 020072 0 ustar 00 0000000 0000000 {-# LANGUAGE ExistentialQuantification #-}
module System.Console.CmdArgs.Test.Util where
import System.Console.CmdArgs.Explicit
import Data.Maybe
import Data.Typeable
failure :: String -> [(String,String)] -> IO ()
failure x ys = putStr $ unlines $ "" : "" : "FAILURE" : x : [a ++ ": " ++ b | (a,b) <- ys]
success :: IO ()
success = putChar '.'
-- seq used to obtain better program coverage
hpc = seq
-- Demo - wrap a demo up hiding the real type of it
data Demo = forall a . Typeable a => Demo (a -> IO ()) a
runDemo :: Demo -> IO ()
runDemo (Demo f a) = f a
-- Question: Is it possible to do this without the Typeable constraint?
newDemo :: Typeable a => (a -> IO ()) -> Mode a -> Mode Demo
newDemo act = remap (Demo act) (\(Demo f x) -> (coerce x, Demo f . coerce))
where
coerce :: (Typeable a, Typeable b) => a -> b
coerce = fromMaybe (error "Type issue in CmdArgs.coerce") . cast
cmdargs-0.10.13/System/Console/CmdArgs/Test/SplitJoin.hs 0000644 0000000 0000000 00000021155 12527643224 021071 0 ustar 00 0000000 0000000 {-# 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 $ "runhaskell \"" ++ 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 =
[(,) "" []
,(,) "c" ["c"]
,(,) "b" ["b"]
,(,) "\\" ["\\"]
,(,) "'//" ["'//"]
,(,) "a" ["a"]
,(,) "cda" ["cda"]
,(,) "b'" ["b'"]
,(,) "" []
,(,) " " []
,(,) "/b" ["/b"]
,(,) "\"b/\"d a'b'b" ["b/d","a'b'b"]
,(,) "d'c a\"/\\" ["d'c","a/\\"]
,(,) "d" ["d"]
,(,) "bb' " ["bb'"]
,(,) "b'\\" ["b'\\"]
,(,) "\"\\ac" ["\\ac"]
,(,) "\\'\"abbb\"c/''' \\ c" ["\\'abbbc/'''","\\","c"]
,(,) "/bbdbb a " ["/bbdbb","a"]
,(,) "b\" d" ["b d"]
,(,) "" []
,(,) "\\cc/''\\b\\ccc\\'\\b\\" ["\\cc/''\\b\\ccc\\'\\b\\"]
,(,) "/" ["/"]
,(,) "///\"b\\c/b\"cd//c'\"" ["///b\\c/bcd//c'"]
,(,) "\\\"d\\\\' /d\\\\/bb'a /\\d" ["\"d\\\\'","/d\\\\/bb'a","/\\d"]
,(,) "c/ \\''/c b\\'" ["c/","\\''/c","b\\'"]
,(,) "dd'b\\\\\\' /c'aaa\"" ["dd'b\\\\\\'","/c'aaa"]
,(,) "b'd''\\/ b\\'b'db/'cd " ["b'd''\\/","b\\'b'db/'cd"]
,(,) "a\"ba\\/\\ " ["aba\\/\\ "]
,(,) "b\"'dd'c /b/c\"bbd \"\"\\ad'\"c\\\"" ["b'dd'c /b/cbbd","\\ad'c\""]
,(,) "da 'c\\\\acd/'dbaaa///dccbc a \\" ["da","'c\\\\acd/'dbaaa///dccbc","a","\\"]
,(,) "a'ac \"da\"" ["a'ac","da"]
,(,) "\"'\\\"/\"\"b\\b \"'\"\"ccd'a\"/c /da " ["'\"/\"b\\b","'\"ccd'a/c /da "]
,(,) "d\"\\c\\\\cb c/\"aa' b\"\\/d \"'c c/" ["d\\c\\\\cb c/aa'","b\\/d 'c","c/"]
,(,) "dbc\\/\"\"//c/\"accda" ["dbc\\///c/accda"]
,(,) "aca a'' \\ c b'\\/d\\" ["aca","a''","\\","c","b'\\/d\\"]
,(,) "dc\"bc/a\\ccdd\\\\aad\\c'ab '\\cddcdba" ["dcbc/a\\ccdd\\\\aad\\c'ab '\\cddcdba"]
,(,) " c'\"ba \"b\\dc\"" ["c'ba b\\dc"]
,(,) "a\\acd/a \"'c /'c'" ["a\\acd/a","'c /'c'"]
,(,) " ac ddc/\"\"a/\\bd\\d c'cac\"c\\a/a''c" ["ac","ddc/a/\\bd\\d","c'cacc\\a/a''c"]
,(,) "b/cd\"//bb\"/daaab/ b b \"' d\"a\" 'd b" ["b/cd//bb/daaab/","b","b","' da 'd b"]
,(,) "a\"cc'cd\"\\'ad '\"dcc acb\"\\\\" ["acc'cd\\'ad","'dcc acb\\\\"]
,(,) "/bc/bc'/\"d \"a/\"\\ad aba\\da" ["/bc/bc'/d a/\\ad aba\\da"]
,(,) "b\\a" ["b\\a"]
,(,) "/dc ''c'a\"'/'\\ /'cd\\'d/'db/b\"' cabacaaa\"\"dd" ["/dc","''c'a'/'\\ /'cd\\'d/'db/b'","cabacaaadd"]
,(,) "\"ac\\\"c'/c'b\"b\"b'd\"c\"\"" ["ac\"c'/c'bbb'dc"]
,(,) "/ 'ccc\"d\\dc'\"'\\ b" ["/","'cccd\\dc''\\","b"]
,(,) " '\"/\\cc\\/c '\\\\" ["'/\\cc\\/c '\\\\"]
,(,) "\\ \\' ' /d \"cc\\\\//da\"d'a/a\"ca\\\\\"\\cb c\"d'b 'acb" ["\\","\\'","'","/d","cc\\\\//dad'a/aca\\\\cb","cd'b 'acb"]
,(,) "a\"\"d'\"a\"\\ \\c db'da/d\\c\"a/ aa c/db" ["ad'a\\","\\c","db'da/d\\ca/ aa c/db"]
,(,) " d\\" ["d\\"]
,(,) "d c b'/\\/'\"/'a'aa\"a\"/ad\\/" ["d","c","b'/\\/'/'a'aaa/ad\\/"]
,(,) " a \\' /" ["a","\\'","/"]
,(,) "'/ c" ["'/","c"]
,(,) "acd 'bcab /ba'daa'/ba/\"dcdadbcacb" ["acd","'bcab","/ba'daa'/ba/dcdadbcacb"]
,(,) "a\\\"dd'a c\"a\"\"ac\\" ["a\"dd'a","ca\"ac\\"]
,(,) "\"dba /'bb\\ d ba '/c' \"dd\\' cbcd c /b/\\b///" ["dba /'bb\\ d ba '/c' dd\\'","cbcd","c","/b/\\b///"]
,(,) "a'c/c \"ccb '/d\\abd/bc " ["a'c/c","ccb '/d\\abd/bc "]
,(,) "\\da\"\\//add\\\\ c" ["\\da\\//add\\\\ c"]
,(,) "c/\\\"// a/\"ac\"//''ba\"c/\\bc\\\"d\"bc/d" ["c/\"//","a/ac//''bac/\\bc\"dbc/d"]
,(,) "/d/ a dc'\\ \"" ["/d/","a","dc'\\",""]
,(,) " \"dc//b\\cd/ \\ac\"b\"b\"d\"\"\"dd\"\" ' a\\'/ \"/'/\\a/abd\\ddd" ["dc//b\\cd/ \\acbbd\"dd","'","a\\'/","/'/\\a/abd\\ddd"]
,(,) "\\' ' d\"b bbc" ["\\'","'","db bbc"]
,(,) "'ba\\a'db/bd d\\'b\\ \\/a'da' " ["'ba\\a'db/bd","d\\'b\\","\\/a'da'"]
,(,) "\\b\\cc\"\"d' dd ddcb\"d" ["\\b\\ccd'","dd","ddcbd"]
,(,) "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\\"]
,(,) " b ddbbbbc\"da\\c\"'\\" ["b","ddbbbbcda\\c'\\"]
,(,) "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"]
,(,) "/c\"\" dd'a'/b\\/'\"'/" ["/c","dd'a'/b\\/''/"]
,(,) "/\"'\"\"'cc a a\\dd''\\'b" ["/'\"'cc","a","a\\dd''\\'b"]
,(,) "c\"dcd''aba\" \" /'" ["cdcd''aba"," /'"]
,(,) "'\"/''\\\\d'/ad\\baadabdca\\ /\\'''bd\\/\"'/' aca \\ \\a'\\ cd\"d /bdcd''cac" ["'/''\\\\d'/ad\\baadabdca\\ /\\'''bd\\/'/'","aca","\\","\\a'\\","cdd /bdcd''cac"]
,(,) "\" /\"da" [" /da"]
,(,) "'\"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/\\ "]
,(,) "\\\\d'ad ' ''\"cd/a \"\"\\'\\\"'dc\\" ["\\\\d'ad","'","''cd/a \"\\'\"'dc\\"]
,(,) " ab c'\\a" ["ab","c'\\a"]
,(,) "b" ["b"]
,(,) "''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'"]
,(,) " \"'cb dbddbdd/" ["'cb dbddbdd/"]
,(,) "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/\\"]
,(,) "b\"ddccd\"a\"/ba\"" ["bddccda/ba"]
,(,) " \" 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"]
,(,) "\\caab" ["\\caab"]
,(,) "bb\"'\"/d'bad 'd\\/'\\b//\\\\ \\d''c\"c b\\b/\\" ["bb'/d'bad","'d\\/'\\b//\\\\","\\d''cc b\\b/\\"]
,(,) " c'a\" \\cab\"bd\"dcd\"/cb/\"\"b\"b'\"d" ["c'a \\cabbddcd/cb/bb'd"]
,(,) "\\/ \"c'ca" ["\\/","c'ca"]
,(,) " 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/ "]
,(,) "/\"\\db'd/ ca\"ad b\\\\\"cd/a bbc\\ " ["/\\db'd/ caad","b\\cd/a bbc\\ "]
,(,) "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'"]
,(,) "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"]
,(,) "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\\ "]
,(,) "baa' b'b''\\dab/'c" ["baa'","b'b''\\dab/'c"]
,(,) "cb\\\\ " ["cb\\\\"]
,(,) "/b'a''d\"b\" 'c'b ba\\'b\" bb" ["/b'a''db","'c'b","ba\\'b bb"]
,(,) "b /\"ca\\cbac " ["b","/ca\\cbac "]
,(,) " \"\"/\"bcaa\"\"a' \\/bb \"a\\\"'\"" ["/bcaa\"a'","\\/bb","a\"'"]
,(,) "\"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"]
,(,) "/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"]
,(,) "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'/"]
,(,) "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''"]
]
cmdargs-0.10.13/System/Console/CmdArgs/Test/Implicit.hs 0000644 0000000 0000000 00000001022 12527643224 020717 0 ustar 00 0000000 0000000
module System.Console.CmdArgs.Test.Implicit(test, demo) where
import System.Console.CmdArgs.Test.Implicit.Util
import qualified System.Console.CmdArgs.Test.Implicit.Diffy as Diffy
import qualified System.Console.CmdArgs.Test.Implicit.HLint as HLint
import qualified System.Console.CmdArgs.Test.Implicit.Maker as Maker
import qualified System.Console.CmdArgs.Test.Implicit.Tests as Tests
test = Diffy.test >> HLint.test >> Maker.test >> Tests.test
demo = toDemo Diffy.mode : toDemo HLint.mode : toDemo Maker.mode : Tests.demos
cmdargs-0.10.13/System/Console/CmdArgs/Test/GetOpt.hs 0000644 0000000 0000000 00000003231 12527643224 020353 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
module System.Console.CmdArgs.Test.GetOpt where
import Data.Data
import System.Console.CmdArgs.GetOpt
import qualified System.Console.CmdArgs.Explicit as Explicit
import System.Console.CmdArgs.Test.Util
data Flag = Verbose | Version | Name String | Output String | Arg String deriving (Show,Data,Typeable)
options :: [OptDescr Flag]
options =
[Option ['v'] ["verbose"] (NoArg Verbose) "verbosely list files",
Option ['V','?'] ["version","release"] (NoArg Version) "show version info",
Option ['o'] ["output"] (OptArg out "FILE") "use FILE for dump",
Option ['n'] ["name"] (ReqArg Name "USER") "only dump USER's files"]
out :: Maybe String -> Flag
out Nothing = Output "stdout"
out (Just o) = Output o
tester :: [String] -> (String,String)
tester cmdline = case getOpt Permute options cmdline of
(o,n,[] ) -> let x = "options=" ++ show o ++ " args=" ++ show n in (x,x)
(_,_,errs) -> ("failed", unlines errs ++ usageInfo header options)
where header = "Usage: foobar [OPTION...] files..."
mode = (convert "GetOpt compatibility demo" options){Explicit.modeNames=["getopt"]}
demo = [newDemo print mode]
test = do
tester ["foo","-v"] === "options=[Verbose] args=[\"foo\"]"
tester ["foo","--","-v"] === "options=[] args=[\"foo\",\"-v\"]"
tester ["-?o","--name","bar","--na=baz"] === "options=[Version,Output \"stdout\",Name \"bar\",Name \"baz\"] args=[]"
tester ["--ver","foo"] === "failed"
a === b | fst a == b = success
| otherwise = failure "Mismatch in GetOpt" [("Wanted",b),("Got",fst a)]
cmdargs-0.10.13/System/Console/CmdArgs/Test/Explicit.hs 0000644 0000000 0000000 00000010460 12527643224 020734 0 ustar 00 0000000 0000000
module System.Console.CmdArgs.Test.Explicit(test, demo) where
import System.Console.CmdArgs.Default
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Test.Util
demo = [newDemo act dem]
act xs | ("help","") `elem` xs = print $ helpText [] def dem
| otherwise = print xs
dem :: Mode [(String,String)]
dem = 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
test :: IO ()
test = do
testUnnamedOnly
testFlags
testModes
testUnnamedOnly = do
let m = name "UnnamedOnly" $ mode "" [] "" (flagArg (upd "") "") []
checkFail m ["-f"]
checkFail m ["--test"]
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 "") "")
[flagNone ["test","t"] ("test":) ""
,flagNone ["more","m"] ("more":) ""
,flagReq ["color","colour","bobby"] (upd "color") "" ""
,flagOpt "" ["bob","z"] (upd "bob") "" ""
,flagBool ["x","xxx"] (upb "xxx") ""]
checkFail m ["-q"]
checkGood m ["--test"] ["test"]
checkGood m ["-t"] ["test"]
checkFail m ["-t="]
checkFail m ["--test=value"]
checkFail m ["--bo"]
checkGood m ["--bobb=r"] ["colorr"]
checkGood m ["--bob"] ["bob"]
checkGood m ["--bob=foo"] ["bobfoo"]
checkGood m ["--bob","foo"] ["bob","foo"]
checkGood m ["-zfoo"] ["bobfoo"]
checkGood m ["-z=foo"] ["bobfoo"]
checkGood m ["-z","foo"] ["bob","foo"]
checkGood m ["--mo"] ["more"]
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 "dist" ["dist"] "" (flagArg (upd "") "") [flagNone ["bob"] ("bob":) "", flagReq ["bill"] (upd "bill") "" ""]]
checkGood m [] []
checkFail m ["--bob"]
checkFail m ["tess"]
checkFail m ["test","arg"]
checkGood m ["test","--b"] ["test","bob"]
checkGood m ["t","--bo"] ["test","bob"]
checkGood m ["dist","--bob"] ["dist","bob"]
checkFail m ["dist","--bill"]
checkGood m ["dist","--bill","foo"] ["dist","billfoo"]
---------------------------------------------------------------------
-- UTILITIES
upd pre s x = Right $ (pre++s):x
upb pre s x = (pre ++ show s):x
name x y = ("Explicit " ++ x, y)
checkFail :: (String,Mode [String]) -> [String] -> IO ()
checkFail (n,m) xs = case process m xs of
Right a -> failure "Succeeded when should have failed" [("Name",n),("Args",show xs),("Result",show a)]
Left a -> length (show a) `hpc` success
checkGood :: (String,Mode [String]) -> [String] -> [String] -> IO ()
checkGood (n,m) xs ys = case process m xs of
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
cmdargs-0.10.13/System/Console/CmdArgs/Test/All.hs 0000644 0000000 0000000 00000001146 12527643224 017664 0 ustar 00 0000000 0000000
module System.Console.CmdArgs.Test.All(test,demo,Demo,runDemo) where
import System.Console.CmdArgs.Explicit
import System.Console.CmdArgs.Test.Util
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]
demo = GetOpt.demo ++ Explicit.demo ++ Implicit.demo
cmdargs-0.10.13/System/Console/CmdArgs/Test/Implicit/ 0000755 0000000 0000000 00000000000 12527643224 020370 5 ustar 00 0000000 0000000 cmdargs-0.10.13/System/Console/CmdArgs/Test/Implicit/Util.hs 0000644 0000000 0000000 00000010331 12527643224 021637 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
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
import System.Console.CmdArgs.Test.Util
import Control.Exception
import Data.Char
import Data.List
import Data.Maybe
toDemo :: (Typeable a, Show a) => Mode (CmdArgs a) -> Mode Demo
toDemo = newDemo $ \x -> cmdArgsApply x >>= print
invalid :: Data a => (() -> a) -> IO ()
invalid a = do
res <- try $ evaluate $ length $ show $ cmdArgsMode $ a ()
case res of
Left (ErrorCall _) -> success
Right _ -> failure "Expected exception" []
data Tester a = Tester
{(===) :: [String] -> a -> IO ()
,fails :: [String] -> IO ()
,isHelp :: [String] -> [String] -> IO ()
,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 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 completion
where
failed msg args xs = failure msg $ ("Name","Implicit "++name):("Args",show args):xs
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 = f args $ \x -> case x of
Left x -> success
Right x -> failed "Succeeded 52 should have failed" args [("Result",show x)]
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 $
("Want",show want) : showGot cmdArgsHelp x
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 = 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 = 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)
matchLine :: String -> String -> Bool
matchLine (' ':' ':x) (' ':' ':y) = matchLine (dropWhile isSpace x) (dropWhile isSpace y)
matchLine (x:xs) (y:ys) | x == y = matchLine xs ys
matchLine [] [] = True
matchLine _ _ = False
cmdargs-0.10.13/System/Console/CmdArgs/Test/Implicit/Tests.hs 0000644 0000000 0000000 00000035012 12527643224 022027 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, RecordWildCards, TemplateHaskell, MagicHash #-}
{-# OPTIONS_GHC -fno-warn-missing-fields -fno-warn-unused-binds #-}
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
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], int64 :: Int64}
deriving (Show,Eq,Data,Typeable)
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{..} = testers "Test1" [mode1,mode1_]
[] === def1
["--maybeint=12"] === def1{maybeInt = Just 12}
["--maybeint=12","--maybeint=14"] === def1{maybeInt = Just 14}
fails ["--maybeint"]
fails ["--maybeint=test"]
["--listdouble=1","--listdouble=3","--listdouble=2"] === def1{listDouble=[1,3,2]}
fails ["--maybestr"]
["--maybestr="] === def1{maybeStr=Just ""}
["--maybestr=test"] === def1{maybeStr=Just "test"}
["12.5"] === def1{float=12.5}
["12.5","18"] === def1{float=18}
["--bool"] === def1{bool=True}
["--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"}
-- from bug #230
data Test2 = Cmd1 {bs :: [String]}
| Cmd2 {bar :: Int}
deriving (Show, Eq, Data, Typeable)
mode2 = cmdArgsMode $ modes [Cmd1 [], Cmd2 42]
test2 = do
let Tester{..} = tester "Test2" mode2
fails []
["cmd1","-btest"] === Cmd1 ["test"]
["cmd2","-b14"] === Cmd2 14
-- various argument position
data Test3 = Test3 {pos1_1 :: [Int], pos1_2 :: [String], pos1_rest :: [String]}
deriving (Show, Eq, Data, Typeable)
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{..} = testers "Test3" [mode3,mode3_]
fails []
fails ["a"]
["a","1"] === Test3 [1] ["foo"] ["a"]
["a","1","c"] === Test3 [1] ["c"] ["a"]
["a","1","c","d"] === Test3 [1] ["c"] ["a","d"]
invalid $ \_ -> Test3 def def (def &= help "help" &= args)
-- from bug #222
data Test4 = Test4 {test_4 :: [String]}
deriving (Show, Eq, Data, Typeable)
mode4 = cmdArgsMode $ Test4 (def &= opt "hello" &= args)
test4 = do
let Tester{..} = tester "Test4" mode4
[] === Test4 ["hello"]
["a"] === Test4 ["a"]
["a","b"] === Test4 ["a","b"]
-- from #292, automatic enumerations
data ABC = Abacus | Arbitrary | B | C deriving (Eq,Show,Data,Typeable)
data Test5 = Test5 {choice :: ABC} deriving (Eq,Show,Data,Typeable)
mode5 = cmdArgsMode $ Test5 B
test5 = do
let Tester{..} = tester "Test5" mode5
[] === Test5 B
fails ["--choice=A"]
["--choice=c"] === Test5 C
["--choice=C"] === Test5 C
["--choice=Aba"] === Test5 Abacus
["--choice=abacus"] === Test5 Abacus
["--choice=c","--choice=B"] === Test5 B
-- tuple support
data Test6 = Test6 {val1 :: (Int,Bool), val2 :: [(Int,(String,Double))]} deriving (Eq,Show,Data,Typeable)
val6 = Test6 def def
mode6 = cmdArgsMode val6
test6 = do
let Tester{..} = tester "Test6" mode6
[] === val6
["--val1=1,True"] === val6{val1=(1,True)}
["--val1=84,off"] === val6{val1=(84,False)}
fails ["--val1=84"]
fails ["--val1=84,off,1"]
["--val2=1,2,3","--val2=5,6,7"] === val6{val2=[(1,("2",3)),(5,("6",7))]}
-- from #333, add default fields
data Test7 = Test71 {shared :: Int}
| Test72 {unique :: Int, shared :: Int}
| Test73 {unique :: Int, shared :: Int}
deriving (Eq,Show,Data,Typeable)
mode7 = cmdArgsMode $ modes [Test71{shared = def &= name "rename"}, Test72{unique=def}, Test73{}]
test7 = do
let Tester{..} = tester "Test7" mode7
fails []
["test71","--rename=2"] === Test71 2
["test72","--rename=2"] === Test72 0 2
["test72","--unique=2"] === Test72 2 0
["test73","--rename=2"] === Test73 0 2
["test73","--unique=2"] === Test73 2 0
-- from #252, grouping
data Test8 = Test8 {test8a :: Int, test8b :: Int, test8c :: Int}
| Test81
| Test82
deriving (Eq,Show,Data,Typeable)
mode8 = cmdArgsMode $ modes [Test8 1 (2 &= groupname "More flags") 3 &= groupname "Mode1", Test81, Test82 &= groupname "Mode2"]
mode8_ = cmdArgsMode_ $ modes_ [record Test8{} [atom (1::Int), atom (2::Int) += groupname "More flags", atom (3::Int)] += groupname "Mode1"
,record Test81{} []
,record Test82{} [] += groupname "Mode2"]
test8 = do
let Tester{..} = testers "Test8" [mode8,mode8_]
isHelp ["-?"] ["Flags:"," --test8a=INT","More flags:"," --test8b=INT"]
fails []
["test8","--test8a=18"] === Test8 18 2 3
-- bug from Sebastian Fischer, enums with multiple fields
data XYZ = X | Y | Z deriving (Eq,Show,Data,Typeable)
data Test9 = Test91 {foo :: XYZ}
| Test92 {foo :: XYZ}
deriving (Eq,Show,Data,Typeable)
mode9 = cmdArgsMode $ modes [Test91 {foo = enum [X &= help "pick X (default)", Y &= help "pick Y"]} &= auto, Test92{}]
mode9_ = cmdArgsMode_ $ modes_ [record Test91{} [enum_ foo [atom X += help "pick X (default)", atom Y += help "pick Y"]] += auto, record Test92{} []]
test9 = do
let Tester{..} = testers "Test9" [mode9,mode9_]
[] === Test91 X
["test91","-x"] === Test91 X
["test91","-y"] === Test91 Y
fails ["test91","-z"]
["test92","-x"] === Test92 X
["test92","-y"] === Test92 Y
["test92"] === Test92 X
invalid $ \_ -> modes [Test91 {foo = enum [X &= help "pick X (default)"] &= opt "X"}]
-- share common fields in the help message
data Test10 = Test101 {food :: Int}
| Test102 {food :: Int, bard :: Int}
deriving (Eq,Show,Data,Typeable)
mode10 = cmdArgsMode $ modes [Test101 def, Test102 def def]
test10 = do
let Tester{..} = tester "Test10" mode10
isHelp ["-?=one"] [" -f --food=INT"]
isHelpNot ["-?=one"] [" -b --bard=INT"]
-- test for GHC over-optimising
data Test11 = Test11A {test111 :: String}
| Test11B {test111 :: String}
deriving (Eq,Show,Data,Typeable)
test11A = Test11A { test111 = def &= argPos 0 }
test11B = Test11B { test111 = def &= argPos 0 }
mode11 = cmdArgsMode $ modes [test11A, test11B]
mode11_ = cmdArgsMode_ $ modes_
[record Test11A{} [test111 := def += argPos 0]
,record Test11B{} [test111 := def += argPos 0]]
test11 = do
let Tester{..} = testers "Test11" [mode11,mode11_]
fails []
["test11a","test"] === Test11A "test"
["test11b","test"] === Test11B "test"
-- #351, check you can add name annotations to modes
data Test12 = Test12A | Test12B deriving (Eq,Show,Data,Typeable)
mode12 = cmdArgsMode $ modes [Test12A &= name "check", Test12B]
mode12_ = cmdArgsMode $ modes [Test12A &= name "check" &= explicit, Test12B]
test12 = do
let Tester{..} = tester "Test12" mode12
fails []
["test12a"] === Test12A
["check"] === Test12A
["test12b"] === Test12B
fails ["t"]
let Tester{..} = tester "Test12" mode12_
fails []
fails ["test12a"]
["check"] === Test12A
["test12b"] === Test12B
["t"] === Test12B
-- 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
fails ["test13b"]
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"] &= 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"] &=# 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 ++ ")"}
cmdargs-0.10.13/System/Console/CmdArgs/Test/Implicit/Maker.hs 0000644 0000000 0000000 00000006333 12527643224 021770 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
{-# OPTIONS_GHC -fno-cse -fno-warn-unused-binds -fno-warn-missing-fields #-}
module System.Console.CmdArgs.Test.Implicit.Maker where
import System.Console.CmdArgs
import System.Console.CmdArgs.Test.Implicit.Util
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"
-- 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"
wipe = record Wipe{} [] += help "Clean all build objects"
test_ = record Test{}
[threads_
,extra := def += typ "ANY" += args
] += help "Run the test suite"
build = record Build{}
[threads_
,enum_ method
[atom Release += help "Release build"
,atom Debug += help "Debug build"
,atom Profile += help "Profile build"]
,files := def += args
] += help "Build the project" += auto
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]"]
isHelp ["build","-?=one"] ["maker [build] [OPTIONS] [ITEM]"]
isHelp ["-?=one"] [" Build helper program"]
["build","foo","--profile"] === build{files=["foo"],method=Profile}
["foo","--profile"] === build{files=["foo"],method=Profile}
["foo","--profile","--release"] === build{files=["foo"],method=Release}
["-d"] === build{method=Debug}
["build","-j3"] === build{threads=3}
["build","-j=3"] === build{threads=3}
fails ["build","-jN"]
fails ["build","-t1"]
["wipe"] === wipe
["test"] === test_
["test","foo"] === test_{extra=["foo"]}
["test","foo","-j3"] === test_{extra=["foo"],threads=3}
fails ["test","foo","-baz","-j3","--what=1"]
["test","foo","--","-baz","-j3","--what=1"] === test_{extra=["foo","-baz","-j3","--what=1"]}
["test","--","foo","-baz","-j3","--what=1"] === test_{extra=["foo","-baz","-j3","--what=1"]}
["--"] === build
["test","--"] === test_
["test","-j3","--","foo","-baz","-j3","--what=1"] === test_{extra=["foo","-baz","-j3","--what=1"],threads=3}
["test","-"] === test_{extra=["-"]}
["build","-"] === build{files=["-"]}
cmdargs-0.10.13/System/Console/CmdArgs/Test/Implicit/HLint.hs 0000644 0000000 0000000 00000006131 12527643224 021743 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable, RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-unused-binds #-}
module System.Console.CmdArgs.Test.Implicit.HLint where
import System.Console.CmdArgs
import System.Console.CmdArgs.Test.Implicit.Util
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 "FILE/DIR"
} &=
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
-- STOP MANUAL
test = do
let Tester{..} = tester "HLint" mode
[] === hlint
fails ["-ch"]
isVerbosity ["--color","--quiet"] Quiet
isVerbosity ["--color","--verbose"] Loud
isVerbosity ["--color","--quiet","--verbose"] Loud
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}
["-c=off"] === hlint
["-ct"] === hlint{color=True,test_=True}
["--colour","--test"] === hlint{color=True,test_=True}
["-thfoo"] === hlint{test_=True,hint=["foo"]}
["-cr"] === hlint{color=True,report=["report.html"]}
["--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"]
cmdargs-0.10.13/System/Console/CmdArgs/Test/Implicit/Diffy.hs 0000644 0000000 0000000 00000005172 12527643224 021772 0 ustar 00 0000000 0000000 {-# 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}
| 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"
$(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{..} = testers "Diffy" [mode,mode_]
fails []
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"]
fails ["create","--verbose"]
isVerbosity ["create"] Normal
["create","--src","x"] === create{src=Just "x"}
["create","--src","x","--src","y"] === create{src=Just "y"}
fails ["diff","--src","x"]
fails ["create","foo"]
["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) []
cmdargs-0.10.13/System/Console/CmdArgs/Implicit/ 0000755 0000000 0000000 00000000000 12527643224 017451 5 ustar 00 0000000 0000000 cmdargs-0.10.13/System/Console/CmdArgs/Implicit/UI.hs 0000644 0000000 0000000 00000013566 12527643224 020335 0 ustar 00 0000000 0000000 {-|
This module describes the attributes that can be specified on flags and modes.
Many attributes have examples specified on the following data type:
> data Sample = Sample {hello :: String}
-}
module System.Console.CmdArgs.Implicit.UI where
import System.Console.CmdArgs.Implicit.Ann
import Data.Typeable
-- | 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
_ -> show x
-- | Flag: \"For this flag, users need to give something of type ...\"
--
-- The the type of a flag's value, usually upper case. Only used
-- for the help message. Commonly the type will be @FILE@ ('typFile')
-- or @DIR@ ('typDir').
--
-- > {hello = def &= typ "MESSAGE"}
-- > -h --hello=MESSAGE
typ :: String -> Ann
typ = FlagType
-- | Flag: \"Users must give a file for this flag's value.\"
--
-- Alias for @'typ' "FILE"@.
typFile :: Ann
typFile = typ "FILE"
-- | Flag: \"Users must give a directory for this flag's value.\"
--
-- Alias for @'typ' "DIR"@.
typDir :: Ann
typDir = typ "DIR"
-- | Flag/Mode: \"The help message is ...\"
--
-- Descriptive text used in the help output.
--
-- > {hello = def &= help "Help message"}
-- > -h --hello=VALUE Help message
help :: String -> Ann
help = Help
{-
-- | Flag: Specify group membership for this flag
--
-- > {str = def &= group "Repository Management"
-- > ---- Repository Management ----
-- > -s --str=VALUE
group :: String -> Ann
group = FldGroup
-}
-- | Flag: \"Use this flag name for this field.\"
--
-- Add flags which trigger this option.
--
-- > {hello = def &= name "foo"}
-- > -h --hello --foo=VALUE
name :: String -> Ann
name = Name
-- | Flag: \"Put non-flag arguments here.\"
--
-- All argument flags not captured by 'argPos' are returned by 'args'.
--
-- > {hello = def &= args}
args :: Ann
args = FlagArgs
-- | Flag: \"Put the nth non-flag argument here.\"
--
-- This field should be used to store a particular argument position
-- (0-based).
--
-- > {hello = def &= argPos 0}
argPos :: Int -> Ann
argPos = FlagArgPos
-- | Flag\/Mode: \"Give these flags/modes a group name in the help output.\"
--
-- This mode will be used for all following modes/flags, until the
-- next @groupname@.
--
-- > {hello = def &= groupname "Welcomes"}
-- > Welcomes
-- > -h --hello=VALUE
groupname :: String -> Ann
groupname = GroupName
-- | Mode: \"A longer description of this mode is ...\"
--
-- Suffix to be added to the help message.
--
-- > Sample{..} &= details ["More details on the website www.example.org"]
details :: [String] -> Ann
details = ModeHelpSuffix
-- | 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@. 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
summary = ProgSummary
-- | Mode: \"If the user doesn't give a mode, use this one.\"
--
-- This mode is the default. If no mode is specified and a mode has this
-- attribute then that mode is selected, otherwise an error is raised.
--
-- > modes [Mode1{..}, Mode2{..} &= auto, Mode3{..}]
auto :: Ann
auto = ModeDefault
-- | Modes: \"My program executable is named ...\"
--
-- This is the name of the program executable. Only used in the help message.
-- Defaults to the type of the mode.
--
-- > Sample{..} &= program "sample"
program :: String -> Ann
program = ProgProgram
-- | Flag: \"Don't guess any names for this field.\"
--
-- A field should not have any flag names guessed for it.
-- All flag names must be specified by 'flag'.
--
-- > {hello = def &= explicit &= name "foo"}
-- > --foo=VALUE
explicit :: Ann
explicit = Explicit
-- | Flag/Mode: \"Ignore this field, don't let the user set it.\"
--
-- A mode or field is not dealt with by CmdArgs.
--
-- > {hello = def, extra = def &= ignore}
-- > --hello=VALUE
ignore :: Ann
ignore = Ignore
-- | Modes: \"My program needs verbosity flags.\"
--
-- 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
cmdargs-0.10.13/System/Console/CmdArgs/Implicit/Type.hs 0000644 0000000 0000000 00000003562 12527643224 020734 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
-- | The underlying CmdArgs type.
module System.Console.CmdArgs.Implicit.Type(
-- cmdArgs_privateArgsSeen is exported, otherwise Haddock
-- gets confused when using RecordWildCards
CmdArgs(..), cmdArgsHasValue, embed, reembed,
CmdArgsPrivate, incArgsSeen, getArgsSeen
) where
import System.Console.CmdArgs.Verbosity
import Data.Data
import Data.Maybe
-- | A structure to store the additional data relating to @--help@,
-- @--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, 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,Eq,Ord,Data,Typeable)
cmdArgsHasValue :: CmdArgs a -> Bool
cmdArgsHasValue x = isNothing (cmdArgsHelp x) && isNothing (cmdArgsVersion x)
instance Functor CmdArgs where
fmap f x = x{cmdArgsValue = f $ cmdArgsValue x}
embed :: a -> CmdArgs a
embed x = CmdArgs x Nothing Nothing Nothing (CmdArgsPrivate 0)
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"
cmdargs-0.10.13/System/Console/CmdArgs/Implicit/Reform.hs 0000644 0000000 0000000 00000002257 12527643224 021245 0 ustar 00 0000000 0000000 {-# 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
-}
cmdargs-0.10.13/System/Console/CmdArgs/Implicit/Reader.hs 0000644 0000000 0000000 00000007754 12527643224 021224 0 ustar 00 0000000 0000000 {-# 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, expected one of: " ++ unwords (map fst xs)
| Just (_,x) <- find ((==) s . fst) ys = Right x
| length ys > 1 = Left $ "Ambiguous read, 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)
cmdargs-0.10.13/System/Console/CmdArgs/Implicit/Local.hs 0000644 0000000 0000000 00000021011 12527643224 021032 0 ustar 00 0000000 0000000 {-# LANGUAGE PatternGuards #-}
{-# OPTIONS_GHC -fno-warn-overlapping-patterns #-}
-- | This module takes the result of Capture, and deals with all the local
-- constraints.
module System.Console.CmdArgs.Implicit.Local(
local, err,
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.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]
,progProgram :: String
,progHelp :: String -- only for multiple mode programs
,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 (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)
,modeDefault :: Bool
,modeGroup :: Maybe String
,modeExplicit :: Bool
} deriving Show
instance Default Mode_ where
def = Mode_ [] (modeEmpty $ error "Mode_ undefined") def def def
data Flag_
= Flag_
{flagField :: String
,flagFlag :: Flag (CmdArgs Any)
,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_ "" (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
withMode x f = x{modeMode = f $ modeMode x}
withFlagArg x f = x{flagArg_ = f $ flagArg_ x}
withFlagFlag x f = x{flagFlag = f $ flagFlag x}
err x y = error $ "System.Console.CmdArgs.Implicit, unexpected " ++ x ++ ": " ++ y
errFlag x y = err ("flag (" ++ x ++ ")") y
local :: Capture Ann -> Prog_
local = prog_ . defaultMissing
---------------------------------------------------------------------
-- CAPTURE THE STRUCTURE
prog_ :: Capture Ann -> Prog_
prog_ (Ann a b) = progAnn a $ prog_ b
prog_ (Many xs) = def{progModes=concatMap mode_ xs, progProgram=prog}
where prog = map toLower $ typeShell $ fromCapture $ head xs
prog_ x@Ctor{} = prog_ $ Many [x]
prog_ x = err "program" $ show x
mode_ :: Capture Ann -> [Mode_]
mode_ (Ann Ignore _) = []
mode_ (Ann a b) = map (modeAnn a) $ mode_ b
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) = 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) = concatMap (enum_ name) xs
flag_ name x = errFlag name $ show 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
-- Fixup (ends up in modeCheck) and the flag itself
value_ :: String -> Any -> (Fixup, Flag Any)
value_ name x
| isNothing mty = errFlag name $ show x
| 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) $ readerRead ty (getField name x) s
in (fixup, flagReq [] upd (readerHelp ty) "")
where
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 $ lines a}
progAnn (ProgProgram a) x = x{progProgram=a}
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}
modeAnn ModeDefault x = x{modeDefault=True}
modeAnn (GroupName a) x = x{modeGroup=Just a}
modeAnn Explicit x = x{modeExplicit=True}
modeAnn (Name a) x = withMode x $ \x -> x{modeNames=a:modeNames x}
modeAnn a x = err "mode" $ show a
flagAnn :: Ann -> Flag_ -> Flag_
flagAnn (FlagType a) x@Arg_{} = withFlagArg x $ \x -> x{argType=a}
flagAnn (FlagType a) x@Flag_{} = withFlagFlag x $ \x -> x{flagType=a}
flagAnn (Help a) x@Flag_{} = withFlagFlag x $ \x -> x{flagHelp=a}
flagAnn (FlagArgPos a) x = toArg x $ Just a
flagAnn FlagArgs x = toArg x Nothing
flagAnn Explicit x@Flag_{} = x{flagExplicit=True}
flagAnn (FlagOptional a) x@Flag_{flagEnum=Nothing,flagFlag=Flag{flagInfo=FlagReq}} = withFlagFlag x $ \x -> x{flagInfo=FlagOpt a}
flagAnn (FlagOptional a) x@Arg_{} = x{flagArgOpt=Just a}
flagAnn (Name a) x@Flag_{} = withFlagFlag x $ \x -> x{flagNames = a : flagNames x}
flagAnn (GroupName a) x@Flag_{} = x{flagGroup=Just a}
flagAnn a x = errFlag (head $ words $ show x) $ show a
toArg :: Flag_ -> Maybe Int -> Flag_
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) (isNothing y)) pos y fix
where
opt FlagReq = Just Nothing
opt (FlagOpt x) = Just (Just x)
opt (FlagOptRare x) = Just Nothing
opt _ = Nothing
toArg a _ = errFlag "args/argPos" $ show a
cmdargs-0.10.13/System/Console/CmdArgs/Implicit/Global.hs 0000644 0000000 0000000 00000024350 12527643224 021211 0 ustar 00 0000000 0000000 {-# 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
import Data.Generics.Any
import Data.List
import Data.Maybe
global :: Prog_ -> Mode (CmdArgs Any)
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 = (snd $ head ms){modeNames=[progProgram x]}
| length auto > 1 = err "prog" "Multiple automatic modes"
| otherwise = (head $ map zeroMode auto ++ map (emptyMode . snd) ms)
{modeNames=[progProgram x], modeGroupModes=grouped, modeHelp=progHelp x}
where
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=[]}
-- | A mode whose help hides all it's contents
zeroMode :: Mode (CmdArgs Any) -> Mode (CmdArgs Any)
zeroMode x = x
{modeGroupFlags = groupUncommonHide $ modeGroupFlags 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
pick x = map flagFlag $ filter ((==) x . flagGroup) xs
groups = nub $ mapMaybe flagGroup xs
collapseArgs :: [Flag_] -> Mode (CmdArgs Any) -> Mode (CmdArgs Any)
collapseArgs [] x = x
collapseArgs xs x = x{modeCheck=chk, modeArgs = ([], Just $ flagArg upd hlp)}
where
argUpd = argValue . flagArg_
(ord,rep) = orderArgs xs
mn = length $ dropWhile (isJust . flagArgOpt) $ reverse ord
chk v | not $ cmdArgsHasValue v = Right v
| n < mn = Left $ "Requires at least " ++ show mn ++ " arguments, got " ++ show n
| otherwise = foldl f (addOptArgs n v) (drop n ord)
where n = getArgsSeen v
f (Right v) arg = argUpd arg (fromJust $ flagArgOpt arg) v
f x _ = x
-- if we have repeating args which is also opt, translate that here
addOptArgs n v
| Just x <- rep, Just o <- flagArgOpt x, Just n <= findIndex (isNothing . flagArgPos) (ord ++ [x]) = argUpd x o v
| otherwise = Right v
hlp = unwords $ a ++ map (\x -> "["++x++"]") b
where (a,b) = splitAt mn $ map (argType . flagArg_) $ ord ++ maybeToList rep
upd s v | n < length ord = argUpd (ord !! n) s v2
| Just x <- rep = argUpd x s v2
| otherwise = Left $ "expected at most " ++ show (length ord)
where n = getArgsSeen v
v2 = incArgsSeen v
-- return the arguments in order, plus those at the end
orderArgs :: [Flag_] -> ([Flag_], Maybe Flag_)
orderArgs args = (f 0 ord, listToMaybe rep)
where
(rep,ord) = span (isNothing . flagArgPos) $ sortBy (compare `on` flagArgPos) args
f i [] = []
f i (x:xs) = case fromJust (flagArgPos x) `compare` i of
LT -> f i xs
EQ -> x : f (i+1) xs
GT -> take 1 rep ++ f (i+1) (x:xs)
---------------------------------------------------------------------
-- DEAL WITH GROUPS
assignGroups :: Prog_ -> Prog_
assignGroups p = assignCommon $ p{progModes = map (\m -> m{modeFlags_ = f Nothing $ modeFlags_ m}) $ progModes p}
where
f grp [] = []
f grp (x@Flag_{}:xs) = x{flagGroup=grp2} : f grp2 xs
where grp2 = flagGroup x `mplus` grp
f grp (x:xs) = x : f grp xs
assignCommon :: Prog_ -> Prog_
assignCommon p =
p{progModes = [m{modeFlags_ =
[if isFlag_ f && show (flagFlag f) `elem` com then f{flagGroup = Just commonGroup} else f | f <- modeFlags_ m]}
| m <- progModes p]}
where
com = map head $ filter ((== length (progModes p)) . length) $ group $ sort
[show $ flagFlag f | m <- progModes p, f@Flag_{flagGroup=Nothing} <- modeFlags_ m]
commonGroup = "Common flags"
groupSplitCommon :: Group a -> ([a], Group a)
groupSplitCommon (Group unnamed hidden named) = (concatMap snd com, Group unnamed hidden uni)
where (com,uni) = partition ((==) commonGroup . fst) named
groupCommonHide x = let (a,b) = groupSplitCommon x in b{groupHidden = groupHidden b ++ a}
groupUncommonHide x = let (a,b) = groupSplitCommon x in Group [] (fromGroup b) [(commonGroup,a) | not $ null a]
groupUncommonDelete x = let a = fst $ groupSplitCommon x in Group [] [] [(commonGroup,a) | not $ null a]
---------------------------------------------------------------------
-- ADD EXTRA PIECES
extraFlags :: Prog_ -> Prog_
extraFlags p = p{progModes = map f $ progModes p}
where f m = m{modeFlags_ = modeFlags_ m ++ flags}
grp = if length (progModes p) > 1 then Just commonGroup else Nothing
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 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 :: 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
assignNames :: Prog_ -> Prog_
assignNames x = x{progModes = map f $ namesOn fromMode toMode $ progModes x}
where
fromMode x = Names (modeNames $ modeMode x) [asName $ ctor $ cmdArgsValue $ modeValue $ modeMode x | not $ modeExplicit x]
toMode xs x = x{modeMode = (modeMode x){modeNames=["["++head xs++"]" | modeDefault x] ++ xs}}
fromFlagLong x = Names (flagNames $ flagFlag x) [asName $ fromMaybe (flagField x) (flagEnum x) | not $ flagExplicit x]
fromFlagShort x = Names ns $ nub [take 1 s | not $ flagExplicit x, all ((/=) 1 . length) ns, s <- ns]
where ns = flagNames $ flagFlag x
toFlag xs x = x{flagFlag = (flagFlag x){flagNames=xs}}
f x = x{modeFlags_ = rest ++ namesOn fromFlagShort toFlag (namesOn fromFlagLong toFlag flgs)}
where (flgs,rest) = partition isFlag_ $ modeFlags_ x
isFlag_ Flag_{} = True
isFlag_ _ = False
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]}
-- error out if any name is by multiple have's, or one item would get no names
names :: [Names] -> [[String]]
names xs | not $ null bad = err "repeated names" $ unwords bad
where bad = duplicates $ concatMap have xs
names xs | any null res = err "no available name" "?"
| otherwise = res
where
bad = concatMap have xs ++ duplicates (concatMap want xs)
res = map (\x -> have x ++ (want x \\ bad)) xs
duplicates :: Eq a => [a] -> [a]
duplicates xs = nub $ xs \\ nub xs
namesOn :: (a -> Names) -> ([String] -> a -> a) -> [a] -> [a]
namesOn f g xs = zipWith g (names $ map f xs) xs
cmdargs-0.10.13/System/Console/CmdArgs/Implicit/Ann.hs 0000644 0000000 0000000 00000001167 12527643224 020526 0 ustar 00 0000000 0000000 {-# LANGUAGE DeriveDataTypeable #-}
module System.Console.CmdArgs.Implicit.Ann where
import Data.Data
-- | The general type of annotations that can be associated with a value.
data Ann
= Help String
| Name String
| Explicit
| Ignore
| GroupName String
| FlagOptional String
| FlagArgs
| FlagArgPos Int
| FlagType String
| ModeDefault
| ModeHelpSuffix [String]
| ProgSummary String
| ProgProgram String
| ProgVerbosity
| ProgHelpArg [Ann]
| ProgVersionArg [Ann]
| ProgVerbosityArgs [Ann] [Ann]
| ProgNoAtExpand
deriving (Eq,Ord,Show,Data,Typeable)
cmdargs-0.10.13/System/Console/CmdArgs/Explicit/ 0000755 0000000 0000000 00000000000 12527643224 017460 5 ustar 00 0000000 0000000 cmdargs-0.10.13/System/Console/CmdArgs/Explicit/Type.hs 0000644 0000000 0000000 00000023734 12527643224 020746 0 ustar 00 0000000 0000000 {-# LANGUAGE CPP #-}
module System.Console.CmdArgs.Explicit.Type where
import Control.Arrow
import Control.Monad
import Data.Char
import Data.List
import Data.Maybe
#if __GLASGOW_HASKELL__ < 709
import Data.Monoid
#endif
-- | A name, either the name of a flag (@--/foo/@) or the name of a mode.
type Name = String
-- | A help message that goes with either a flag or a mode.
type Help = String
-- | The type of a flag, i.e. @--foo=/TYPE/@.
type FlagHelp = String
---------------------------------------------------------------------
-- UTILITY
-- | 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
| otherwise = Nothing
where
ls = map toLower s
true = ["true","yes","on","enabled","1"]
false = ["false","no","off","disabled","0"]
---------------------------------------------------------------------
-- GROUPS
-- | A group of items (modes or flags). The items are treated as a list, but the
-- group structure is used when displaying the help message.
data Group a = Group
{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
instance Functor Group where
fmap f (Group a b c) = Group (map f a) (map f b) (map (second $ map f) c)
instance Monoid (Group a) where
mempty = Group [] [] []
mappend (Group x1 x2 x3) (Group y1 y2 y3) = Group (x1++y1) (x2++y2) (x3++y3)
-- | Convert a group into a list.
fromGroup :: Group a -> [a]
fromGroup (Group x y z) = x ++ y ++ concatMap snd z
-- | Convert a list into a group, placing all fields in 'groupUnnamed'.
toGroup :: [a] -> Group a
toGroup x = Group x [] []
---------------------------------------------------------------------
-- TYPES
-- | 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 -- ^ 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 :: ([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
}
-- | Extract the modes from a 'Mode'
modeModes :: Mode a -> [Mode a]
modeModes = fromGroup . modeGroupModes
-- | Extract the flags from a 'Mode'
modeFlags :: Mode a -> [Flag a]
modeFlags = fromGroup . modeGroupFlags
-- | The 'FlagInfo' type has the following meaning:
--
--
-- > FlagReq FlagOpt FlagOptRare/FlagNone
-- > -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
data FlagInfo
= FlagReq -- ^ Required argument
| FlagOpt String -- ^ Optional argument
| FlagOptRare String -- ^ Optional argument that requires an = before the value
| FlagNone -- ^ No argument
deriving (Eq,Ord,Show)
-- | Extract the value from inside a 'FlagOpt' or 'FlagOptRare', or raises an error.
fromFlagOpt :: FlagInfo -> String
fromFlagOpt (FlagOpt x) = x
fromFlagOpt (FlagOptRare x) = x
-- | A function to take a string, and a value, and either produce an error message
-- (@Left@), or a modified value (@Right@).
type Update a = String -> a -> Either String a
-- | A flag, consisting of a list of flag names and other information.
data Flag a = Flag
{flagNames :: [Name] -- ^ The names for the flag.
,flagInfo :: FlagInfo -- ^ Information about a flag's arguments.
,flagValue :: Update a -- ^ The way of processing a flag.
,flagType :: FlagHelp -- ^ The type of data for the flag argument, i.e. FILE\/DIR\/EXT
,flagHelp :: Help -- ^ The help message associated with this flag.
}
-- | An unnamed argument. Anything not starting with @-@ is considered an argument,
-- apart from @\"-\"@ which is considered to be the argument @\"-\"@, and any arguments
-- following @\"--\"@. For example:
--
-- > programname arg1 -j - --foo arg3 -- -arg4 --arg5=1 arg6
--
-- Would have the arguments:
--
-- > ["arg1","-","arg3","-arg4","--arg5=1","arg6"]
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
}
---------------------------------------------------------------------
-- CHECK FLAGS
-- | Check that a mode is well formed.
checkMode :: Mode a -> Maybe String
checkMode x = msum
[checkNames "modes" $ concatMap modeNames $ modeModes x
,msum $ map checkMode $ modeModes x
,checkGroup $ modeGroupModes x
,checkGroup $ modeGroupFlags x
,checkNames "flag names" $ concatMap flagNames $ modeFlags x]
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]
checkNames :: String -> [Name] -> Maybe String
checkNames msg xs = check "Empty names" (all (not . null) xs) `mplus` do
bad <- listToMaybe $ xs \\ nub xs
let dupe = filter (== bad) xs
return $ "Sanity check failed, multiple " ++ msg ++ ": " ++ unwords (map show dupe)
check :: String -> Bool -> Maybe String
check msg True = Nothing
check msg False = Just msg
---------------------------------------------------------------------
-- REMAP
class Remap m where
remap :: (a -> b) -- ^ Embed a value
-> (b -> (a, a -> b)) -- ^ Extract the mode and give a way of re-embedding
-> m a -> m b
remap2 :: Remap m => (a -> b) -> (b -> a) -> m a -> m b
remap2 f g = remap f (\x -> (g x, f))
instance Remap Mode where
remap f g x = x
{modeGroupModes = fmap (remap f g) $ modeGroupModes x
,modeValue = f $ modeValue x
,modeCheck = \v -> let (a,b) = g v in fmap b $ modeCheck x a
,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
remap f g x = x{flagValue = remapUpdate f g $ flagValue x}
instance Remap Arg where
remap f g x = x{argValue = remapUpdate f g $ argValue x}
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 = (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 = (modeEmpty value){modeNames=[name], modeHelp=help, modeGroupModes=toGroup xs}
---------------------------------------------------------------------
-- FLAG CREATORS
-- | Create a flag taking no argument value, with a list of flag names, an update function
-- and some help text.
flagNone :: [Name] -> (a -> a) -> Help -> Flag a
flagNone names f help = Flag names FlagNone upd "" help
where upd _ x = Right $ f x
-- | Create a flag taking an optional argument value, with an optional value, a list of flag names,
-- an update function, the type of the argument and some help text.
flagOpt :: String -> [Name] -> Update a -> FlagHelp -> Help -> Flag a
flagOpt def names upd typ help = Flag names (FlagOpt def) upd typ help
-- | Create a flag taking a required argument value, with a list of flag names,
-- an update function, the type of the argument and some help text.
flagReq :: [Name] -> Update a -> FlagHelp -> Help -> Flag a
flagReq names upd typ help = Flag names FlagReq upd typ help
-- | 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 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
flagBool names f help = Flag names (FlagOptRare "") upd "" help
where
upd s x = case if s == "" then Just True else parseBool s of
Just b -> Right $ f b x
Nothing -> Left "expected boolean value (true/false)"
cmdargs-0.10.13/System/Console/CmdArgs/Explicit/SplitJoin.hs 0000644 0000000 0000000 00000003670 12527643224 021735 0 ustar 00 0000000 0000000 {-# 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 [] = []
cmdargs-0.10.13/System/Console/CmdArgs/Explicit/Process.hs 0000644 0000000 0000000 00000014126 12527643224 021436 0 ustar 00 0000000 0000000 {-# 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
-- | 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
process = processMode
processMode :: Mode a -> [String] -> Either String a
processMode m args =
case find of
Ambiguous xs -> Left $ ambiguous "mode" a xs
Found x -> processMode x as
NotFound
| 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
where
(find,a,as) = case args of
[] -> (NotFound,"",[])
x:xs -> (lookupName (map (modeNames &&& id) $ modeModes m) x, x, xs)
data S a = S
{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 :: 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}
upd :: S a -> (a -> Either String a) -> S a
upd s f = case f $ val s of
Left x -> err s x
Right x -> s{val=x}
processFlags :: Mode a -> a -> [String] -> Either String a
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]
processFlag :: Mode a -> S a -> S a
processFlag mode s_@S{args=('-':'-':xs):ys} | xs /= "" =
case lookupName (pickFlags True mode) a of
Ambiguous poss -> err s $ ambiguous "flag" ("--" ++ a) poss
NotFound -> err s $ "Unknown flag: --" ++ a
Found (arg,flag) -> case arg of
FlagNone | null b -> upd s $ flagValue flag ""
| otherwise -> err s $ "Unhandled argument to flag, none expected: --" ++ xs
FlagReq | null b && null ys -> err s $ "Flag requires argument: --" ++ xs
| null b -> upd s{args=tail ys} $ flagValue flag $ head ys
| otherwise -> upd s $ flagValue flag $ tail b
_ | null b -> upd s $ flagValue flag $ fromFlagOpt arg
| otherwise -> upd s $ flagValue flag $ tail b
where
s = s_{args=ys}
(a,b) = break (== '=') xs
processFlag mode s_@S{args=('-':x:xs):ys} | x /= '-' =
case lookupName (pickFlags False mode) [x] of
Ambiguous poss -> err s $ ambiguous "flag" ['-',x] poss
NotFound -> err s $ "Unknown flag: -" ++ [x]
Found (arg,flag) -> case arg of
FlagNone | "=" `isPrefixOf` xs -> err s $ "Unhandled argument to flag, none expected: -" ++ [x]
| otherwise -> upd s_{args=['-':xs|xs/=""] ++ ys} $ flagValue flag ""
FlagReq | null xs && null ys -> err s $ "Flag requires argument: -" ++ [x]
| null xs -> upd s_{args=tail ys} $ flagValue flag $ head ys
| otherwise -> upd s_{args=ys} $ flagValue flag $ if "=" `isPrefixOf` xs then tail xs else xs
FlagOpt x | null xs -> upd s_{args=ys} $ flagValue flag x
| otherwise -> upd s_{args=ys} $ flagValue flag $ if "=" `isPrefixOf` xs then tail xs else xs
FlagOptRare x | "=" `isPrefixOf` xs -> upd s_{args=ys} $ flagValue flag $ tail xs
| otherwise -> upd s_{args=['-':xs|xs/=""] ++ ys} $ flagValue flag x
where
s = s_{args=ys}
processFlag mode s_@S{args="--":ys} = f s_{args=ys}
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, 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, 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
ambiguous typ got xs = "Ambiguous " ++ typ ++ " '" ++ got ++ "', could be any of: " ++ unwords xs
missing typ xs = "Missing " ++ typ ++ ", wanted any of: " ++ unwords xs
data LookupName a = NotFound
| Ambiguous [Name]
| Found a
-- different order to lookup so can potentially partially-apply it
lookupName :: [([Name],a)] -> Name -> LookupName a
lookupName names value =
case (match (==), match isPrefixOf) of
([],[]) -> NotFound
([],[x]) -> Found $ snd x
([],xs) -> Ambiguous $ map fst xs
([x],_) -> Found $ snd x
(xs,_) -> Ambiguous $ map fst xs
where
match op = [(head ys,v) | (xs,v) <- names, let ys = filter (op value) xs, ys /= []]
cmdargs-0.10.13/System/Console/CmdArgs/Explicit/Help.hs 0000644 0000000 0000000 00000012335 12527643224 020710 0 ustar 00 0000000 0000000 {-
Sample renderings:
-- ONE MODE
Program description
programname [OPTIONS] FILE1 FILE2 [FILES]
Program to perform some action
-f --flag description
Flag grouping:
-a --another description
-- MANY MODES WITH ONE SHOWN
Program description
programname [COMMAND] [OPTIONS] ...
Program to perform some action
Commands:
[build] Build action here
test Test action here
Flags:
-s --special Special for the root only
Common flags:
-? --help Build action here
-- MANY MODES WITH ALL SHOWN
Program description
programname [COMMAND] [OPTIONS] ...
Program to perform some action
-s --special Special for the root only
Common flags:
-? --help Build action here
programname [build] [OPTIONS] [FILES}
Action to perform here
-}
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
import Data.Maybe
-- | Specify the format to output the help.
data HelpFormat
= 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
instance Show (Mode a) where
show = show . helpTextDefault
instance Show (Flag a) where
show = show . helpFlag
instance Show (Arg a) where
show = show . argType
-- | 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
-- | Help text for all modes
--
-- > [OPTIONS]
-- >
-- > MODE [SUBMODE] [OPTIONS] [FLAG]
helpTextAll :: Mode a -> [Text]
helpTextAll = disp . push ""
where
disp m = uncurry (++) (helpTextMode m) ++ concatMap (\x -> Line "" : disp x) (modeModes m)
push s m = m{modeNames = map (s++) $ modeNames m
,modeGroupModes = fmap (push s2) $ modeGroupModes m}
where s2 = s ++ concat (take 1 $ modeNames m) ++ " "
-- | Help text for only this mode
--
-- > [OPTIONS]
-- >
-- > MODE [FLAGS]
-- >
helpTextOne :: Mode a -> [Text]
helpTextOne m = pre ++ ms ++ suf
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]
helpTextMode :: Mode a -> ([Text], [Text])
helpTextMode x@Mode{modeGroupFlags=flags,modeGroupModes=modes} = (pre,suf)
where
pre = [Line $ unwords $ take 1 (modeNames x) ++
["[COMMAND] ..." | notNullGroup modes] ++
["[OPTIONS]" | not $ null $ fromGroup flags] ++
helpArgs (modeArgs x)] ++
[Line $ " " ++ modeHelp x | not $ null $ modeHelp x]
suf = space
([Line "Flags:" | mixedGroup flags] ++
helpGroup helpFlag (modeGroupFlags x)) ++
space (map Line $ modeHelpSuffix x)
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]
helpFlag x = [cols [unwords $ map ("-"++) a2, unwords $ map ("--"++) b2, ' ' : flagHelp x]]
where
(a,b) = partition ((==) 1 . length) $ flagNames x
(a2,b2) = if null b then (add a opt, b) else (a, add b opt)
add x y = if null x then x else (head x ++ y) : tail x
hlp = if null (flagType x) then "ITEM" else flagType x
opt = case flagInfo x of
FlagReq -> '=' : hlp
FlagOpt x -> "[=" ++ hlp ++ "]"
_ -> ""
cols (x:xs) = Cols $ (" "++x) : map (' ':) xs
space xs = [Line "" | not $ null xs] ++ xs
nullGroup x = null (groupUnnamed x) && null (groupNamed x)
notNullGroup = not . nullGroup
mixedGroup x = not $ null (groupUnnamed x) || null (groupNamed x) -- has both unnamed and named
cmdargs-0.10.13/System/Console/CmdArgs/Explicit/ExpandArgsAt.hs 0000644 0000000 0000000 00000002502 12527643224 022334 0 ustar 00 0000000 0000000 {-# 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]
cmdargs-0.10.13/System/Console/CmdArgs/Explicit/Complete.hs 0000644 0000000 0000000 00000017147 12527643224 021576 0 ustar 00 0000000 0000000 {-# 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
| "-" `isPrefixOf` x = expectFlag flag x ++ [CompleteValue "-" | x == "-", isJust arg]
| otherwise = expectMode mode x ++ expectArg arg x ++ expectFlag 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"]
cmdargs-0.10.13/Data/ 0000755 0000000 0000000 00000000000 12527643224 012342 5 ustar 00 0000000 0000000 cmdargs-0.10.13/Data/Generics/ 0000755 0000000 0000000 00000000000 12527643224 014101 5 ustar 00 0000000 0000000 cmdargs-0.10.13/Data/Generics/Any.hs 0000644 0000000 0000000 00000007656 12527643224 015202 0 ustar 00 0000000 0000000 {-# LANGUAGE ExistentialQuantification #-}
module Data.Generics.Any where
import Control.Exception
import Control.Monad.Trans.State
import qualified Data.Data as D
import Data.Data hiding (toConstr, typeOf, dataTypeOf, isAlgType)
import Data.List
import Data.Maybe
import qualified Data.Typeable.Internal as I
import System.IO.Unsafe
type CtorName = String
type FieldName = String
readTupleType :: String -> Maybe Int
readTupleType x | "(" `isPrefixOf` x && ")" `isSuffixOf` x && all (== ',') y = Just $ length y
| otherwise = Nothing
where y = init $ tail x
try1 :: a -> Either SomeException a
try1 = unsafePerformIO . try . evaluate
---------------------------------------------------------------------
-- BASIC TYPES
-- | Any value, with a Data dictionary.
data Any = forall a . Data a => Any a
type AnyT t = Any
instance Show Any where
show = show . typeOf
fromAny :: Typeable a => Any -> a
fromAny (Any x) = case D.cast x of
Just y -> y
~(Just y) -> error $ "Data.Generics.Any.fromAny: Failed to extract any, got " ++
show (D.typeOf x) ++ ", wanted " ++ show (D.typeOf y)
cast :: Typeable a => Any -> Maybe a
cast (Any x) = D.cast x
---------------------------------------------------------------------
-- SYB COMPATIBILITY
toConstr :: Any -> Constr
toConstr (Any x) = D.toConstr x
typeOf :: Any -> TypeRep
typeOf (Any x) = D.typeOf x
dataTypeOf :: Any -> DataType
dataTypeOf (Any x) = D.dataTypeOf x
isAlgType :: Any -> Bool
isAlgType = D.isAlgType . dataTypeOf
---------------------------------------------------------------------
-- TYPE STUFF
typeShell :: Any -> String
typeShell = tyconUQname . typeShellFull
typeShellFull :: Any -> String
typeShellFull = I.tyConName . typeRepTyCon . typeOf
typeName :: Any -> String
typeName = show . typeOf
---------------------------------------------------------------------
-- ANY PRIMITIVES
ctor :: Any -> CtorName
ctor = showConstr . toConstr
fields :: Any -> [String]
fields = constrFields . toConstr
children :: Any -> [Any]
children (Any x) = gmapQ Any x
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)
recompose :: Any -> [Any] -> Any
recompose (Any x) cs | null s = Any $ res `asTypeOf` x
| otherwise = err
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) ++
", got " ++ show (length cs)
ctors :: Any -> [CtorName]
ctors = map showConstr . dataTypeConstrs . dataTypeOf
---------------------------------------------------------------------
-- DERIVED FUNCTIONS
decompose :: Any -> (CtorName,[Any])
decompose x = (ctor x, children x)
arity = length . children
compose :: Any -> CtorName -> [Any] -> Any
compose t c xs = recompose (compose0 t c) xs
---------------------------------------------------------------------
-- FIELD UTILITIES
getField :: FieldName -> Any -> Any
getField lbl x = fromMaybe (error $ "getField: Could not find field " ++ show lbl) $
lookup lbl $ zip (fields x) (children x)
setField :: (FieldName,Any) -> Any -> Any
setField (lbl,child) parent
| lbl `notElem` fs = error $ "setField: Could not find field " ++ show lbl
| otherwise = recompose parent $ zipWith (\f c -> if f == lbl then child else c) fs cs
where
fs = fields parent
cs = children parent
cmdargs-0.10.13/Data/Generics/Any/ 0000755 0000000 0000000 00000000000 12527643224 014630 5 ustar 00 0000000 0000000 cmdargs-0.10.13/Data/Generics/Any/Prelude.hs 0000644 0000000 0000000 00000004227 12527643224 016571 0 ustar 00 0000000 0000000 {-# LANGUAGE ViewPatterns #-}
module Data.Generics.Any.Prelude where
import Prelude hiding (head,tail,null)
import Data.Generics.Any
import Data.Maybe
head :: AnyT [a] -> AnyT a
head (decompose -> ("(:)",[x,_])) = x
tail :: AnyT [a] -> AnyT [a]
tail (decompose -> ("(:)",[_,x])) = x
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 == "[]"
just_ :: AnyT (Maybe a) -> AnyT a -> AnyT (Maybe a)
just_ w x = compose w "Just" [x]
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 = 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)
isString x = typeName x == "[Char]"
isList x = typeShell x == "[]"
isMaybe x = typeShell x == "Maybe"
isTuple x = isJust $ readTupleType $ typeShell x
fromList w = children (compose0 w "(:)") !! 0
fromMaybe w = children (compose0 w "Just") !! 0
fromTuple w = children (compose0 w $ typeShell w)
unit :: AnyT ()
unit = Any ()
-- Could use a witness and avoid switching on the list of tuples, but this
-- presents a nicer interface
tuple :: [Any] -> Any
tuple [] = unit
tuple [x] = x
-- $(2\7 tuple [$(1,$ Any x$)] = Any ($(1,$ x$)))
tuple [Any x1,Any x2] = Any (x1,x2)
tuple [Any x1,Any x2,Any x3] = Any (x1,x2,x3)
tuple [Any x1,Any x2,Any x3,Any x4] = Any (x1,x2,x3,x4)
tuple [Any x1,Any x2,Any x3,Any x4,Any x5] = Any (x1,x2,x3,x4,x5)
tuple [Any x1,Any x2,Any x3,Any x4,Any x5,Any x6] = Any (x1,x2,x3,x4,x5,x6)
tuple [Any x1,Any x2,Any x3,Any x4,Any x5,Any x6,Any x7] = Any (x1,x2,x3,x4,x5,x6,x7)
tuple _ = error "Data.Generics.Any: Tuples of 8 elements or more are not supported by Data.Data"