diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,26 @@ +Release 0.30.0.4 + +* Version bump for QuickCheck + +Release 0.30.0.0 + +* Completely changed the API. This version is much better tested than + previous versions. Instead of using parser combinators as a model, + this version is built on a Mealy finite state machine. + +* The tests are particularly exhaustive; there is a module that + produces all possible command-line words that can parse to a + particular option (for instance, the user might enter "-a -b foo" or + "-abfoo" if -b is an option that takes a single option argument.) + Different combinations are tested randomly. + +Release 0.28.0.0 + +* Renamed everything from System.Console.MultiArg to Multiarg + (shorter; note also case change from MultiArg to Multiarg) + +* Removed existentials from Multiarg.CommandLine + Release 0.24.0.4, February 24, 2014 * Changed lower bound on base down to 4.5.0.0 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -10,19 +10,69 @@ http://www.github.com/massysett/multiarg +## Building + +If you obtained this code through Hackage, just build it using the +ordinary Cabal command: + +cabal install + +If you obtain this code on Github, you will first need to generate the +Cabal file and generate the tests. This will require that you install +two libraries: + +cabal install cartel quickpull + +Then run this script to generate the Cabal file and the tests: + +sh generate + ## Versioning multiarg releases are numbered in accordance with the Haskell Package Versioning Policy. -multiarg does not set its dependencies in accordance with the -Package Versioning Policy, as I do not set upper bounds. multiarg -is guaranteed to build with the *minimum* versions specified in the -cabal file. I also include a current-versions.txt file that -documents more recent dependencies that are also known to work. +Currently the multiarg library depends only on the "base" package, so +multiarg should have wide compatibility with different compilers and +sets of libraries. The tests have some additional dependencies. -If you find that multiarg does not build due to dependency problems: -1) please let me know at omari@smileystation.com; 2) feel free to -add appropriate upper bounds or patches to the package as -appropriate; and 3) feel free to add command-line contraints to your -cabal command to get it to build. +## Build history + +If you're having trouble building multiarg, try looking at the +travis-ci build history at: + +https://travis-ci.org/massysett/multiarg + +It shows successful builds and the versions of any package +dependencies that were installed when that build succeeded, so it +might help you diagnose any dependency issues. + +[![Build Status](https://travis-ci.org/massysett/multiarg.svg?branch=master)](https://travis-ci.org/massysett/multiarg) + +## Similar libraries + +Of course there are many command-line parsing modules and libraries +out there; here are some comparisons. + +[optparse-applicative](https://hackage.haskell.org/package/optparse-applicative): +very featureful with a well thought-out interface. Builds help for +you. I often use this if it meets my needs. From what I can tell, +though, it strips out information about the relative ordering of the +words from the command line; for instance, if the user typed "hello +--opt1 --opt2", you cannot tell whether she entered "--opt1" before +she entered "--opt2". Also, from what I can tell it cannot easily +parse options that take more than one argument. + +[GetOpt](https://hackage.haskell.org/package/base-4.7.0.2/docs/System-Console-GetOpt.html): +comes with the base libraries, so you don't have to install anything +extra, which gives it a huge advantage. Keeps information about the +relative ordering of the words from the command line. Cannot easily +parse options that take more than one argument. + +[cmdargs](https://hackage.haskell.org/package/cmdargs): after multiple +passes through the Haddocks I could never make any sense of this +library at all, which must be a reflection of my level of Haskell +ignorance. + +More comparisons are at the [Haskell +Wiki](https://www.haskell.org/haskellwiki/Command_line_option_parsers). diff --git a/current-versions.txt b/current-versions.txt deleted file mode 100644 --- a/current-versions.txt +++ /dev/null @@ -1,51 +0,0 @@ -This package was tested to work with these dependency -versions and compiler version. -These are the default versions fetched by cabal install. -Tested as of: 2014-03-01 20:12:15.212998 UTC -Path to compiler: ghc-7.6.3 -Compiler description: 7.6.3 - -/opt/ghc-7.6.3/lib/ghc-7.6.3/package.conf.d: - Cabal-1.16.0 - array-0.4.0.1 - base-4.6.0.1 - bin-package-db-0.0.0.0 - binary-0.5.1.1 - bytestring-0.10.0.2 - containers-0.5.0.0 - deepseq-1.3.0.1 - directory-1.2.0.1 - filepath-1.3.0.1 - (ghc-7.6.3) - ghc-prim-0.3.0.0 - (haskell2010-1.1.1.0) - (haskell98-2.0.0.2) - hoopl-3.9.0.0 - hpc-0.6.0.0 - integer-gmp-0.5.0.0 - old-locale-1.0.0.5 - old-time-1.1.0.1 - pretty-1.1.1.0 - process-1.1.0.2 - rts-1.0 - template-haskell-2.8.0.0 - time-1.4.0.1 - unix-2.6.0.1 - -/home/massysett/multiarg/sunlight-29118/db: - bifunctors-4.1.1 - comonad-4.0 - contravariant-0.4.4 - distributive-0.4 - hashable-1.2.1.0 - mtl-2.1.2 - multiarg-0.26.0.0 - nats-0.1.2 - semigroupoids-4.0 - semigroups-0.12.2 - tagged-0.7 - text-1.1.0.0 - transformers-0.3.0.0 - transformers-compat-0.1.1.1 - unordered-containers-0.2.3.3 - diff --git a/lib/Multiarg.hs b/lib/Multiarg.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg.hs @@ -0,0 +1,37 @@ +-- | Parse command lines with /options/ that might take multiple +-- /option arguments/. +-- +-- I built this library could not find anything that would readily +-- parse command lines where the /options/ took more than one +-- /option argument/. For example, for the @tail@ command on GNU systems, the +-- @--lines@ /option/ takes one /option argument/ to specify how many +-- lines you want to see. Well, what if you want to build a program +-- with an option that takes two /option arguments/, like @--foo bar +-- baz@? I found no such library so I built this one. +-- +-- Please consult the "Multiarg.Vocabulary" module to learn common +-- vocabulary used throughout Multiarg and its documentation. Words +-- that appear in /italics/ are defined in "Multiarg.Vocabulary". +-- +-- Use this module to build parsers for simple commands. The +-- 'parseCommandLine' function runs in the IO monad and will cause +-- your program to exit unsuccessfully if there are any errors in the +-- command line, printing an error message in the process. If you +-- want more control over error handling, use the "Multiarg.Internal" +-- module. +-- +-- To write parsers for commands with multiple modes (for instance, +-- @ghc-pkg@ has multiple modes, such as @ghc-pkg list@ and @ghc-pkg +-- check@) use the "Multiarg.Mode" module. +-- +-- You will find examples in "Multiarg.Examples.Telly" for non-mode +-- parsers, and in "Multiarg.Examples.Grover" for mode parsers. +module Multiarg + ( ArgSpec(..) + , OptSpec + , optSpec + , parseCommandLine + ) where + +import Multiarg.Internal +import Multiarg.Types diff --git a/lib/Multiarg/Examples.hs b/lib/Multiarg/Examples.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Examples.hs @@ -0,0 +1,31 @@ +-- | These modules provide examples. Since they are live code, cabal +-- compiles them, which ensures that the examples actually compile. +-- In addition, the examples are used as fodder for the test cases; +-- this provides assurance not only that the library is tested but +-- also that the examples work as they should. +-- +-- "Multiarg.Examples.Telly" provides an example parser for a command +-- that does not have modes; this is the sort of parser you build with +-- "Multiarg". "Multiarg.Examples.Grover" provides an example of a +-- parser for multiple modes; you build this sort of parser using +-- "Multiarg.Mode". +-- +-- To see these examples in action, compile the library using the +-- "programs" flag, like so: +-- +-- > cabal configure -fprograms +-- > cabal build +-- +-- This will create two programs, @telly@ and @grover@. You simply +-- pass /words/ to these programs just like an ordinary user would, +-- and the programs will print the results of what they parse. If you +-- entered /words/ that parse correctly, you will see this result; if +-- there are any errors, you will see that instead. For example: +-- +-- >>> dist/build/telly/telly --uno testarg filename +-- [Uno "testarg",PosArg "filename"] +-- +-- >>> dist/build/grover/grover --verbose 2 int --double 5 2 +-- Right (ModeResult [Right (Verbose 2)] (Right (Ints [Right (Double 5 2)]))) + +module Multiarg.Examples where diff --git a/lib/Multiarg/Examples/Grover.hs b/lib/Multiarg/Examples/Grover.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Examples/Grover.hs @@ -0,0 +1,110 @@ +-- | Grover is a simple example program that shows how to write a +-- parser for commands with multiple modes. You build such parsers +-- using "Multiarg.Mode". It provides an example for the +-- documentation, and it also provides fodder for the QuickCheck +-- tests. You will want to look at the source code. +-- +-- Grover has three modes: @int@, @string@, and @maybe@. Each of +-- these modes has three options: @-z@ or @--zero@, which takes no +-- arguments; @-s@ or @--single@, which takes one argument; @-d@ or +-- @--double@, which takes two arguments; and @-t@ or @--triple@, +-- which takes three arguments. The type of the argument depends on +-- the mode. For @int@, the argument or arguments must be an integer; +-- for @string@ the arguments can be any string; and for @maybe@ the +-- arguments must be a Maybe Int, such as @Nothing@ or @Just 5@. +-- +-- Each mode also accepts any number of positional arguments, which +-- can be any string. +-- +-- Grover handles simple errors right inside the parser by using the +-- @Either@ type as a return value. + +module Multiarg.Examples.Grover where + +import Control.Applicative +import Multiarg.Mode +import Text.Read (readMaybe) + +-- | Grover's global options. +data Global + = Help + | Verbose Int + -- ^ The Int would indicate, for example, the desired level of + -- verbosity. + | Version + deriving (Eq, Ord, Show) + +-- | Handles all options and positional arguments for any Grover mode. +data GroverOpt a + = Zero + | Single a + | Double a a + | Triple a a a + | PosArg String + deriving (Eq, Ord, Show) + +instance Functor GroverOpt where + fmap f g = case g of + Zero -> Zero + Single a -> Single (f a) + Double a b -> Double (f a) (f b) + Triple a b c -> Triple (f a) (f b) (f c) + PosArg a -> PosArg a + +-- | All of Grover's global options. The 'OptSpec' is parameterized +-- on an 'Either' to allow for error handling. If the user enters a +-- non-integer argument for the @--verbose@ option, a @Left@ with an +-- error message is returned. +globalOptSpecs :: [OptSpec (Either String Global)] +globalOptSpecs = + [ optSpec "h" ["help"] . ZeroArg . return $ Help + , optSpec "v" ["verbose"] . OneArg $ \s -> + Verbose <$> readErr s + , optSpec "" ["version"] . ZeroArg . return $ Version + ] + +-- | A list of 'OptSpec' that works for any 'Mode'. +modeOptSpecs :: Read a => [OptSpec (Either String (GroverOpt a))] +modeOptSpecs = + [ optSpec "z" ["zero"] . ZeroArg . Right $ Zero + , optSpec "s" ["single"] . OneArg $ \s -> Single <$> readErr s + + , optSpec "d" ["double"] . TwoArg $ \s1 s2 -> + Double <$> readErr s1 <*> readErr s2 + + , optSpec "t" ["triple"] . ThreeArg $ \s1 s2 s3 -> + Triple <$> readErr s1 <*> readErr s2 <*> readErr s3 + ] + +-- | Holds the results of parsing Grover's modes. +data Result + = Ints [Either String (GroverOpt Int)] + | Strings [Either String (GroverOpt String)] + | Maybes [Either String (GroverOpt (Maybe Int))] + deriving (Eq, Ord, Show) + +-- | All Grover modes. +modes :: [Mode Result] +modes = + [ mode "int" modeOptSpecs (return . PosArg) Ints + , mode "string" modeOptSpecs (return . PosArg) Strings + , mode "maybe" modeOptSpecs (return . PosArg) Maybes + ] + +-- | Reads a value. If it cannot be read, returns an error message. +readErr :: Read a => String -> Either String a +readErr s = case readMaybe s of + Nothing -> Left $ "could not read value: " ++ s + Just a -> Right a + +-- | Parses all of Grover's options and modes. +parseGrover + :: [String] + -- ^ Command line arguments, presumably from 'getArgs' + -> Either (String, [String]) + (ModeResult (Either String Global) Result) + -- ^ Returns a 'Left' if there are errors, or a 'Right' if there are + -- no errors. (In an actual application, further processing of a + -- 'Right' would be necessary to determine whether all entered + -- arguments were valid.) +parseGrover = parseModeLine globalOptSpecs modes diff --git a/lib/Multiarg/Examples/Telly.hs b/lib/Multiarg/Examples/Telly.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Examples/Telly.hs @@ -0,0 +1,88 @@ +-- | Telly is a simple command-line program to test command-line +-- parsers that do not have multiple modes. This includes most +-- command-line programs; you build parsers like this using +-- "Multiarg". This module provides an example for documentation +-- purposes; it also provides fodder for the QuickCheck test cases. +-- You will want to look at the source code. + +module Multiarg.Examples.Telly where + +import Multiarg + +-- | A data type to hold the result of command line parsing. +data Telly + = PosArg String + -- ^ Positional argument + + | Empty + -- ^ @--empty@, @-e@ + | Single String + -- ^ @--single@, @-s@ + | Double String String + -- ^ @--double@, @-d@ + | Triple String String String + -- ^ @--triple@, @-t@ + + | Zero + -- ^ @-0@ + | One String + -- ^ @-1@ + | Two String String + -- ^ @-2@ + | Three String String String + -- ^ @-3@ + + | Cero + -- ^ @--cero@ + | Uno String + -- ^ @--uno@ + | Dos String String + -- ^ @--dos@ + | Tres String String String + -- ^ @--tres@ + deriving (Eq, Ord, Show) + +optSpecs :: [OptSpec Telly] +optSpecs = + [ optSpec "e" ["empty"] (ZeroArg Empty) + , optSpec "s" ["single"] (OneArg Single) + , optSpec "d" ["double"] (TwoArg Double) + , optSpec "t" ["triple"] (ThreeArg Triple) + + , optSpec "0" [] (ZeroArg Zero) + , optSpec "1" [] (OneArg One) + , optSpec "2" [] (TwoArg Two) + , optSpec "3" [] (ThreeArg Three) + + , optSpec "" ["cero"] (ZeroArg Cero) + , optSpec "" ["uno"] (OneArg Uno) + , optSpec "" ["dos"] (TwoArg Dos) + , optSpec "" ["tres"] (ThreeArg Tres) + ] + +help :: String -> String +help progName = unlines + [ progName ++ " - simple program to test Multiarg." + , "Parses command line and prints the results to standard output." + , "Usage:" + , progName ++ " [options] ARGUMENTS..." + , "" + , "Options:" + , "" + , "--empty, -e - option that takes no arguments" + , "--single ARG, -s ARG - option that takes one argument" + , "--double ARG1 ARG2, -d ARG1 ARG2 - option that takes two arguments" + , "--triple ARG1 ARG2 ARG3, -t ARG1 ARG2 ARG3" + , " - option that takes three arguments" + , "" + , "--cero - same as --empty" + , "--uno - same as --single" + , "--dos - same as --double" + , "--tres - same as --triple" + , "" + , "--help, -h - show help and exit" + ] + +parse :: IO [Telly] +parse = parseCommandLine help optSpecs PosArg + diff --git a/lib/Multiarg/Internal.hs b/lib/Multiarg/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Internal.hs @@ -0,0 +1,176 @@ +-- | Functions and types used by the "Multiarg" module. You don't +-- have to worry about \"breaking\" anything by using this module. +-- This module is separate from "Multiarg" only because it makes the +-- documentation in that module cleaner, as that module should satisfy +-- most use cases. Use this module if you want more control over +-- error handling, or if you want to process arguments using pure +-- functions rather than IO functions. +module Multiarg.Internal where + +import Multiarg.Maddash +import Multiarg.Limeline +import Multiarg.Types +import Multiarg.Util +import Data.Either (partitionEithers) +import System.Environment +import System.Exit +import qualified System.IO as IO + +limelineOutputToParsedCommandLine + :: ([Either [Output a] (PosArg a)], Maybe OptName) + -> ParsedCommandLine a +limelineOutputToParsedCommandLine (ls, mayOpt) = + ParsedCommandLine (concatMap f ls) mayOpt + where + f ei = case ei of + Left os -> map g os + where + g o = case o of + Good a -> Right a + OptionError oe -> Left oe + Right (PosArg pa) -> [Right pa] + + +-- | Indicates the result of parsing a command line. +data ParsedCommandLine a + = ParsedCommandLine [Either OptionError a] (Maybe OptName) + -- ^ @ParsedCommandLine a b@, where: + -- + -- @a@ is a list of errors and results, in the original order in + -- which they appeared on the command line. + -- + -- @b@ is @Just p@ if the user included an /option/ at the end of + -- the command line and there were not enough following /words/ to + -- provide the /option/ with its necessary /option arguments/, where + -- @p@ is the /name/ of the /option/ with insufficient + -- /option arguments/; + -- otherwise 'Nothing'. + deriving (Eq, Ord, Show) + +instance Functor ParsedCommandLine where + fmap f (ParsedCommandLine ls m) = ParsedCommandLine + (map (fmap f) ls) m + +-- | Gets the results from a parsed command line. If there were +-- errors, returns a 'Left' with an error message; otherwise, returns +-- a 'Right' with a list of the results. +parsedResults + :: ParsedCommandLine a + -> Either (String, [String]) [a] +parsedResults (ParsedCommandLine ls mayOpt) = + let (ers, gds) = partitionEithers ls + in case (ers, mayOpt) of + ([], Nothing) -> Right gds + ([], Just opt) -> Left (insufficientOptArgs opt, []) + (x:xs, Just opt) -> Left + (optError x, map optError xs ++ [insufficientOptArgs opt]) + (x:xs, Nothing) -> Left + (optError x, map optError xs) + +insufficientOptArgs :: OptName -> String +insufficientOptArgs n = "not enough arguments given for option: " + ++ optNameToString n + +optError :: OptionError -> String +optError oe = case oe of + BadOption opt -> + "unrecognized option: " ++ optNameToString opt + LongArgumentForZeroArgumentOption lng arg -> + "argument given for option that takes no arguments. " + ++ "option: --" ++ longNameToString lng + ++ " argument: " ++ optArgToString arg + + +-- | Parses a command line; a pure function (unlike +-- 'parseCommandLineIO'). +parseCommandLinePure + + :: [OptSpec a] + -- ^ All program options + + -> (String -> a) + -- ^ Processes non-option positional arguments + + -> [String] + -- ^ Input tokens from the command line, probably obtained from + -- 'getArgs' + + -> ParsedCommandLine a + +parseCommandLinePure os fPos inp = + limelineOutputToParsedCommandLine limeOut + where + limeOut = interspersed shrts lngs fPos (map Word inp) + (shrts, lngs) = splitOptSpecs os + +-- | Parses a command line. Runs in the IO monad so that it can do +-- some tedious things for you: +-- +-- * fetches the /words/ on command line using 'getArgs' and the name +-- of the program with 'getProgName' +-- +-- * prints help, if the user requested help, and exits +-- successfully +-- +-- * prints an error message and exits unsuccessfully, if the user +-- entered a bad command line (such as an unknown option) +-- +-- If you don't want this degree of automation or if you want a pure +-- function, see the 'parseCommandLinePure' function in the +-- "Multiarg.Internal" module. +parseCommandLine + :: (String -> String) + -- ^ Returns help for your command. This function is applied to the + -- name of the program being run, which is obtained from + -- 'getProgName'. The function should return a string that gives + -- help for how to use your command; this string is printed as-is. + + -> [OptSpec a] + -- ^ All program /options/. An /option/ for @-h@ and for @--help@ is + -- added for you, using the help function given above. If the user + -- asks for help, then it is printed and the program exits + -- successfully. If the user gives a command line with one or more + -- errors in it, an error message is printed, along with something + -- like @Enter program-name --help for help@. + + -> (String -> a) + -- ^ Processes /positional arguments/. + + -> IO [a] + -- ^ Fetches the /words/ from the command line arguments using + -- 'getArgs' and parses them. If there is an error, prints an error + -- message and exits unsuccessfully. Otherwise, returns the parsed + -- result, where each item in the list corresponds to a parsed + -- /option/ or /positional argument/ in the order in which it + -- appeared on the command line. +parseCommandLine fHelp os fPos = do + progName <- getProgName + args <- getArgs + case parsedResults $ parseCommandLineHelp os fPos args of + Left (e1, es) -> do + IO.hPutStrLn IO.stderr $ progName ++ ": error" + _ <- mapM (IO.hPutStrLn IO.stderr) $ e1 : es + IO.hPutStrLn IO.stderr $ "enter \"" ++ progName ++ " --help\" " + ++ "for help." + exitFailure + Right mayResults -> case sequence mayResults of + Nothing -> do + putStr (fHelp progName) + exitSuccess + Just ls -> return ls + + +-- | Automatically adds a /short option/, @-h@, and a /long option/, +-- @--help@. Intended primarily for use by the 'parseCommandLineIO' +-- function. +parseCommandLineHelp + :: [OptSpec a] + -> (String -> a) + -> [String] + -> ParsedCommandLine (Maybe a) +parseCommandLineHelp os fPos inp = + limelineOutputToParsedCommandLine + $ interspersed shrts lngs (fmap Just fPos) (map Word inp) + where + (shrts, lngs) = addHelpOption os + diff --git a/lib/Multiarg/Limeline.hs b/lib/Multiarg/Limeline.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Limeline.hs @@ -0,0 +1,44 @@ +-- | Processes both /options/ and /positional arguments/. Functions +-- here return both any successful results and any errors. Ordinarily +-- you will not need this module; instead, see "Multiarg" for most +-- uses or "Multiarg.Mode" for commands that have more than one mode. +module Multiarg.Limeline where + +import Multiarg.Types +import Multiarg.Maddash +-- GHC 7.10 exports Word from the Prelude +import Prelude hiding (Word) + +data PosArg a = PosArg a + deriving (Eq, Ord, Show) + +instance Functor PosArg where + fmap f (PosArg a) = PosArg (f a) + +-- | Processes a command line where /options/ are interspersed with +-- /positional arguments/. A /stopper/ is not returned; all +-- /words/ after a /stopper/ are treated as +-- /positional arguments/. +interspersed + :: [(ShortName, ArgSpec a)] + -> [(LongName, ArgSpec a)] + -> (String -> a) + -> [Word] + -> ([Either [Output a] (PosArg a)], Maybe OptName) +interspersed shorts longs fTok = go + where + go toks = (map Left outs ++ outsRest, err) + where + (outs, ei) = processWords shorts longs toks + (outsRest, err) = case ei of + Left (opt, _) -> ([], Just opt) + Right [] -> ([], Nothing) + Right ((Word x):xs) + | x == "--" -> + ( map (\(Word t) -> Right . PosArg . fTok $ t) xs + , Nothing ) + | otherwise -> ( (Right . PosArg . fTok $ x) : rest + , mayErrRest ) + where + (rest, mayErrRest) = go xs + diff --git a/lib/Multiarg/Maddash.hs b/lib/Multiarg/Maddash.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Maddash.hs @@ -0,0 +1,319 @@ +-- | Maddash is a Mealy finite state machine that processes /options/. +-- Ordinarily you will not need this module; instead, see "Multiarg" +-- for most uses or "Multiarg.Mode" for commands that have more than +-- one mode. +-- +-- The machine consists of the following parts: +-- +-- * The set of states, in 'State' +-- +-- * The start state, which is 'Ready' +-- +-- * The input alphabet, which is all 'Word's. A 'Word' is an +-- input /word/ from the command line. +-- +-- * The output alphabet, which is 'Pallet'. A 'Pallet' indicates +-- whether its input is not an option at all with 'NotAnOption'. This +-- indicates that the input 'Word' was not a short option and was not +-- a long option; that is, it was not a single dash followed by a +-- non-dash character and it was not a double dash followed by another +-- character. (Neither a single dash alone nor a double dash alone is +-- an option.) Anything else is an option and will return 'Full', +-- which is a list of 'Output'. Each 'Output' indicates either an +-- error or a good result. +-- +-- * The transition function and the output function are combined into +-- a single function, 'processWord'. + +module Multiarg.Maddash + ( -- * /Options/ and /option arguments/ + OptName(..) + , optSpec + , ArgSpec(..) + , ShortName + , LongName + , shortName + , longName + , shortNameToChar + , longNameToString + + -- * Machine components + , Output(..) + , Pallet(..) + , State(..) + , isReady + , isPending + , processWord + + -- * Multi-word processor + , processWords + + -- * Errors + , OptArg(..) + , OptionError(..) + ) where + +import Control.Applicative +import Multiarg.Types +-- GHC 7.10 exports Word from the Prelude +import Prelude hiding (Word) + +-- * Machine components + +data Output a + = Good a + | OptionError OptionError + deriving (Eq, Ord, Show) + +instance Functor Output where + fmap f (Good a) = Good (f a) + fmap _ (OptionError e) = OptionError e + +data Pallet a + = NotAnOption + | Full [Output a] + deriving (Eq, Ord, Show) + +instance Functor Pallet where + fmap _ NotAnOption = NotAnOption + fmap f (Full os) = Full (map (fmap f) os) + +data State a + = Ready + -- ^ Accepting new words + + | Pending OptName (Word -> ([Output a], State a)) + -- ^ In the middle of processing an /option/; this function will be + -- applied to the next word to get a result + + +instance Functor State where + fmap _ Ready = Ready + fmap f (Pending o g) + = Pending o (\t -> let (os, st') = g t + in (map (fmap f) os, fmap f st')) + +instance Show (State a) where + show Ready = "Ready" + show (Pending o _) = "Pending - " ++ show o + +isReady :: State a -> Bool +isReady Ready = True +isReady _ = False + +isPending :: State a -> Bool +isPending (Pending _ _) = True +isPending _ = False + +-- | Process a single word in the machine. +processWord + :: [(ShortName, ArgSpec a)] + -> [(LongName, ArgSpec a)] + -> State a + -> Word + -> (Pallet a, State a) +processWord shorts longs st inp = case st of + Pending _ f -> (Full os, st') + where + (os, st') = f inp + Ready -> case procOpt of + Just (os, st') -> (Full os, st') + Nothing -> (NotAnOption, Ready) + where + procOpt = procShort shorts inp <|> procLong longs inp + +-- * Multi-word processor + +-- | Processes multiple /words/ in the machine. Processing ends with +-- the first /word/ that is 'NotAnOption'. This first /word/ that is +-- 'NotAnOption', and all remaining /words/, are returned in the +-- result. A list of all lists of 'Output' are also returned, with +-- one list for each input 'Word' that was processed. Each of these +-- lists may be of any length. For instance, if the input /word/ is +-- the /flag/ for a /long option/ that takes two /option arguments/, +-- the corresponding list will be empty. If the input /word/ is a +-- /flag/ for a /short option/, this list may have more than one +-- element. +processWords + :: [(ShortName, ArgSpec a)] + -> [(LongName, ArgSpec a)] + -> [Word] + -> ([[Output a]], Either (OptName, Word -> ([Output a], State a)) [Word]) +processWords shorts longs = go Ready + where + go Ready [] = ([], Right []) + go (Pending opt f) [] = ([], Left (opt, f)) + go st (t:ts) = (rs, eiToksPend) + where + (pallet, st') = processWord shorts longs st t + (rs, eiToksPend) = case pallet of + NotAnOption -> ([], Right (t:ts)) + Full out -> (out : outRest, ei) + where + (outRest, ei) = go st' ts + +-- * Errors + +data OptionError + = BadOption OptName + | LongArgumentForZeroArgumentOption LongName OptArg + -- ^ The user gave an argument for a long option that does not take + -- an argument. + deriving (Eq, Ord, Show) + +-- * All exported types and functions above this line + +-- * Internal functions - not exported + +-- | Examines a word to determine if it is a short option. If so, +-- processes it; otherwise, returns Nothing. +procShort + :: [(ShortName, ArgSpec a)] + -> Word + -> Maybe ([Output a], State a) +procShort shorts inp = fmap (getShortOpt shorts) (isShort inp) + +getShortOpt + :: [(ShortName, ArgSpec a)] + -> (ShortName, ShortTail) + -> ([Output a], State a) +getShortOpt shorts (short, rest) = case lookup short shorts of + Nothing -> ( [OptionError (BadOption (OptName (Left short))) ], Ready) + Just arg -> procShortOpt shorts short arg rest + +procShortOpt + :: [(ShortName, ArgSpec a)] + -> ShortName + -> ArgSpec a + -> ShortTail + -> ([Output a], State a) +procShortOpt opts _ (ZeroArg a) inp = (this : rest, st) + where + this = Good a + (rest, st) = case splitShortTail inp of + Nothing -> ([], Ready) + Just (opt,arg) -> getShortOpt opts (opt, arg) + +procShortOpt _ shrt (OneArg f) (ShortTail inp) = case inp of + [] -> ([], Pending opt g) + where + g tok = ([res], Ready) + where + res = Good . f . optArgToString $ arg + arg = wordToOptArg tok + xs -> ([res], Ready) + where + res = Good . f . optArgToString $ optArg + optArg = OptArg xs + where + opt = OptName (Left shrt) + +procShortOpt _ shrt (TwoArg f) (ShortTail inp) = ([], Pending opt g) + where + g tok1 = case inp of + [] -> ([], Pending opt h) + where + h tok2 = ([res], Ready) + where + oa2 = wordToOptArg tok2 + res = Good $ f (optArgToString oa1) (optArgToString oa2) + + xs -> ([res], Ready) + where + res = Good $ f (optArgToString tokArg) (optArgToString oa1) + tokArg = OptArg xs + where + oa1 = wordToOptArg tok1 + opt = OptName (Left shrt) + +procShortOpt _ shrt (ThreeArg f) (ShortTail inp) = ([], Pending opt g) + where + opt = OptName (Left shrt) + g tok1 = ([], Pending opt h) + where + oa1 = wordToOptArg tok1 + h tok2 = case inp of + [] -> ([], Pending opt i) + where + i tok3 = ([res], Ready) + where + oa3 = wordToOptArg tok3 + res = Good $ f (optArgToString oa1) (optArgToString oa2) + (optArgToString oa3) + tokInp -> ([res], Ready) + where + tokArg = wordToOptArg (Word tokInp) + res = Good $ f (optArgToString tokArg) (optArgToString oa1) + (optArgToString oa2) + where + oa2 = wordToOptArg tok2 + +procLong + :: [(LongName, ArgSpec a)] + -> Word + -> Maybe ([Output a], State a) +procLong longs inp = fmap (procLongOpt longs) (isLong inp) + +procLongOpt + :: [(LongName, ArgSpec a)] + -> (LongName, Maybe OptArg) + -> ([Output a], State a) +procLongOpt longs (inp, mayArg) = case lookup inp longs of + Nothing -> ( [OptionError (BadOption . OptName . Right $ inp)], Ready) + Just (ZeroArg r) -> ([result], Ready) + where + result = case mayArg of + Nothing -> Good r + Just arg -> OptionError (LongArgumentForZeroArgumentOption inp arg) + + Just (OneArg f) -> case mayArg of + Nothing -> ([], Pending opt run) + where + run tok = ([out], Ready) + where + out = Good $ f (optArgToString arg1) + arg1 = wordToOptArg tok + Just arg -> ([out], Ready) + where + out = Good $ f (optArgToString arg) + + Just (TwoArg f) -> ([], Pending opt g) + where + g gTok = case mayArg of + Just arg1 -> ([out], Ready) + where + out = Good $ f (optArgToString arg1) (optArgToString gArg) + Nothing -> ([], Pending opt h) + where + h hTok = ([out], Ready) + where + out = Good $ f (optArgToString gArg) + (optArgToString hArg) + hArg = wordToOptArg hTok + where + gArg = wordToOptArg gTok + + Just (ThreeArg f) -> ([], Pending opt g) + where + g gTok = ([], Pending opt h) + where + gArg = wordToOptArg gTok + h hTok = case mayArg of + Just arg1 -> ([out], Ready) + where + out = Good $ f (optArgToString arg1) (optArgToString gArg) + (optArgToString hArg) + Nothing -> ([], Pending opt i) + where + i iTok = ([out], Ready) + where + iArg = wordToOptArg iTok + out = Good $ f (optArgToString gArg) + (optArgToString hArg) + (optArgToString iArg) + where + hArg = wordToOptArg hTok + where + opt = OptName (Right inp) + +-- * end diff --git a/lib/Multiarg/Mode.hs b/lib/Multiarg/Mode.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Mode.hs @@ -0,0 +1,15 @@ +-- | Helps you build command-line parsers for programs that have more +-- than one so-called /mode/; examples of such programs include @git@, +-- @darcs@, and @ghc-pkg@. +module Multiarg.Mode + ( ArgSpec(..) + , OptSpec + , optSpec + , Mode + , mode + , ModeResult(..) + , parseModeLine + ) where + +import Multiarg.Mode.Internal +import Multiarg.Types diff --git a/lib/Multiarg/Mode/Internal.hs b/lib/Multiarg/Mode/Internal.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Mode/Internal.hs @@ -0,0 +1,254 @@ +-- | Internal functions used by "Multiarg.Mode". You don't have to +-- worry about \"breaking\" anything by using this module; it is +-- separate from "Multiarg.Mode" primarily to tidy up the +-- documentation in that module. The functions in "Multiarg.Mode" +-- should satisfy most use cases. However, if you want more control +-- over error handling, you can use this module. +module Multiarg.Mode.Internal where + +import Data.Either (partitionEithers) +import Multiarg.Maddash +import Multiarg.Internal +import Multiarg.Util +import Multiarg.Types +-- GHC 7.10 exports Word from the Prelude +import Prelude hiding (Word) + +newtype ModeName = ModeName String + deriving (Eq, Ord, Show) + +data ParsedMode a + = ModeGood a + | ModeError [OptionError] (Either OptionError OptName) + -- ^ There was an error. There may be zero or more initial + -- OptionError. There must be at least one error, which is either + -- an OptionError or the name of an option, if the error is that + -- there were not enough words following the option to provide it + -- with its necessary arguments. + deriving (Eq, Ord, Show) + +instance Functor ParsedMode where + fmap f (ModeGood a) = ModeGood (f a) + fmap _ (ModeError ls ei) = ModeError ls ei + +-- | A 'Mode' represents a single command line mode, such as @check@ +-- for @ghc-pkg check@. It contains the name of the mode, as well as +-- a parser that handles all /options/ and /positional arguments/ for +-- the mode. Ordinarily you will create a 'Mode' using the 'mode' +-- function rather than by using the constructor directly. +data Mode r = Mode ModeName ([Word] -> ParsedMode r) + +instance Functor Mode where + fmap f (Mode s p) = Mode s (fmap (fmap f) p) + +parsedCommandLineToParsedMode + :: ([a] -> r) + -> ParsedCommandLine a + -> ParsedMode r +parsedCommandLineToParsedMode fMode (ParsedCommandLine ls mayOpt) + = case mayOpt of + Nothing -> case mayLast errs of + Nothing -> ModeGood (fMode goods) + Just (errs1st, errsLst) -> ModeError errs1st (Left errsLst) + Just opt -> ModeError errs (Right opt) + where + (errs, goods) = partitionEithers ls + +-- | Creates a new 'Mode'. +mode + :: String + -- ^ Mode name. For instance, for the @check@ mode of @ghc-pkg@, + -- this would be @check@. + -> [OptSpec a] + -- ^ Mode /options/ + -> (String -> a) + -- ^ Parses /positional arguments/ + -> ([a] -> r) + -- ^ Processes the result of all mode /options/ + -> Mode r +mode name opts fPos fMode + = Mode (ModeName name) + $ parsedCommandLineToParsedMode fMode + . parseCommandLinePure opts fPos + . map (\(Word s) -> s) + +data GlobalLocalEnd a + = GlobalInsufficientOptArgs OptName + | ModeNotFound String [String] + | NoMode + | ModeFound (ParsedMode a) + deriving (Eq, Ord, Show) + +data GlobalLocal g r + = GlobalLocal [Either OptionError g] (GlobalLocalEnd r) + deriving (Eq, Ord, Show) + +-- | The result of parsing a mode command line. +data ModeResult g r + = ModeResult [g] (Either [String] r) + -- ^ @ModeResult a b@ is a successfully parsed mode command line, + -- where: + -- + -- @a@ is a list of all global options parsed; and + -- + -- @b@ indicates the result of parsing the mode. It is @Either c + -- d@, where @Left c@ indicates that no mode was parsed. This + -- arises under two circumstances. If the user did not include any + -- /words/ after the global /options/, then @c@ will be the empty + -- list, @[]@. If the user did include /words/ after the global + -- options, but the first /word/ was not recognized as a mode, then + -- this list will contain the first /word/ and any subsequent /words/. + -- Therefore, note that if the user attempted to use a mode that + -- does not exist (e.g. she misspelled it), this is not treated as + -- an error. It's up to the client code to deal with this issue + -- (for instance, your program might not view this situation as + -- being an error.) + -- + -- If @b@ is @Right d@, this indicates that the user entered a + -- recognized mode, and the result is @d@. + + deriving (Eq, Ord, Show) + +getModeResult + :: GlobalLocal g r + -> Either (String, [String]) (ModeResult g r) +getModeResult (GlobalLocal eis end) + = combine global (endToModeResult end) + where + (glblErrs, glblGoods) = partitionEithers eis + global = case glblErrs of + [] -> Right glblGoods + x:xs -> Left (x, xs) + +combine + :: Either (OptionError, [OptionError]) [g] + -- ^ Global result. Contains either one or more errors, or global + -- /option/ results. + + -> Either (String, [String]) (Either [String] r) + -- ^ Result of parsing mode /word/, and the mode /options/ and + -- /positional arguments/. May be @Left a@, where @a@ is one or + -- more errors, or @Right b@, where @b@ is a good result. A good + -- result @b@ may be either @Left c@, where @c@ is a list of + -- /positional arguments/, or @Right d@, where @d@ is the mode + -- result. @c@ indicates that no mode was recognized and may be + -- either @[]@, which indicates that the user passed no /words/ at + -- all after the global /options/, or @x:xs@, indicating that the + -- user did pass /words/ after the global /options/, but the first + -- /word/ was not recognized as a mode. + + -> Either (String, [String]) (ModeResult g r) +combine (Left (oe1, oes)) (Left (me1, mes)) = + Left ( globalOptErrorToString oe1 + , map globalOptErrorToString oes ++ (me1 : mes) ) +combine (Left (oe1, oes)) (Right _) = + Left (globalOptErrorToString oe1, map globalOptErrorToString oes) +combine (Right _) (Left (me1, mes)) = Left (me1, mes) +combine (Right glbls) (Right r) = + Right (ModeResult glbls r) + +endToModeResult + :: GlobalLocalEnd a + -> Either (String, [String]) (Either [String] a) +endToModeResult end = case end of + GlobalInsufficientOptArgs on -> Left + (labeledInsufficientOptArgs "global" on, []) + ModeNotFound s ss -> Right (Left $ s:ss) + NoMode -> Right (Left []) + ModeFound pm -> extractParsedMode pm + +extractParsedMode + :: ParsedMode a + -> Either (String, [String]) (Either b a) +extractParsedMode (ModeGood g) = Right . Right $ g +extractParsedMode (ModeError es lst) = Left $ case es of + [] -> (eiToError lst, []) + (x:xs) -> + ( modeOptErrorToString x + , (map modeOptErrorToString xs) ++ [eiToError lst] ) + +globalOptErrorToString :: OptionError -> String +globalOptErrorToString = optErrorToString "global" + +modeOptErrorToString :: OptionError -> String +modeOptErrorToString = optErrorToString "mode" + +optErrorToString :: String -> OptionError -> String +optErrorToString lbl oe = case oe of + BadOption opt -> + "unrecognized " ++ lbl ++ " option: " ++ optNameToString opt + LongArgumentForZeroArgumentOption lng arg -> + "argument given for " ++ lbl ++ " option that takes no arguments. " + ++ "option: --" ++ longNameToString lng + ++ " argument: " ++ optArgToString arg + + +eiToError :: Either OptionError OptName -> String +eiToError ei = case ei of + Left oe -> modeOptErrorToString oe + Right on -> labeledInsufficientOptArgs "mode" on + + +labeledInsufficientOptArgs :: String -> OptName -> String +labeledInsufficientOptArgs lbl on = "insufficient option arguments " + ++ "given for " ++ lbl ++ " option: " ++ optNameToString on + + +-- | Parses a command line that may contain modes. +parseModeLine + :: [OptSpec g] + -- ^ Global /options/. This might, for example, include a @--help@ + -- /option/. + -> [Mode r] + -- ^ All modes + -> [String] + -- ^ All command line /words/ + -> Either (String, [String]) (ModeResult g r) + -- ^ Returns @Either a b@. @Left a@ represents an error. Each + -- String represents a single error (this is returned as a pair + -- because there must be at least one error; a simple list would not + -- reflect this requirement.) + -- + -- @Right b@ indicates that parsing proceeded successfully; consult + -- 'ModeResult' to see what is returned. +parseModeLine glbl mds = + getModeResult + . parseModeLineWithErrors glbl mds + +parseModeLineWithErrors + :: [OptSpec g] + -- ^ Global options + -> [Mode r] + -- ^ All modes + -> [String] + -- ^ All command line tokens + -> GlobalLocal g r +parseModeLineWithErrors glbl mds tokStrings = GlobalLocal lsErrsGoods end + where + toks = map Word tokStrings + (shorts, longs) = splitOptSpecs glbl + (outs, eiOptTok) = processWords shorts longs toks + lsErrsGoods = map f . concat $ outs + where + f (Good a) = Right a + f (OptionError e) = Left e + end = case eiOptTok of + Left (opt, _) -> GlobalInsufficientOptArgs opt + Right [] -> NoMode + Right (x:xs) -> case findExactMode x mds of + Nothing -> ModeNotFound (unWord x) (map unWord xs) + where + unWord (Word t) = t + Just (Mode _ f) -> ModeFound (f xs) + +-- | Takes a token and a list of all modes; returns the matching mode +-- if there is one, or Nothing if there is no match. +findExactMode + :: Word + -> [Mode a] + -> Maybe (Mode a) +findExactMode _ [] = Nothing +findExactMode tok@(Word s) (m@(Mode (ModeName n) _) : ms) + | s == n = Just m + | otherwise = findExactMode tok ms + diff --git a/lib/Multiarg/Types.hs b/lib/Multiarg/Types.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Types.hs @@ -0,0 +1,185 @@ +-- | Types used throughout Multiarg, and associated functions. +-- Ordinarily you should not need this module; "Multiarg" and +-- "Multiarg.Mode" export all the types and constructors you should +-- ordinarily need. However, if you want more control than those +-- modules afford, you can import this one. +module Multiarg.Types + ( ArgSpec(..) + , OptSpec(..) + , optSpec + , ShortName + , shortNameToChar + , shortName + , LongName + , longNameToString + , longName + , Word(..) + , OptName(..) + , optNameToString + , OptArg(..) + , ShortTail(..) + , isLong + , isShort + , wordToOptArg + , splitShortTail + ) where + +-- GHC 7.10 incorporates 'Data.Word' into the Prelude, which clashes +-- with a binding below. +import Prelude hiding (Word) + +-- | Specifies how many /option arguments/ an /option/ takes. +data ArgSpec a + = ZeroArg a + -- ^ This /option/ takes no /option arguments/ + | OneArg (String -> a) + -- ^ This /option/ takes one /option argument/ + | TwoArg (String -> String -> a) + -- ^ This /option/ takes two /option arguments/ + | ThreeArg (String -> String -> String -> a) + -- ^ This /option/ takes three /option arguments/ + +instance Functor ArgSpec where + fmap f (ZeroArg a) = ZeroArg (f a) + fmap f (OneArg g) = OneArg $ \a -> f (g a) + fmap f (TwoArg g) = TwoArg $ \a b -> f (g a b) + fmap f (ThreeArg g) = ThreeArg $ \a b c -> f (g a b c) + +instance Show (ArgSpec a) where + show (ZeroArg _) = "ZeroArg" + show (OneArg _) = "OneArg" + show (TwoArg _) = "TwoArg" + show (ThreeArg _) = "ThreeArg" + +-- | Specifies an /option/. Typically you will use 'optSpec' to +-- create an 'OptSpec' rather than using the constructor directly. +-- Each 'OptSpec' may contain mulitple /short option names/ and +-- /long option names/; but each 'OptSpec' contains only one 'ArgSpec'. +-- Therefore, all /short option names/ and /long option names/ +-- specified in a single 'OptSpec' are synonymous. +data OptSpec a = OptSpec [ShortName] [LongName] (ArgSpec a) + deriving Show + +instance Functor OptSpec where + fmap f (OptSpec s l p) = OptSpec s l (fmap f p) + +-- | Creates an 'OptSpec'. +optSpec + :: [Char] + -- ^ There is one character for each desired /short option name/. + -- Each of these characters may not be a hyphen; otherwise, + -- 'optSpec' will apply 'error'. + + -> [String] + -- ^ There is one string for each desired /long option name/. Each + -- string: + -- + -- * cannot be empty; + -- + -- * must not begin with a hyphen; and + -- + -- * must not contain an equal sign. + -- + -- Otherwise, 'optSpec' will apply 'error'. + + -> ArgSpec a + -- ^ How many /option arguments/ this /option/ takes. This also + -- specifies what is returned when the /option/ is parsed on the + -- command line. + + -> OptSpec a +optSpec ss ls = OptSpec (map mkShort ss) (map mkLong ls) + where + mkShort s = case shortName s of + Nothing -> error $ "invalid short option name: " ++ [s] + Just n -> n + mkLong s = case longName s of + Nothing -> error $ "invalid long option name: " ++ s + Just n -> n + + +-- | A /short option name/. +newtype ShortName = ShortName { shortNameToChar :: Char } + deriving (Eq, Ord, Show) + +-- | A /long option name/. +newtype LongName = LongName { longNameToString :: String } + deriving (Eq, Ord, Show) + +-- | Creates a /short option name/. Any character other than a single +-- hyphen will succeed. +shortName :: Char -> Maybe ShortName +shortName '-' = Nothing +shortName x = Just $ ShortName x + +-- | Creates a /long option name/. The string may not be empty, and the +-- first character may not be a hyphen. In addition, no character may +-- be an equal sign. +longName :: String -> Maybe LongName +longName s = case s of + [] -> Nothing + '-':_ -> Nothing + xs | '=' `elem` xs -> Nothing + | otherwise -> Just $ LongName xs + +-- | The /name/ of an /option/ (either a /short option name/ +-- or a /long option name/). +newtype OptName = OptName (Either ShortName LongName) + deriving (Eq, Ord, Show) + +optNameToString :: OptName -> String +optNameToString (OptName ei) = case ei of + Left shrt -> '-' : shortNameToChar shrt : [] + Right lng -> "--" ++ longNameToString lng + +-- | A /word/ supplied by the user on the command line. +newtype Word = Word String + deriving (Eq, Ord, Show) + +-- | An /option argument/. +newtype OptArg = OptArg { optArgToString :: String } + deriving (Eq, Ord, Show) + +-- | Is this /word/ an input for a /long option/? +isLong + :: Word + -> Maybe (LongName, Maybe OptArg) + -- ^ Nothing if the option does not begin with a double dash and is + -- not at least three characters long. Otherwise, returns the + -- characters following the double dash to the left of any equal + -- sign. The Maybe in the tuple is Nothing if there is no equal + -- sign, or Just followed by characters following the equal sign if + -- there is one. +isLong (Word ('-':'-':[])) = Nothing +isLong (Word ('-':'-':xs)) = Just (LongName optName, arg) + where + (optName, end) = span (/= '=') xs + arg = case end of + [] -> Nothing + _:rs -> Just . OptArg $ rs +isLong _ = Nothing + +-- | Characters after the first /short option name/ in a /flag/ that +-- specifies a /short option/ instance, if the user supplies +-- @-afoobar@, then this will be @foobar@. +newtype ShortTail = ShortTail String + deriving (Eq, Ord, Show) + +-- | Is this an input /word/ for a /short argument/? +isShort + :: Word + -> Maybe (ShortName, ShortTail) +isShort (Word ('-':'-':_)) = Nothing +isShort (Word ('-':[])) = Nothing +isShort (Word ('-':x:xs)) = Just (ShortName x, ShortTail xs) +isShort _ = Nothing + +wordToOptArg :: Word -> OptArg +wordToOptArg (Word t) = OptArg t + +-- | If possible, splits a ShortTail into a /short option name/ and a +-- remaining tail. +splitShortTail :: ShortTail -> Maybe (ShortName, ShortTail) +splitShortTail (ShortTail s) = case s of + [] -> Nothing + x:xs -> Just (ShortName x, ShortTail xs) diff --git a/lib/Multiarg/Util.hs b/lib/Multiarg/Util.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Util.hs @@ -0,0 +1,34 @@ +-- | Grab bag of miscellaneous functions. +module Multiarg.Util where + +import Multiarg.Types + +-- | Returns a list of the first items in a list and the last item, or +-- Nothing if the list is empty. +mayLast :: [a] -> Maybe ([a], a) +mayLast [] = Nothing +mayLast xs = Just (init xs, last xs) + +-- | Partitions a list of 'OptSpec' into the short flags and long +-- flags. +splitOptSpecs + :: [OptSpec a] + -> ([(ShortName, ArgSpec a)], [(LongName, ArgSpec a)]) +splitOptSpecs = foldr f ([], []) + where + f (OptSpec so lo sp) (ss, ls) = (so' ++ ss, lo' ++ ls) + where + so' = map (\o -> (o, sp)) so + lo' = map (\o -> (o, sp)) lo + +-- | Adds an option for @h@ and @help@. The resulting 'ArgSpec' +-- return 'Nothing' if help was requested, or 'Just' with the original +-- argument for any other option. +addHelpOption + :: [OptSpec a] + -> ( [(ShortName, ArgSpec (Maybe a))] + , [(LongName, ArgSpec (Maybe a))] ) +addHelpOption os = splitOptSpecs os' + where + os' = optSpec "h" ["help"] (ZeroArg Nothing) : map (fmap Just) os + diff --git a/lib/Multiarg/Vocabulary.hs b/lib/Multiarg/Vocabulary.hs new file mode 100644 --- /dev/null +++ b/lib/Multiarg/Vocabulary.hs @@ -0,0 +1,94 @@ +-- | Vocabulary used throughout Multiarg. +-- +-- Each time one of these words is used in the documentation, it is +-- /italicized/ (or, if you are viewing the source code directly +-- rather than through Haddock, it is /surrounded by slashes/). +-- +-- [/word/] When you run your program from the Unix shell prompt, your +-- shell is responsible for splitting the command line into +-- /words/. Typically you separate /words/ with spaces, although +-- quoting can affect this. multiarg parses lists of /words/. Each +-- /word/ can consist of a single /long option/, a single /long option/ +-- and an accompanying /option argument/, a single /short option/, +-- multiple /short options/, and even one or more /short options/ +-- with the last /short option/ being accompanied by an +-- /option argument/. Or, a word can be a /positional argument/ or a +-- /stopper/. All these are described below. +-- +-- [/option/] /Options/ allow a user to specify ways to tune the +-- operation of a program. Typically /options/ are indeed optional, +-- although some programs do sport \"required options\" (a bit of an +-- oxymoron). /Options/ can be either /short options/ or /long options/. +-- Also, /options/ can take /option arguments/. +-- The option is specified on the command line with both the /flag/ +-- that specifies the option and of any /option arguments/ that are +-- included with the /option/. Therefore the /option/ might be +-- specified on the command line using one /word/ or multiple /words/, +-- and in the case of short /options/, multiple /options/ might be in +-- one /word/. +-- +-- [/short option/] An /option/ that is specified on the command line +-- using a /flag/ whose /word/ begins with a hyphen, and with a single +-- letter. For example, for the program @tail(1)@, possible short +-- options include @n@ and @v@. Multiarg will parse /words/ that +-- contain mulitple /short options/. For example, if a user wants to +-- run @tail@ with two options, he might type @tail -v -f@ or he might +-- type @tail -vf@. +-- +-- [/flag/] A /flag/ uniquely specifies an /option/. To specify an +-- /option/ on the command line, the user must present both a /flag/ +-- and any /option arguments/. In the case of a /long option/, the +-- /flag/ consists of one or more characters (typically a mnemonic +-- word), preceded by two hyphens. In the case of a /short option/, +-- the /flag/ consists of a single character, in a /word/ that begins +-- with a single hyphen; the /word/ might contain more than one /flag/ +-- for multiple /short options/. +-- +-- [/short option name/] A short option is specified on the command +-- line using a /flag/ and any /option arguments/. The /flag/ +-- contains the /short option name/, which is a single character. A +-- /short option name/ is never a single hyphen. +-- +-- [/long option name/] A long option is specified on the command line +-- using a /flag/ and any /option arguments/. The /flag/ begins with +-- two hyphens, followed by the /long option name/, which must be at +-- least one letter but typically is a mnemonic word. +-- +-- [/name/] Either a /short option name/ or /long option name/, as +-- appropriate. +-- +-- [/long option/] An option that is specified using two hyphens and +-- what is usually a mnemonic word, though it could be as short as a +-- single letter. For example, @tail(1)@ has long options including +-- @follow@ and @verbose@. The user would specify these on the command +-- line by typing @tail --follow --verbose@. A long option is +-- specified on the command line with a /flag/ and any /option arguments/. +-- +-- [/option argument/] An /option/ may take anywhere from zero to +-- three /option arguments/. When using a /short option/, the first +-- /option argument/ and the /flag/ may be contained in the same +-- /word/ by appending the /option argument/ immediately after the +-- /flag/ without an intervening space. When using a /long option/, +-- the first /option argument/ and the /flag/ may be contained in the +-- same word by separating the /flag/ and the /option argument with an +-- equal sign. In any case in which an /option argument/ and a /flag/ +-- are in the same /word/, the /option argument/ must be the last +-- thing to appear in the /word/. When using either /short options/ +-- or /long options/, the first /option argument/ may appear in the +-- same /word/ as the /flag/ or in the /word/ following the /flag/; +-- the second and third /option arguments/ (if applicable) must each +-- appear in its own /word/. +-- +-- [/positional argument/] A /word/ on the command line that does not +-- contain a /flag/, is not a /stopper/, and is not an /option argument/. +-- For instance, with @tail(1)@, you specify the files you +-- want to see by using /positional arguments/. In the command @tail -n 10 myfile@, +-- @myfile@ is a /positional argument/. +-- +-- [/stopper/] A /word/ consisting solely of two hyphens, +-- @--@. The user types this to indicate that all subsequent words +-- on the command line are /positional arguments/, even if they begin +-- with hyphens and therefore look like they might be /options/. + +module Multiarg.Vocabulary where + diff --git a/lib/System/Console/MultiArg.hs b/lib/System/Console/MultiArg.hs deleted file mode 100644 --- a/lib/System/Console/MultiArg.hs +++ /dev/null @@ -1,167 +0,0 @@ --- | A combinator library for building command-line parsers. - -module System.Console.MultiArg ( - - -- | To say this library is inspired by Parsec would probably insult the - -- creators of Parsec, as this library could not possibly be as - -- elegant or throughly considered as Parsec is. Nevertheless this - -- library can be used in a similar style as Parsec, but is - -- specialized for parsing command lines. - -- - -- This parser was built because I could not find anything that would - -- readily parse command lines where the options took more than one - -- argument. For example, for the @tail@ command on GNU systems, the - -- --lines option takes one argument to specify how many lines you - -- want to see. Well, what if you want to build a program with an - -- option that takes /two/ arguments, like @--foo bar baz@? I found no - -- such library so I built this one. Nevertheless, using this library - -- you can build parsers to parse a variety of command line - -- vocabularies, from simple to complex. - - -- * Terminology - - -- | Some terms are used throughout multiarg: - -- - -- [@word@] When you run your program from the Unix shell prompt, - -- your shell is responsible for splitting the command line into - -- words. Typically you separate words with spaces, although quoting - -- can affect this. multiarg parses lists of words. Each word can - -- consist of a single long option, a single long option and an - -- accompanying option argument, a single short option, multiple - -- short options, and even one or more multiple short options and an - -- accompanying short option argument. Or, a word can be a - -- positional argument or a stopper. All these are described below. - -- - -- [@option@] Options allow a user to specify ways to tune the - -- operation of a program. Typically options are indeed optional, - -- although some programs do sport \"required options\" (a bit of an - -- oxymoron). Options can be either short options or long - -- options. Also, options can take arguments. - -- - -- [@short option@] An option that is specified with a single hyphen - -- and a single letter. For example, for the program @tail(1)@, - -- possible short options include @n@ and @v@. With multiarg it is - -- possible to easily parse short options that are specified in - -- different words or in the same word. For example, if a user wants - -- to run @tail@ with two options, he might type @tail -v -f@ or he - -- might type @tail -vf@. - -- - -- [@long option@] An option that is specified using two hyphens and - -- what is usually a mnemonic word, though it could be as short as a - -- single letter. For example, @tail(1)@ has long options including - -- @follow@ and @verbose@. The user would specify these on the - -- command line by typing @tail --follow --verbose@. - -- - -- [@option argument@] Some options take additional arguments that - -- are specific to the option and change what the option does. For - -- instance, the @lines@ option to @tail(1)@ takes a single, - -- optional argument, which is the number of lines to show. Option - -- arguments can be optional or required, and a single option can - -- take a mulitple, fixed number of arguments and it can take a - -- variable number of arguments. Option arguments can be given in - -- various ways. They can be specified in the same word as a long - -- option by using an equals sign; they can also be specified in the - -- same word as a short option simply by placing them in the same - -- word, or they can be specified in the following word. For - -- example, these different command lines all mean the same thing; - -- @tail --verbose --lines=20@, @tail --verbose --lines 20@, @tail - -- -vn 20@, @tail -v -n20@, @tail -vn20@, and @tail -v -n 20@, and - -- numerous other combinations also have the same meaning. - -- - -- [@GNU-style option argument@] A long option with an argument - -- given with an equal sign, such as [@lines=20@]. - -- - -- [@positional argument@] A word on the command line that is not an - -- option or an argument to an option. For instance, with @tail(1)@, - -- you specify the files you want to see by using positional - -- arguments. In the command @tail -n 10 myfile@, @myfile@ is a - -- positional argument. For some programs, such as @git@ or @darcs@, - -- a positional argument might be a \"command\" or a \"mode\", such - -- as the @commit@ in @git commit@ or the @whatsnew@ in @darcs - -- whatsnew@. multiarg has no primitive parsers that treat these - -- positional arguments specially but it is trivial to build a - -- parser for command lines such as this, too. - -- - -- [@stopper@] A single word consisting solely of two hyphens, - -- @--@. The user types this to indicate that all subsequent words - -- on the command line are positional arguments, even if they begin - -- with hyphens and therefore look like they might be options. - -- - -- [@pending@] The user might specify more than one short option, or - -- a short option and a short option argument, in a single word. For - -- example, she might type @tail -vl20@. After parsing the @v@ - -- option, the Parser makes @l20@ into a \"pending\". The next - -- parser can then treat @l20@ as an option argument to the @v@ - -- option (which is probably not what was wanted) or the next parser - -- can parse @l@ as a short option. This would result in a - -- \"pending\" of @20@. Then, the next parser can treat @20@ as an - -- option argument. After that parse there will be no pendings. - - -- * Getting started - - -- |If your needs are simple to moderately complicated just look at the - -- "System.Console.MultiArg.CommandLine" module, which uses the - -- underlying combinators to build a simple parser for you. That - -- module is already exported from this module for easy usage. - -- - -- "System.Console.MultiArg.CommandLine" also has a parser that can - -- handle multi-mode commands (examples include @git@, @darcs@, and - -- @cvs@.) - -- - -- For maximum flexibility you will want to start with the - -- "System.Console.MultiArg.Prim" module. Using those parsers you - -- can easily build parsers that are quite complicated. The parsers - -- can check for errors along the way, simplifying the sometimes - -- complex task of ensuring that data a user supplied on the command - -- line is good. You can easily build parsers for programs that take - -- no options, take dozens of options, require that options be given - -- in a particular order, require that some options be given, or bar - -- some combinations of options. You might also require particular - -- positional arguments. Other helpful functions are in - -- "System.Console.MultiArg.Combinator". You will also want to - -- examine the source code for "System.Console.MultiArg.Combinator" - -- and "System.Console.MultiArg.CommandLine" as these show some - -- ways to use the primitive parsers and combinators. - - -- * Non-features and shortcomings - -- - -- | multiarg isn't perfect; no software is. multiarg does not - -- automatically make online help for your command line - -- parsers. Getting this right would be tricky given the nature of - -- the code and I don't even want to bother trying, as I just write - -- my own online help in a text editor. - -- - -- multiarg partially embraces \"The Tao of Option Parsing\" that - -- Python's Optik () follows. Read - -- \"The Tao of Option Parsing\" here: - -- - -- - -- - -- multiarg's philosophy is similar to that of Optik, which - -- means you won't be able to use multiarg to (easily) build a clone - -- to the UNIX @find(1)@ command. (You could do it, but multiarg won't - -- help you very much.) - -- - -- multiarg can be complicated, although I'd like to believe this is - -- because it addresses a complicated problem in a flexible way. - - -- * Projects usings multiarg - - -- | * Penny, an extensible double-entry accounting - -- system. The code - -- using multiarg is woven throughout the system; for example, see - -- the Penny.Liberty module. - - - module System.Console.MultiArg.Combinator - , module System.Console.MultiArg.CommandLine - , module System.Console.MultiArg.Option - , module System.Console.MultiArg.Prim - , module System.Environment - ) where - -import System.Console.MultiArg.Combinator -import System.Console.MultiArg.CommandLine -import System.Console.MultiArg.Option -import System.Console.MultiArg.Prim -import System.Environment diff --git a/lib/System/Console/MultiArg/Combinator.hs b/lib/System/Console/MultiArg/Combinator.hs deleted file mode 100644 --- a/lib/System/Console/MultiArg/Combinator.hs +++ /dev/null @@ -1,478 +0,0 @@ --- | Combinators that are useful for building command-line --- parsers. These build off the functions in --- "System.Console.MultiArg.Prim". Unlike those functions, these --- functions have no access to the internals of the parser. -module System.Console.MultiArg.Combinator ( - -- * Parser combinators - notFollowedBy, - - -- * Combined long and short option parser - OptSpec(OptSpec, longOpts, shortOpts, argSpec), - InputError(..), - reader, - optReader, - ArgSpec(..), - parseOption, - - -- * Formatting errors - formatError - ) where - -import Data.List (isPrefixOf, intersperse, nubBy) -import Data.Set ( Set ) -import qualified Data.Set as Set -import Control.Applicative - ((<*>), optional, (<$), (*>), (<|>), many) - -import System.Console.MultiArg.Prim - ( Parser, try, approxLongOpt, - nextWord, pendingShortOptArg, nonOptionPosArg, - pendingShortOpt, nonPendingShortOpt, nextWord, (), - Error(..), Description(..)) -import System.Console.MultiArg.Option - ( LongOpt, ShortOpt, unLongOpt, - makeLongOpt, makeShortOpt, unShortOpt ) -import qualified Data.Map as M -import Data.Map ((!)) -import Data.Maybe (fromMaybe, mapMaybe) -import Data.Monoid ( mconcat ) - - --- | @notFollowedBy p@ succeeds only if parser p fails. If p fails, --- notFollowedBy succeeds without consuming any input. If p succeeds --- and consumes input, notFollowedBy fails and consumes input. If p --- succeeds and does not consume any input, notFollowedBy fails and --- does not consume any input. -notFollowedBy :: Parser a -> Parser () -notFollowedBy p = - () <$ ((try p >> fail "notFollowedBy failed") - <|> return ()) - - -unsafeShortOpt :: Char -> ShortOpt -unsafeShortOpt c = - fromMaybe (error $ "invalid short option: " ++ [c]) - (makeShortOpt c) - -unsafeLongOpt :: String -> LongOpt -unsafeLongOpt c = - fromMaybe (error $ "invalid long option: " ++ c) - (makeLongOpt c) - - --- |Specifies options for the 'parseOption' function. Each OptSpec --- represents one command-line option. -data OptSpec a = OptSpec { - longOpts :: [String] - -- ^ Each String is a single long option, such as @version@. When - -- the user specifies long options on the command line, she must - -- type two dashes; however, do not include the dashes when you - -- specify the long option here. Strings you specify as long options - -- cannot include a dash as either the first or the second - -- character, and they cannot include an equal sign anywhere. If - -- your long option does not meet these conditions, a runtime error - -- will occur. - - - , shortOpts :: [Char] - -- ^ Each Char is a single short option, such as @v@. The - -- character cannot be a dash; if it is, a runtime error will occur. - - , argSpec :: ArgSpec a - -- ^ What to do each time one of the given long options or - -- short options appears on the command line. - } - -instance Functor OptSpec where - fmap f (OptSpec ls ss as) = OptSpec ls ss (fmap f as) - --- | Reads in values that are members of Read. Provides a generic --- error message if the read fails. -reader :: Read a => String -> Either InputError a -reader s = case reads s of - (x, ""):[] -> return x - _ -> Left . ErrorMsg $ "could not parse option argument" - --- | Reads in values that are members of Read, but the value does not --- have to appear on the command line. Provides a generic error --- message if the read fails. If the argument is Nothing, returns --- Nothing. -optReader - :: Read a - => Maybe String - -> Either InputError (Maybe a) -optReader ms = case ms of - Nothing -> return Nothing - Just s -> case reads s of - (x, ""):[] -> return (Just x) - _ -> Left . ErrorMsg $ "could not parse option argument" - --- | Indicates errors when parsing options to arguments. -data InputError - = NoMsg - -- ^ No error message accompanies this failure. multiarg will create - -- a generic error message for you. - - | ErrorMsg String - -- ^ Parsing the argument failed with this error message. An example - -- might be @option argument is not an integer@ or @option argument - -- is too large@. The text of the options the user provided is - -- automatically prepended to the error message, so do not replicate - -- this in your message. - - deriving (Eq, Show) - --- | Create an error message from an InputError. -errorMsg - :: Either LongOpt ShortOpt - -- ^ The option with the faulty argument - - -> [String] - -- ^ The faulty command line arguments - - -> InputError - -> String -errorMsg badOpt ss err = arg ++ opt ++ msg - where - arg = let aw = if length ss > 1 then "arguments " else "argument " - ws = concat . intersperse " " . map quote $ ss - quote s = "\"" ++ s ++ "\"" - in aw ++ ws - opt = " to option " ++ optDesc - optDesc = case badOpt of - Left lo -> "--" ++ unLongOpt lo - Right so -> "-" ++ [unShortOpt so] - msg = " invalid" ++ detail - detail = case err of - NoMsg -> "" - ErrorMsg s -> ": " ++ s - - - --- | Specifies how many arguments each option takes. As with --- 'System.Console.GetOpt.ArgDescr', there are (at least) two ways to --- use this type. You can simply represent each possible option using --- different data constructors in an algebraic data type. Or you can --- have each ArgSpec yield a function that transforms a record. For an --- example that uses an algebraic data type, see --- "System.Console.MultiArg.SampleParser". --- --- Most of these value constructors take as an argument a function --- that returns an Either. The function should return a @Left --- InputError@ if the parsing of the arguments failed--if, for --- example, the user needs to enter an integer but she instead input a --- letter. The functions should return a Right if parsing of the --- arguments was successful. -data ArgSpec a = - NoArg a - -- ^ This option takes no arguments - - | OptionalArg (Maybe String -> Either InputError a) - -- ^ This option takes an optional argument. As noted in \"The Tao - -- of Option Parsing\", optional arguments can result in some - -- ambiguity. (Read it here: - -- ) If option @a@ - -- takes an optional argument, and @b@ is also an option, what - -- does @-ab@ mean? SimpleParser resolves this ambiguity by - -- assuming that @b@ is an argument to @a@. If the user does not - -- like this, she can specify @-a -b@ (in such an instance @-b@ is - -- not parsed as an option to @-a@, because @-b@ begins with a - -- hyphen and therefore \"looks like\" an option.) Certainly - -- though, optional arguments lead to ambiguity, so if you don't - -- like it, don't use them :) - - | OneArg (String -> Either InputError a) - -- ^ This option takes one argument. Here, if option @a@ takes one - -- argument, @-a -b@ will be parsed with @-b@ being an argument to - -- option @a@, even though @-b@ starts with a hyphen and therefore - -- \"looks like\" an option. - - | TwoArg (String -> String -> Either InputError a) - -- ^ This option takes two arguments. Parsed similarly to - -- 'OneArg'. - - | ThreeArg (String -> String -> String -> Either InputError a) - -- ^ This option takes three arguments. Parsed similarly to - -- 'OneArg'. - - | VariableArg ([String] -> Either InputError a) - -- ^ This option takes a variable number of arguments--zero or - -- more. Option arguments continue until the command line contains - -- a word that begins with a hyphen. For example, if option @a@ - -- takes a variable number of arguments, then @-a one two three - -- -b@ will be parsed as @a@ taking three arguments, and @-a -b@ - -- will be parsed as @a@ taking no arguments. If the user enters - -- @-a@ as the last option on the command line, then the only way - -- to indicate the end of arguments for @a@ and the beginning of - -- positional argments is with a stopper. - - | ChoiceArg [(String, a)] - -- ^ This option takes a single argument, which must match one of - -- the strings given in the list. The user may supply the shortest - -- unambiguous string. If the argument list to ChoiceArg has - -- duplicate strings, only the first string is used. For instance, - -- ChoiceArg could be useful if you were parsing the @--color@ - -- option to GNU grep, which requires the user to supply one of - -- three arguments: @always@, @never@, or @auto@. - - -instance Functor ArgSpec where - fmap f a = case a of - NoArg i -> NoArg $ f i - ChoiceArg gs -> - ChoiceArg . map (\(s, r) -> (s, f r)) $ gs - - OptionalArg g -> OptionalArg $ \ms -> fmap f (g ms) - - OneArg g -> - OneArg $ \s1 -> fmap f (g s1) - - TwoArg g -> - TwoArg $ \s1 s2 -> fmap f (g s1 s2) - - ThreeArg g -> - ThreeArg $ \s1 s2 s3 -> fmap f (g s1 s2 s3) - - VariableArg g -> - VariableArg $ \ls -> fmap f (g ls) - - --- | Parses a single command line option. Examines all the options --- specified using multiple OptSpec and parses one option on the --- command line accordingly. Fails without consuming any input if the --- next word on the command line is not a recognized option. Allows --- the user to specify the shortest unambiguous match for long --- options; for example, the user could type @--verb@ for @--verbose@ --- and @--vers@ for @--version@. --- --- This function is applied to a list of OptSpec, rather than to a --- single OptSpec, because in order to correctly handle the parsing of --- shortened long options (e.g. @--verb@ rather than @--verbose@) it --- is necessary for one function to have access to all of the --- OptSpec. Applying this function multiple times to different lists --- of OptSpec and then using the @<|>@ function to combine them will --- break the proper parsing of shortened long options. --- --- For an example that uses this function, see --- "System.Console.MultiArg.SimpleParser". -parseOption :: [OptSpec a] -> Parser a -parseOption os = - let longs = longOptParser os - in case mconcat ([shortOpt] <*> os) of - Nothing -> longs - Just shorts -> longs <|> shorts - -longOptParser :: [OptSpec a] -> Parser a -longOptParser os = longOpt (longOptSet os) (longOptMap os) - - -longOptSet :: [OptSpec a] -> Set LongOpt -longOptSet = Set.fromList . concatMap toOpts where - toOpts = map unsafeLongOpt . longOpts - -longOptMap :: [OptSpec a] -> M.Map LongOpt (ArgSpec a) -longOptMap = M.fromList . concatMap toPairs where - toPairs (OptSpec los _ as) = map (toPair as) los where - toPair a s = (unsafeLongOpt s, a) - -longOpt :: - Set LongOpt - -> M.Map LongOpt (ArgSpec a) - -> Parser a -longOpt set mp = do - (_, lo, maybeArg) <- approxLongOpt set - let spec = mp ! lo - maybeNextArg = maybe nextWord return maybeArg - case spec of - NoArg a -> case maybeArg of - Nothing -> return a - Just _ -> fail $ "option " ++ unLongOpt lo - ++ " does not take argument" - ChoiceArg ls -> do - s <- maybeNextArg - case matchAbbrev ls s of - Nothing -> fail $ "option " ++ unLongOpt lo - ++ " requires an argument: " - ++ (concat . intersperse ", " . map fst $ ls) - Just g -> return g - - OptionalArg f -> case maybeArg of - Nothing -> either (fail . errorMsg (Left lo) []) return - $ f Nothing - Just s -> either (fail . errorMsg (Left lo) [s]) return - $ f (Just s) - - - OneArg f -> maybeNextArg >>= g - where - g a = either (fail . errorMsg (Left lo) [a]) return - $ f a - - TwoArg f -> do - a1 <- maybeNextArg - a2 <- nextWord - either (fail . errorMsg (Left lo) [a1, a2]) return - $ f a1 a2 - - ThreeArg f -> do - a1 <- maybeNextArg - a2 <- nextWord - a3 <- nextWord - either (fail . errorMsg (Left lo) [a1, a2, a3]) return - $ f a1 a2 a3 - - VariableArg f -> do - as <- many nonOptionPosArg - let args = case maybeArg of - Nothing -> as - Just a -> a:as - either (fail . errorMsg (Left lo) args) return - $ f args - - -shortOpt :: OptSpec a -> Maybe (Parser a) -shortOpt o = mconcat parsers where - parsers = map mkParser . shortOpts $ o - mkParser c = - let opt = unsafeShortOpt c - in Just $ nextShort opt *> case argSpec o of - NoArg a -> return a - ChoiceArg ls -> shortChoiceArg opt ls - OptionalArg f -> shortOptionalArg opt f - OneArg f -> shortOneArg opt f - TwoArg f -> shortTwoArg opt f - ThreeArg f -> shortThreeArg opt f - VariableArg f -> shortVariableArg opt f - --- | Parses a short option without an argument, either pending or --- non-pending. Fails with a single error message rather than two. -nextShort :: ShortOpt -> Parser () -nextShort o = p ("short option: -" ++ [unShortOpt o]) - where - p = do - r1 <- optional $ pendingShortOpt o - case r1 of - Just () -> return () - Nothing -> nonPendingShortOpt o - - -shortVariableArg - :: ShortOpt - -> ([String] -> Either InputError a) - -> Parser a -shortVariableArg so f = do - maybeSameWordArg <- optional pendingShortOptArg - args <- many nonOptionPosArg - let as = case maybeSameWordArg of - Nothing -> args - Just a -> a:args - either (fail . errorMsg (Right so) as) return $ f as - - -shortOneArg - :: ShortOpt - -> (String -> Either InputError a) - -> Parser a -shortOneArg so f = do - a <- firstShortArg - either (fail . errorMsg (Right so) [a]) return $ f a - -firstShortArg :: Parser String -firstShortArg = - optional pendingShortOptArg >>= maybe nextWord return - - -shortChoiceArg :: ShortOpt -> [(String, a)] -> Parser a -shortChoiceArg opt ls = - firstShortArg - >>= maybe err return . matchAbbrev ls - where - err = fail $ "option " ++ [unShortOpt opt] ++ " requires " - ++ "one argument: " - ++ (concat . intersperse " " . map fst $ ls) - - -shortTwoArg - :: ShortOpt - -> (String -> String -> Either InputError a) - -> Parser a -shortTwoArg so f = do - a1 <- firstShortArg - a2 <- nextWord - either (fail . errorMsg (Right so) [a1, a2]) return - $ f a1 a2 - - -shortThreeArg - :: ShortOpt - -> (String -> String -> String -> Either InputError a) - -> Parser a -shortThreeArg so f = do - a1 <- firstShortArg - a2 <- nextWord - a3 <- nextWord - either (fail . errorMsg (Right so) [a1, a2, a3]) return - $ f a1 a2 a3 - -shortOptionalArg - :: ShortOpt - -> (Maybe String -> Either InputError a) - -> Parser a -shortOptionalArg so f = do - maybeSameWordArg <- optional pendingShortOptArg - case maybeSameWordArg of - Nothing -> do - maybeArg <- optional nonOptionPosArg - case maybeArg of - Nothing -> either (fail . errorMsg (Right so) []) return - $ f Nothing - Just a -> either (fail . errorMsg (Right so) [a]) return - $ f (Just a) - Just a -> either (fail . errorMsg (Right so) [a]) return - $ f (Just a) - - - --- | Finds the unambiguous short match for a string, if there is --- one. Returns a string describing the error condition if there is --- one, or the matching result if successful. -matchAbbrev :: [(String, a)] -> String -> Maybe a -matchAbbrev ls s = - let ls' = nubBy (\x y -> fst x == fst y) ls - in case lookup s ls' of - Just a -> return a - Nothing -> - let pdct (t, _) = s `isPrefixOf` t - in case filter pdct ls of - (_, a):[] -> return a - _ -> Nothing - --- | Formats error messages for nice display. Returns a multi-line --- string (there is no need to append a newline to the end of the --- string returned). -formatError - :: String - -- ^ Pass the name of your program here. Displayed at the beginning - -- of the error message. - - -> Error - -> String -formatError p (Error loc ls) = - p ++ ": error: could not parse command line.\n" - ++ "Error at: " ++ loc ++ "\n" - ++ expError - ++ genError - ++ unk - where - toExp m = case m of { Expected s -> Just s; _ -> Nothing } - expc = unlines . mapMaybe toExp $ ls - expError = if null expc then "" else "Expecting:\n" ++ expc - toGeneral m = case m of { General s -> Just s; _ -> Nothing } - gen = unlines . mapMaybe toGeneral $ ls - genError = if null gen - then "" - else let sep = if null expError - then "" else "\n" - in sep ++ gen - unk = if any (== Unknown) ls then "Unknown error\n" else "" - diff --git a/lib/System/Console/MultiArg/CommandLine.hs b/lib/System/Console/MultiArg/CommandLine.hs deleted file mode 100644 --- a/lib/System/Console/MultiArg/CommandLine.hs +++ /dev/null @@ -1,536 +0,0 @@ -{-# LANGUAGE ExistentialQuantification #-} --- | Some pre-built command line parsers. One is a simple command line --- parser that can parse options that take an optional argument, one --- or two arguments, or a variable number of arguments. For sample --- code that uses this parser, see --- "System.Console.MultiArg.SampleParser". --- --- Another parser is provided for multi-mode programs that are similar --- to @git@ or @darcs@. --- --- Previously there was a bug in System.Environment.getArgs that would --- not properly encode Unicode command line arguments. multiarg used --- to provide its own GetArgs module to deal with this. This bug was --- in base 4.3.1.0, which was bundled with ghc 7.0.4. This bug was --- fixed in base 4.4.0.0, which came with ghc 7.2. Since this bug has --- been fixed for awhile, multiarg no longer has its own GetArgs --- module. -module System.Console.MultiArg.CommandLine ( - -- * Interspersion control - Intersperse (Intersperse, StopOptions) - - -- * Types - , ProgName - , Opts(..) - , OptsWithPosArgs(..) - , Mode(..) - - -- * Simple parsers - , simplePure - , simpleIO - , simpleHelp - , simpleHelpVersion - - -- * Mode parsers - , modesPure - , modesIO - - -- * Helpers to create various options and modes - , optsHelp - , optsHelpVersion - , modeHelp - - ) where - -import qualified System.Console.MultiArg.Combinator as C -import qualified System.Console.MultiArg.Prim as P -import System.Environment (getArgs, getProgName) -import System.Exit (exitFailure, exitSuccess) -import qualified System.IO as IO -import Control.Applicative ( many, (<|>), optional, - (<$), (<*>), (<*), (<$>)) -import Data.Bifunctor -import Data.List (find) -import Data.Maybe (catMaybes, fromJust) -import qualified Data.Set as Set - - --- | What to do after encountering the first non-option, --- non-option-argument word on the command line? In either case, no --- more options are parsed after a stopper. -data Intersperse = - Intersperse - -- ^ Additional options are allowed on the command line after - -- encountering the first positional argument. For example, if @a@ - -- and @b@ are options, in the command line @-a posarg -b@, @b@ will - -- be parsed as an option. If @b@ is /not/ an option and the same - -- command line is entered, then @-b@ will result in an error - -- because @-b@ starts with a hyphen and therefore \"looks like\" an - -- option. - - | StopOptions - -- ^ No additional options will be parsed after encountering the - -- first positional argument. For example, if @a@ and @b@ are - -- options, in the command line @-a posarg -b@, @b@ will be parsed - -- as a positional argument rather than as an option. - - --- | Specifies a set of options. -data Opts s a = Opts - { oShortcuts :: [C.OptSpec s] - -- ^ Shortcut options are commonly options such as @--help@ or - -- @--version@. Such options must be specified alone on the command - -- line. The parser looks for one of these options first. If it - -- finds one and it is the only option on the command line, only - -- this option is processed and returned. If the option is not - -- alone on the command line, an error occurs. If no shortcut - -- option is found, the parser processes non-shortcut options - -- instead. - - , oOptions :: [C.OptSpec a] - -- ^ If the user does not specify any shortcut options, she may - -- specify any number of these options. - - } - -instance Bifunctor Opts where - bimap fa fc o = Opts - { oShortcuts = map (fmap fa) . oShortcuts $ o - , oOptions = map (fmap fc) . oOptions $ o - } - -instance Functor (Opts a) where - fmap f o = o { oOptions = fmap (fmap f) . oOptions $ o } - --- | Creates an Opts with a help shortcut option. -optsHelp - :: h - -- ^ Whatever type you wish to use for help - -> [C.OptSpec a] - -> Opts h a -optsHelp h = Opts [C.OptSpec ["help"] "h" (C.NoArg h)] - --- | Creates an Opts with help and version shortcut options. -optsHelpVersion - :: h - -- ^ What you wish to use for help - - -> h - -- ^ What you wish to use for version - - -> [C.OptSpec a] - -> Opts h a -optsHelpVersion h v = Opts [ C.OptSpec ["help"] "h" (C.NoArg h) - , C.OptSpec ["version"] "v" (C.NoArg v) ] - --- | Specification for both options and positional arguments. -data OptsWithPosArgs s a = OptsWithPosArgs - { opOpts :: Opts s a - , opIntersperse :: Intersperse - , opPosArg :: String -> Either C.InputError a - } - -instance Bifunctor OptsWithPosArgs where - bimap fa fc o = OptsWithPosArgs - { opOpts = bimap fa fc . opOpts $ o - , opIntersperse = opIntersperse o - , opPosArg = fmap (fmap fc) . opPosArg $ o - } - -instance Functor (OptsWithPosArgs s) where - fmap f o = o - { opOpts = fmap f . opOpts $ o - , opPosArg = fmap (fmap f) . opPosArg $ o - } - --- | Specifies a mode. -data Mode s r = forall a. Mode - { mModeName :: String - -- ^ How the user specifies the mode on the command line. For @git@ - -- for example this might be @commit@ or @log@. - - , mGetResult :: [a] -> r - -- ^ This function is applied to a list of the results of parsing the - -- options that are specific to this mode. The function returns a - -- type of your choosing (though all modes in the same parser will - -- have to return the same type.) - - , mOpts :: OptsWithPosArgs s a - -- ^ Options and positional arguments that are specific to this - -- mode. For example, in the command line @git commit -a -m 'this - -- is a log message'@, @commit@ is the mode name and everything - -- after that is specified here as an option or positional argument - -- that is specific to this mode. - } - -instance Bifunctor Mode where - bimap fa fc (Mode n r o) = Mode - { mModeName = n - , mGetResult = fmap fc r - , mOpts = first fa o - } - -instance Functor (Mode s) where - fmap f (Mode n gr os) = Mode n (fmap f gr) os - --- | Creates a Mode with a help option (help specific to the mode.) -modeHelp - :: String - -- ^ Mode name - - -> h - -- ^ Whatever you want to use for the help (perhaps a string, or a - -- function, or an IO action). Its type will have to match up with - -- the type of the global shortcut options and with the shortcut - -- type of the other modes. - - -> ([a] -> r) - -- ^ When applied to the the mode options, returns the result. - - -> [C.OptSpec a] - -- ^ Options for this mode - - -> Intersperse - -- ^ Allow interspersion of mode options and positional arguments? - - -> (String -> Either C.InputError a) - -- ^ Parses positional arguments - - -> Mode h r - -modeHelp n h getR os i p = - Mode n getR (OptsWithPosArgs (Opts ss os) i p) - where - ss = [C.OptSpec ["help"] "h" (C.NoArg h)] - -parseOpts :: Opts s a -> P.Parser (Either s [a]) -parseOpts os = do - let specials = oShortcuts os - maySpecial <- optional (C.parseOption specials <* P.end) - case maySpecial of - Nothing -> fmap Right - $ P.manyTill (C.parseOption (oOptions os)) endOrNonOpt - Just spec -> return . Left $ spec - -parseOptsWithPosArgs - :: OptsWithPosArgs s a - -> P.Parser (Either s [a]) -parseOptsWithPosArgs os = do - let specials = oShortcuts . opOpts $ os - maySpecial <- optional (C.parseOption specials <* P.end) - case maySpecial of - Nothing -> - let f = case opIntersperse os of - Intersperse -> parseIntersperse - StopOptions -> parseStopOpts - parser = C.parseOption (oOptions . opOpts $ os) - in fmap Right $ f parser (opPosArg os) - Just spec -> return . Left $ spec - -parseModes - :: [Mode s r] - -> P.Parser (Either s r) -parseModes ms = do - let modeWords = Set.fromList . map mModeName $ ms - (_, w) <- P.matchApproxWord modeWords - processMode (fromJust . find (\c -> mModeName c == w) $ ms) - where - processMode (Mode _ gr os) = do - eiOpts <- parseOptsWithPosArgs os - return $ case eiOpts of - Left x -> Left x - Right opts -> Right (gr opts) - - --- | A pure (non-IO) parser for simple command lines--that is, command --- lines that do not have modes. -simplePure - :: OptsWithPosArgs s a - -- ^ Specifies allowed regular options, allowed shortcut options, - -- and how to parse positional arguments. Also specifies whether - -- the user may intersperse options with positional arguments. - - -> [String] - -- ^ The command line arguments to parse - - -> Either P.Error (Either s [a]) - -- ^ Returns an error if the command line arguments could not be - -- parsed. If the parse was successful, returns an Either. A Left - -- indicates that the user selected a shortcut option. A Right - -- indicates that the user did not specify a shortcut option, and - -- will contain a list of the options and positional arguments. -simplePure os ss = P.parse ss (parseOptsWithPosArgs os) - --- | A pure (non-IO) parser for command lines that contain modes. -modesPure - :: Opts s g - -- ^ Global options. These are specified before any mode. For - -- instance, in the command @git --no-pager commit -a@, the option - -- @--no-pager@ is a global option. Global options can contain - -- shortcut options. For instance, @git --help@ contains a single - -- shortcut option. - - -> ([g] -> Either String (Either r [Mode s r])) - -- ^ This function processes the global options. If there are no - -- shortcut options specified in the global options, it is applied - -- to the result of processing the global options. This function - -- may return a Left if there is something wrong with the - -- global options (a nonsensical combination, perhaps.) Otherwise, - -- it returns a @Right Either@. Return a Left if there is no need to - -- process any modes at all after seeing the global options. - -- Otherwise, return a Right with a list of modes. - - -> [String] - -- ^ Command line arguments to parse - - -> Either P.Error (Either s r) - -- ^ If the command line arguments fail to parse, this will be a - -- Left with the error. If the parser is successful, this - -- returns a @Right Either@. A Left indicates that the user entered a - -- shortcut option, either in the global options or in one of the - -- mode-specific options. A Right indicates that the user selected - -- a mode. -modesPure os process ss = P.parse ss p - where - p = do - eiGs <- parseOpts os - case eiGs of - Left spec -> return . Left $ spec - Right gs -> case process gs of - Left s -> fail s - Right eiModes -> case eiModes of - Left r -> return (Right r) - Right modes -> parseModes modes - --- | A parser for simple command lines that do not contain modes. --- Runs in the IO monad. -simpleIO - :: [C.OptSpec a] - -- ^ Options to parse - - -> Intersperse - -- ^ Allow interspersion of options and arguments? - - -> (String -> Either C.InputError a) - -- ^ How to parse positional arguments - - -> IO [a] - -- ^ If there is an error parsing the command line, the program will - -- exit with an error message. If successful the results are - -- returned here. -simpleIO os i getArg = do - let optsWithArgs = OptsWithPosArgs (Opts os []) i getArg - ss <- getArgs - case simplePure optsWithArgs ss of - Left e -> errorAct e - Right g -> case g of - Left _ -> - error "simpleIO: should never happen: no shortcut options" - Right gs -> return gs - -simpleIOCustomError - :: (P.Error -> IO ()) - -> OptsWithPosArgs s a - -> IO (Either s [a]) -simpleIOCustomError showErr os = do - ss <- getArgs - case simplePure os ss of - Left e -> showErr e >> exitFailure - Right g -> return g - - --- | A command line parser for multi-mode command lines. Runs in the --- IO monad. -modesIO - :: Opts s g - -- ^ Specifies global options and global shortcut options - - -> ([g] -> Either String (Either r [Mode s r])) - -- ^ This function processes the global options. If there are no - -- shortcut options specified in the global options, it is applied - -- to the result of processing the global options. This function - -- may return a Left if there is something wrong with the - -- global options (a nonsensical combination, perhaps.) Otherwise, - -- it returns a @Right Either@. Return a Left if there is no need to - -- process any modes at all after seeing the global options. - -- Otherwise, return a Right with a list of modes. - - -> IO (Either s r) - -- ^ If parsing fails, the program will exit with a failure. If - -- successful, the result is returned here. A Left indicates a - -- shortcut option, either from the global options or from the - -- mode-specific options; a Right indicates the mode a user - -- selected. -modesIO os ms = do - ss <- getArgs - case modesPure os ms ss of - Left e -> errorAct e - Right g -> return g - - --- | The name of the program that was entered on the command line, --- obtained from System.Environment.getProgName. -type ProgName = String - -displayAct :: (ProgName -> String) -> IO a -displayAct getHelp = do - pn <- getProgName - putStr $ getHelp pn - exitSuccess - -errorAct :: P.Error -> IO a -errorAct e = do - pn <- getProgName - IO.hPutStr IO.stderr $ C.formatError pn e - exitFailure - -errorActDisplayHelp :: P.Error -> IO a -errorActDisplayHelp e = do - pn <- getProgName - IO.hPutStr IO.stderr $ C.formatError pn e - IO.hPutStrLn IO.stderr $ "enter \"" ++ pn ++ " -h\" for help." - exitFailure - --- | A parser for simple command lines. Adds a @--help@ option for --- you. -simpleHelp - :: (ProgName -> String) - -- ^ Indicate the help here. This function, when applied to the name - -- of the program, returns help. simpleHelp automatically adds - -- options for @--help@ and @-h@ for you. - - -> [C.OptSpec a] - -- ^ Options to parse - - -> Intersperse - -- ^ Allow interspersion of options and positional arguments? - - -> (String -> Either C.InputError a) - -- ^ How to parse positional arguments - - -> IO [a] - -- ^ If the parser fails, the program will exit with an error. If - -- the user requested help, it will be displayed and the program - -- exits successfully. Otherwise, the options and positional - -- arguments are returned here. -simpleHelp getHelp os ir getArg = do - let shortcuts = [C.OptSpec ["help"] "h" (C.NoArg (displayAct getHelp))] - opts = OptsWithPosArgs (Opts shortcuts os) ir getArg - ei <- simpleIOCustomError errorActDisplayHelp opts - case ei of - Left act -> act - Right as -> return as - --- | A parser for simple command lines without modes. Adds options --- for @--help@ and @--version@ for you. -simpleHelpVersion - :: (ProgName -> String) - -- ^ Indicate the help here. This function, when applied to the name - -- of the program, returns help. simpleHelpVersion automatically adds - -- options for @--help@ and @-h@ for you. - - -> (ProgName -> String) - -- ^ Indicate the version here. This function, when applied to the - -- name of the program, returns a version string. simpleHelpVersion - -- automatically adds an option for @--version@ for you. - - -> [C.OptSpec a] - -- ^ Options to parse - - -> Intersperse - -- ^ Allow interspersion of options and positional arguments? - - -> (String -> Either C.InputError a) - -- ^ How to parse positional arguments - - -> IO [a] - -- ^ If the parser fails, the program will exit with an error. If - -- the user requested help or version information, it will be - -- displayed and the program exits successfully. Otherwise, the - -- options and positional arguments are returned here. - -simpleHelpVersion getHelp getVer os ir getArg = do - let shortcuts = [ C.OptSpec ["help"] "h" - (C.NoArg (displayAct getHelp)) - , C.OptSpec ["version"] "" - (C.NoArg (displayAct getVer)) ] - opts = OptsWithPosArgs (Opts shortcuts os) ir getArg - ei <- simpleIOCustomError errorActDisplayHelp opts - case ei of - Left act -> act - Right as -> return as - --- # Helpers - --- | Handles positional arguments and errors with them. The parser for --- the positional argument must be passed in (this way it can --- be parsed with nonOptionPosArg or nextWord, as appropriate; when --- parsing interpsersed command lines, you will want nonOptionPosArg; --- when parsing non-interspersed command lines, you will need --- nextWord.) -parsePosArg - :: P.Parser String - -- ^ Parser for Word for next positional argument - -> (String -> Either C.InputError a) - -- ^ Function to handle positional arguments - -> P.Parser a -parsePosArg pa f = do - a <- pa - case f a of - Left e -> - let msg = "invalid positional argument: \"" ++ a ++ "\"" - in case e of - C.NoMsg -> fail msg - C.ErrorMsg s -> fail $ msg ++ ": " ++ s - Right g -> return g - --- | Parses options only, where they are not interspersed with --- positional arguments. Stops parsing only where it encouters a word --- that does not begin with a dash. This way if the user enters a bad --- option, it shows in the error message as a bad option rather than --- simply not getting parsed. -parseOptsNoIntersperse :: P.Parser a -> P.Parser [a] -parseOptsNoIntersperse p = P.manyTill p e where - e = P.end <|> nonOpt - nonOpt = P.lookAhead next - next = (() <$ P.nonOptionPosArg) <|> P.stopper - --- | Parses options and positional arguments where the two are not --- interspersed. Stops parsing options when a stopper is encountered --- or at the first word that does not look like an option. -parseStopOpts - :: P.Parser a - -> (String -> Either C.InputError a) - -> P.Parser [a] -parseStopOpts optParser p = - (++) - <$> parseOptsNoIntersperse optParser - <* optional P.stopper - <*> many (parsePosArg P.nextWord p) - - --- | @parseIntersperse o p@ parses options and positional arguments, --- where o is a parser that parses options, and p is a function that, --- when applied to a string, returns the appropriate type. --- --- If a stopper has not yet been seen, any word that begins with a --- hyphen will not be parsed as a positional argument. Therefore, if --- there is a word before a stopper and it begins with a hyphen, if it --- is not a valid option then the parse will fail with an error. -parseIntersperse - :: P.Parser a - -> (String -> Either C.InputError a) - -> P.Parser [a] -parseIntersperse optParser p = - let pa = Just <$> parsePosArg P.nonOptionPosArg p - po = Just <$> optParser - ps = Nothing <$ P.stopper - parser = po <|> ps <|> pa - in catMaybes <$> P.manyTill parser P.end - --- | Looks at the next word. Succeeds if it is a non-option, or if we --- are at the end of input. Fails otherwise. -endOrNonOpt :: P.Parser () -endOrNonOpt = (P.lookAhead P.nonOptionPosArg >> return ()) - <|> P.end - diff --git a/lib/System/Console/MultiArg/Option.hs b/lib/System/Console/MultiArg/Option.hs deleted file mode 100644 --- a/lib/System/Console/MultiArg/Option.hs +++ /dev/null @@ -1,45 +0,0 @@ --- | These types represent options. Option names cannot have a dash as --- their first or second character, and long option names cannot have --- an equals sign anywhere in the name. -module System.Console.MultiArg.Option ( - ShortOpt, - unShortOpt, - makeShortOpt, - LongOpt, - unLongOpt, - makeLongOpt ) - where - --- | Short options. Options that are preceded with a single dash on --- the command line and consist of a single letter. That single letter --- cannot be a dash. Any other Unicode character is good (including --- pathological ones like newlines). -newtype ShortOpt = ShortOpt { unShortOpt :: Char } deriving (Show, Eq, Ord) - --- | Creates a short option. Returns Nothing if the character is not --- valid for a short option. -makeShortOpt :: Char -> Maybe ShortOpt -makeShortOpt c = case c of - '-' -> Nothing - x -> Just $ ShortOpt x - --- | Long options. Options that are preceded with two dashes on the --- command line and typically consist of an entire mnemonic word, such --- as @lines@. However, anything that is at least one letter long is --- fine for a long option name. The name must be at least one --- character long. It cannot have an equal sign anywhere in its --- name. Otherwise any Unicode character is good (including --- pathological ones like newlines). -data LongOpt = LongOpt { unLongOpt :: String } deriving (Show, Eq, Ord) - --- | Makes a long option. Returns Nothing if the string is not a valid --- long option. -makeLongOpt :: String -> Maybe LongOpt -makeLongOpt t = - if isValidLongOptText t then Just $ LongOpt t else Nothing - - -isValidLongOptText :: String -> Bool -isValidLongOptText s = case s of - [] -> False - xs -> not $ '=' `elem` xs diff --git a/lib/System/Console/MultiArg/Prim.hs b/lib/System/Console/MultiArg/Prim.hs deleted file mode 100644 --- a/lib/System/Console/MultiArg/Prim.hs +++ /dev/null @@ -1,681 +0,0 @@ --- | Parser primitives. These are the only functions that have access --- to the internals of the parser. Use these functions if you want to --- build your own parser from scratch. If your needs are simpler, you --- will want to look at "System.Console.MultiArg.SimpleParser" or --- "System.Console.MultiArg.Combinator", which do a lot of grunt work --- for you. --- --- Internal design, especially the error handling, is based in large --- part on Parsec, as described in the paper at --- . -module System.Console.MultiArg.Prim ( - -- * Parser types - Parser, - - -- * Running a parser - - -- | Each parser runner is applied to a list of Strings, which are the - -- command line arguments to parse. - parse, - - -- * Higher-level parser combinators - good, - choice, - bind, - lookAhead, - - -- ** Running parsers multiple times - several, - several1, - manyTill, - - -- ** Failure and errors - failString, - genericThrow, - (), - try, - - -- * Parsers - -- ** Short options and arguments - pendingShortOpt, - nonPendingShortOpt, - pendingShortOptArg, - - -- ** Long options and arguments - exactLongOpt, - approxLongOpt, - - -- ** Stoppers - stopper, - resetStopper, - - -- ** Positional (non-option) arguments - nextWord, - nextWordIs, - nonOptionPosArg, - matchApproxWord, - - -- ** Miscellaneous - end, - - -- * Errors - Description(..), - Error(Error), - InputDesc - - ) where - - -import System.Console.MultiArg.Option - (ShortOpt, - unShortOpt, - LongOpt, - unLongOpt, - makeLongOpt ) -import Control.Applicative ( Applicative, Alternative, optional ) -import qualified Control.Applicative as A -import qualified Data.Set as Set -import Data.Set ( Set ) -import qualified Control.Monad -import Control.Monad ( when, MonadPlus(mzero, mplus), guard, liftM ) -import Data.Maybe (mapMaybe) -import Data.Monoid ( Monoid ( mempty, mappend ) ) -import qualified Data.List as L -import Data.List (isPrefixOf) - --- | Parsers. Internally the parser tracks what input remains to be --- parsed, whether there are any pending short options, and whether a --- stopper has been seen. A parser can return a value of any type. --- --- The parser also includes the notion of failure. Any parser can --- fail; a failed parser affects the behavior of combinators such as --- choice. -newtype Parser a = Parser { runParser :: State -> Consumed a } - -instance Monad Parser where - (>>=) = bind - return = good - fail = failString - -instance Functor Parser where - fmap = liftM - -instance Applicative Parser where - (<*>) = Control.Monad.ap - pure = return - -instance Alternative Parser where - empty = genericThrow - (<|>) = choice - some = several1 - many = several - -instance Monoid (Parser a) where - mempty = genericThrow - mappend = choice - -instance MonadPlus Parser where - mzero = genericThrow - mplus = choice - -type PendingShort = String -type Remaining = [String] -type SawStopper = Bool -data State = State PendingShort Remaining SawStopper - -type InputDesc = String -data Description = Unknown | General String | Expected String - deriving (Eq, Show, Ord) - --- | Error messages. To format error messages for nice display, see --- 'System.Console.MultiArg.Combinator.formatError'. -data Error = Error InputDesc [Description] - deriving (Eq, Show, Ord) - -data Reply a = Ok a State Error - | Fail Error - -data Consumed a = Consumed (Reply a) - | Empty (Reply a) - --- | @good a@ always succeeds without consuming any input and has --- result a. This provides the implementation for --- 'Control.Monad.Monad.return' and --- 'Control.Applicative.Applicative.pure'. -good :: a -> Parser a -good x = Parser $ \st -> Empty (Ok x st (Error (descLocation st) [])) - --- | Combines two parsers into a single parser. The second parser can --- optionally depend upon the result from the first parser. --- --- This applies the first parser. If the first parser succeeds, --- combine then takes the result from the first parser, applies the --- function given to the result from the first parser, and then --- applies the resulting parser. --- --- If the first parser fails, combine will not apply the second --- function but instead will bypass the second parser. --- --- This provides the implementation for '>>=' in --- 'Control.Monad.Monad'. -bind :: Parser a -> (a -> Parser b) -> Parser b -bind (Parser p) f = Parser $ \s -> - case p s of - Empty r1 -> case r1 of - Ok x s' _ -> runParser (f x) s' - Fail m -> Empty (Fail m) - Consumed r1 -> Consumed $ - case r1 of - Ok x s' _ -> case runParser (f x) s' of - Consumed r -> r - Empty r -> r - Fail e -> Fail e - -descLocation :: State -> InputDesc -descLocation (State ps rm st) = pending ++ next ++ stop - where - pending - | null ps = "" - | otherwise = "short option or short option argument: " - ++ ps ++ " " - next = case rm of - [] -> "no words remaining" - x:_ -> "next word: " ++ x - stop = if st then " (stopper already seen)" else "" - - --- | @failString s@ always fails without consuming any input. The --- failure contains a record of the string passed in by s. This --- provides the implementation for 'Control.Monad.Monad.fail'. -failString :: String -> Parser a -failString str = Parser $ \s -> - Empty (Fail (Error (descLocation s) [General str])) - - --- | Fail with an unhelpful error message. Usually 'throwString' is --- more useful, but this is handy to implement some typeclass --- instances. -genericThrow :: Parser a -genericThrow = Parser $ \s -> - Empty (Fail (Error (descLocation s) [Unknown])) - --- | Runs the first parser. If it fails without consuming any input, --- then runs the second parser. If the first parser succeeds, then --- returns the result of the first parser. If the first parser fails --- and consumes input, then returns the result of the first --- parser. This provides the implementation for --- '<|>' in 'Control.Applicative.Alternative'. -choice :: Parser a -> Parser a -> Parser a -choice p q = Parser $ \s -> - case runParser p s of - Empty (Fail msg1) -> - case runParser q s of - Empty (Fail msg2) -> mergeError msg1 msg2 - Empty (Ok x s' msg2) -> mergeOk x s' msg1 msg2 - c -> c - Empty (Ok x s' msg1) -> - case runParser q s of - Empty (Fail msg2) -> mergeOk x s' msg1 msg2 - Empty (Ok _ _ msg2) -> mergeOk x s' msg1 msg2 - c -> c - c -> c - where - mergeOk x s msg1 msg2 = Empty (Ok x s (merge msg1 msg2)) - mergeError msg1 msg2 = Empty (Fail (merge msg1 msg2)) - merge (Error loc exp1) (Error _ exp2) = - Error loc (exp1 ++ exp2) - --- | Applies 'error' if a parser would succeed without consuming any --- input. Useful for preventing infinite loops on parsers like --- 'several1'. -crashOnEmptyOk - :: String - -- ^ Use this label when applying 'error' - - -> Parser a - -> Parser a -crashOnEmptyOk str p = Parser $ \s -> - case runParser p s of - Empty r -> case r of - Ok _ _ _ -> - error $ "multiarg: error: " ++ str - ++ " applied to parser that succeeds without " - ++ "consuming any input. Aborted to prevent " - ++ "an infinite loop." - e -> Empty e - o -> o - - --- | Runs a parser one or more times. Runs the parser once and then --- applies 'several'. -several1 :: Parser a -> Parser [a] -several1 p = do - r1 <- p - rs <- several p - return $ r1:rs - - --- | Runs a parser zero or more times. If the last run of the parser --- fails without consuming any input, this parser succeeds without --- consuming any input. If the last run of the parser fails while --- consuming input, this parser fails while consuming input. This --- provides the implementation for 'many' in Control.Applicative. -several :: Parser a -> Parser [a] -several unwrapped = - let p = crashOnEmptyOk "several" unwrapped - in do - maybeA <- optional p - case maybeA of - Nothing -> return [] - Just a -> do - rest <- several unwrapped - return $ a:rest - - --- | Runs the parser given. If it fails without consuming any input, --- replaces all Expected messages with the one given. Otherwise, --- returns the result of the parser unchanged. -() :: Parser a -> String -> Parser a -p str = Parser $ \s -> - case runParser p s of - Empty (Fail m) -> Empty (Fail (expect m str)) - Empty (Ok x s' m) -> Empty (Ok x s' (expect m str)) - x -> x - where - expect (Error pos ls) s = - let ls' = mapMaybe notExpected ls - notExpected d = case d of - Expected _ -> Nothing - x -> Just x - in Error pos ((Expected s) : ls') - -infix 0 - --- | Runs a parser. This is the only way to change a value of type --- @Parser a@ into a value of type @a@ (that is, it is the only way to --- \"get out of the Parser monad\" or to \"escape the Parser monad\".) -parse - :: [String] - -- ^ Command line arguments to parse. Presumably you got these from - -- 'getArgs'. If there is any chance that you will be parsing - -- Unicode strings, see the documentation in - -- "System.Console.MultiArg.GetArgs" before you use - -- 'System.Environment.getArgs'. - - -> Parser a - -- ^ Parser to run - - -> Either Error a - -- ^ Success or failure. Any parser might fail; for example, the - -- command line might not have any values left to parse. Use of the - -- 'choice' combinator can lead to a list of failures. - -parse ss p = - let s = State "" ss False - procReply r = case r of - Ok x _ _ -> Right x - Fail m -> Left m - in case runParser p s of - Consumed r -> procReply r - Empty r -> procReply r - --- | Parses only pending short options. Fails without consuming any --- input if there has already been a stopper or if there are no --- pending short options. Fails without consuming any input if there --- is a pending short option, but it does not match the short option --- given. Succeeds and consumes a pending short option if it matches --- the short option given. -pendingShortOpt :: ShortOpt -> Parser () -pendingShortOpt so = Parser $ \s@(State pends rm stop) -> - let msg = Error (descLocation s) - [Expected ("pending short option: -" ++ [unShortOpt so])] - gd s' = Consumed (Ok () s' msg) - err = Empty (Fail msg) - in maybe err gd $ do - guard $ not stop - (first, rest) <- case pends of - [] -> mzero - x:xs -> return (x, xs) - when (unShortOpt so /= first) mzero - return $ State rest rm stop - --- | @lookAhead p@ runs parser p. If p succeeds, lookAhead p succeeds --- without consuming any input. If p fails without consuming any --- input, so does lookAhead. If p fails and consumes input, lookAhead --- also fails and consumes input. If this is undesirable, combine with --- "try". -lookAhead :: Parser a -> Parser a -lookAhead p = Parser $ \s -> - case runParser p s of - Consumed r -> case r of - Ok x _ e -> Empty (Ok x s e) - e -> Consumed e - e -> e - -nextW :: Remaining -> Maybe (String, Remaining) -nextW rm = case rm of - [] -> Nothing - x:xs -> Just (x, xs) - --- | Parses only non-pending short options. Fails without consuming --- any input if: --- --- * there are pending short options --- --- * there has already been a stopper --- --- * there are no arguments left to parse --- --- * the next argument is an empty string --- --- * the next argument does not begin with a dash --- --- * the next argument is a single dash --- --- * the next argument is a short option but it does not match --- the one given --- --- * the next argument is a stopper --- --- Otherwise, consumes the next argument, puts any remaining letters --- from the argument into a pending short, and removes the first word --- from remaining arguments to be parsed. -nonPendingShortOpt :: ShortOpt -> Parser () -nonPendingShortOpt so = Parser $ \s@(State ps rm stop) -> - let dsc = [Expected - $ "non pending short option: -" ++ [unShortOpt so]] - err = Error (descLocation s) dsc - errRet = Empty (Fail err) - gd (ps'', rm'') = Consumed (Ok () (State ps'' rm'' stop) err) - in maybe errRet gd $ do - guard $ null ps - guard $ not stop - (a, rm') <- nextW rm - (maybeDash, word) <- case a of - [] -> mzero - x:xs -> return (x, xs) - guard (maybeDash == '-') - (letter, arg) <- case word of - [] -> mzero - x:xs -> return (x, xs) - guard (letter == unShortOpt so) - return (arg, rm') - - --- | Parses an exact long option. That is, the text of the --- command-line option must exactly match the text of the --- option. Returns any argument that is attached to --- the same word of the option with an equal sign (for example, --- @--follow=\/dev\/random@ will return @Just \"\/dev\/random\"@ for the --- argument.) If there is no equal sign, returns Nothing for the --- argument. If there is an equal sign but there is nothing after it, --- returns @Just \"\"@ for the argument. --- --- If you do not want your long option to have equal signs and --- GNU-style option arguments, wrap this parser in something that will --- fail if there is an option argument. --- --- Fails without consuming any input if: --- --- * there are pending short options --- --- * a stopper has been parsed --- --- * there are no arguments left on the command line --- --- * the next argument on the command line does not begin with --- two dashes --- --- * the next argument on the command line is @--@ (a stopper) --- --- * the next argument on the command line does begin with two --- dashes but its text does not match the argument we're looking for - -exactLongOpt :: LongOpt -> Parser (Maybe String) -exactLongOpt lo = Parser $ \s@(State ps rm sp) -> - let msg = Error (descLocation s) - [Expected ("long option: --" ++ unLongOpt lo)] - gd (arg, newRm) = Consumed (Ok arg (State ps newRm sp) msg) - err = Empty (Fail msg) - in maybe err gd $ do - guard $ null ps - guard $ not sp - (x, rm') <- nextW rm - (word, afterEq) <- getLongOption x - guard (word == unLongOpt lo) - return (afterEq, rm') - - -getLongOption :: String -> Maybe (String, Maybe String) -getLongOption str = do - guard (str /= "--") - let (pre, word, afterEq) = splitLongWord str - guard (pre == "--") - return (word, afterEq) - --- | Takes a single String and returns a tuple, where the first element --- is the first two letters, the second element is everything from the --- third letter to the equal sign, and the third element is Nothing if --- there is no equal sign, or Just String with everything after the --- equal sign if there is one. -splitLongWord :: String -> (String, String, Maybe String) -splitLongWord t = (f, s, r) where - (f, rest) = L.splitAt 2 t - (s, withEq) = L.break (== '=') rest - r = case withEq of - [] -> Nothing - _:xs -> Just xs - -approxLongOptError :: [LongOpt] -> [Description] -approxLongOptError = - map (Expected . ("long option: --" ++) . unLongOpt) - - -assert :: e -> Bool -> Either e () -assert e b = if b then Right () else Left e - -fromMaybe :: e -> Maybe a -> Either e a -fromMaybe e = maybe (Left e) Right - --- | Examines the next word. If it matches a LongOpt in the set --- unambiguously, returns a tuple of the word actually found and the --- matching word in the set and the accompanying text after the equal --- sign (if any). If the Set is empty, this parser will always fail. -approxLongOpt :: - Set LongOpt - -> Parser (String, LongOpt, Maybe String) -approxLongOpt ts = Parser $ \s@(State ps rm stop) -> - let err ls = Error (descLocation s) (approxLongOptError ls) - ert ls = Empty (Fail $ err ls) - gd (found, opt, arg, rm'') = - Consumed (Ok (found, opt, arg) (State ps rm'' stop) - (err allOpts)) - allOpts = Set.toList ts - in either ert gd $ do - assert allOpts $ null ps - assert allOpts $ not stop - (x, rm') <- fromMaybe allOpts $ nextW rm - (word, afterEq) <- fromMaybe allOpts $ getLongOption x - opt <- fromMaybe allOpts $ makeLongOpt word - if Set.member opt ts - then return (word, opt, afterEq, rm') - else do - let p t = word `isPrefixOf` unLongOpt t - matches = Set.filter p ts - case Set.toList matches of - [] -> Left allOpts - (m:[]) -> return (word, m, afterEq, rm') - ls -> Left ls - - --- | Parses only pending short option arguments. For example, for the --- @tail@ command, if you enter the option @-c25@, then after parsing --- the @-c@ option the @25@ becomes a pending short option argument --- because it was in the same command line argument as the @-c@. --- --- Fails without consuming any input if: --- --- * a stopper has already been parsed --- --- * there are no pending short option arguments --- --- On success, returns the String of the pending short option argument --- (this String will never be empty). -pendingShortOptArg :: Parser String -pendingShortOptArg = Parser $ \st@(State ps rm sp) -> - let msg = [Expected "pending short option argument"] - err = Error (descLocation st) msg - ert = Empty (Fail err) - gd str = Consumed (Ok str (State "" rm sp) err) - in maybe ert gd $ do - guard $ not sp - case ps of - [] -> mzero - xs -> return xs - - --- | Parses a \"stopper\" - that is, a double dash. Changes the internal --- state of the parser to reflect that a stopper has been seen. -stopper :: Parser () -stopper = Parser $ \s@(State ps rm sp) -> - let err = Error (descLocation s) - [Expected "stopper, \"--\""] - ert = Empty (Fail err) - gd rm'' = Consumed (Ok () (State ps rm'' True) err) - in maybe ert gd $ do - guard $ not sp - guard . null $ ps - (x, rm') <- nextW rm - guard $ x == "--" - return rm' - - --- | If a stopper has already been seen, change the internal state --- back to indicating that no stopper has been seen. -resetStopper :: Parser () -resetStopper = Parser $ \s@(State ps rm _) -> - Empty (Ok () (State ps rm False) (Error (descLocation s) [])) - - --- | try p behaves just like p, but if p fails, try p will not consume --- any input. -try :: Parser a -> Parser a -try a = Parser $ \s -> - case runParser a s of - Consumed r -> case r of - Fail e -> Empty (Fail e) - o -> Consumed o - o -> o - - --- | Returns the next string on the command line as long as there are --- no pendings. Succeeds even if a stopper is present. Be careful - --- this will return the next string even if it looks like an option --- (that is, it starts with a dash.) Consider whether you should be --- using nonOptionPosArg instead. However this can be useful when --- parsing command line options after a stopper. -nextWord :: Parser String -nextWord = Parser $ \s@(State ps rm sp) -> - let err = Error (descLocation s) [dsc] - dsc = Expected "next word" - ert = Empty (Fail err) - gd (str, rm'') = Consumed $ Ok str (State ps rm'' sp) err - in maybe ert gd $ do - guard $ null ps - nextW rm - - --- | Parses the next word on the command line, but only if it exactly --- matches the word given. Otherwise, fails without consuming any --- input. Also fails without consuming any input if there are pending --- short options or if a stopper has already been parsed. Does not pay --- any attention to whether a stopper is present. -nextWordIs :: String -> Parser () -nextWordIs str = Parser $ \s@(State ps rm sp) -> - let err = Error (descLocation s) [dsc] - dsc = Expected $ "next argument \"" ++ str ++ "\"" - ert = Empty $ Fail err - gd rm'' = Consumed $ Ok () (State ps rm'' sp) err - in maybe ert gd $ do - guard $ null ps - (a, rm') <- nextW rm - guard (a == str) - return rm' - - --- | If there are pending short options, fails without consuming any input. --- --- Otherwise, if a stopper has NOT already been parsed, then returns --- the next word if it is either a single dash or any other word that --- does not begin with a dash. If the next word does not meet these --- criteria, fails without consuming any input. --- --- Otherwise, if a stopper has already been parsed, then returns the --- next word, regardless of whether it begins with a dash or not. -nonOptionPosArg :: Parser String -nonOptionPosArg = Parser $ \s@(State ps rm sp) -> - let err = Error (descLocation s) [dsc] - dsc = Expected "non option positional argument" - ert = Empty $ Fail err - gd (str, rm'') = Consumed $ Ok str (State ps rm'' sp) err - in maybe ert gd $ do - guard $ null ps - (x, rm') <- nextW rm - result <- if sp - then return x - else case x of - [] -> return x - '-':[] -> return "-" - f:_ -> if f == '-' then mzero else return x - return (result, rm') - - --- | Succeeds if there is no more input left. -end :: Parser () -end = Parser $ \s@(State ps rm _) -> - let err = Error (descLocation s) [dsc] - dsc = Expected "end of input" - ert = Empty $ Fail err - gd = Empty $ Ok () s err - in if null ps && null rm then gd else ert - - --- | Examines the possible words in Set. If there are no pendings, --- then get the next word and see if it matches one of the words in --- Set. If so, returns the word actually parsed and the matching word --- from Set. If there is no match, fails without consuming any --- input. Pays no attention to whether a stopper has been seen. -matchApproxWord :: Set String -> Parser (String, String) -matchApproxWord set = Parser $ \s@(State ps rm sp) -> - let err = Error (descLocation s) . lsDsc - lsDsc = map (Expected . ("next word: " ++)) - ert = Empty . Fail . err - gd (act, mtch, rm'') = - Consumed $ Ok (act, mtch) (State ps rm'' sp) (err allWords) - allWords = Set.toList set - in either ert gd $ do - assert allWords $ null ps - (x, rm') <- fromMaybe allWords $ nextW rm - let matches = Set.filter p set - p t = x `isPrefixOf` t - case Set.toList matches of - [] -> Left allWords - r:[] -> return (x, r, rm') - xs -> Left xs - --- | @manyTill p end@ runs parser p zero or more times until parser --- @end@ succeeds. If @end@ succeeds and consumes input, that input is --- also consumed. in the result of @manyTill@. If that is a problem, --- wrap it in @lookAhead@. Also, if @end@ fails and consumes input, --- @manyTill@ fails and consumes input. If that is a problem, wrap --- @end@ in @try@. -manyTill :: Parser a -> Parser end -> Parser [a] -manyTill p e = do - maybeEnd <- optional e - case maybeEnd of - Just _ -> return [] - Nothing -> do - a <- crashOnEmptyOk "manyTill" p - rs <- manyTill p e - return $ a:rs - diff --git a/lib/System/Console/MultiArg/SampleParser.hs b/lib/System/Console/MultiArg/SampleParser.hs deleted file mode 100644 --- a/lib/System/Console/MultiArg/SampleParser.hs +++ /dev/null @@ -1,70 +0,0 @@ --- | This is sample code using "System.Console.MultiArg". This could --- be a command-line parser for the version of the Unix command @tail@ --- that is included with GNU coreutils version 8.5. "main" simply gets --- the command line arguments, parses them, and prints out what was --- parsed. To test it out, simply compile an executable that looks --- like this and then feed it different options: --- --- > import System.Console.MultiArg.SampleParser --- > main = sampleMain Intersperse --- --- or: --- --- > import System.Console.MultiArg.SampleParser --- > main = sampleMain StopOptions --- --- The code in the module is the sample code; the sample code is not --- in the Haddock documentation! If you're reading this in Haddock, --- you will want to also take a look at the actual source code. -module System.Console.MultiArg.SampleParser where - -import qualified System.Console.MultiArg.Combinator as C -import qualified System.Console.MultiArg.CommandLine as P - -data Flag = - Bytes String - | Follow (Maybe String) - | Retry - | Lines String - | Stats String - | Pid String - | Quiet - | Sleep String - | Verbose - | Help - | Version - | Filename String - deriving Show - -specs :: [C.OptSpec Flag] - -specs = - [ C.OptSpec ["bytes"] ['c'] - (C.OneArg (return . Bytes)) - - , C.OptSpec ["follow"] ['f'] - (C.OptionalArg (return . Follow)) - - , C.OptSpec ["follow-retry"] ['F'] (C.NoArg Retry) - - , C.OptSpec ["lines"] ['n'] - (C.OneArg (return . Lines)) - - , C.OptSpec ["max-unchanged-stats"] [] - (C.OneArg (return . Stats)) - - , C.OptSpec ["pid"] [] - (C.OneArg (return . Pid)) - , C.OptSpec ["quiet"] ['q'] (C.NoArg Quiet) - - , C.OptSpec ["sleep-interval"] ['s'] - (C.OneArg (return . Sleep)) - , C.OptSpec ["verbose"] ['v'] (C.NoArg Verbose) - , C.OptSpec ["help"] [] (C.NoArg Help) - , C.OptSpec ["version"] [] (C.NoArg Version) - ] - -sampleMain :: P.Intersperse -> IO () -sampleMain i = do - r <- P.simpleIO specs i (return . Filename) - print r diff --git a/minimum-versions.txt b/minimum-versions.txt deleted file mode 100644 --- a/minimum-versions.txt +++ /dev/null @@ -1,44 +0,0 @@ -This package was tested to work with these dependency -versions and compiler version. -These are the minimum versions given in the .cabal file. -Tested as of: 2014-03-01 20:12:15.212998 UTC -Path to compiler: ghc-7.4.1 -Compiler description: 7.4.1 - -/opt/ghc/7.4.1/lib/ghc-7.4.1/package.conf.d: - Cabal-1.14.0 - array-0.4.0.0 - base-4.5.0.0 - bin-package-db-0.0.0.0 - binary-0.5.1.0 - bytestring-0.9.2.1 - containers-0.4.2.1 - deepseq-1.3.0.0 - directory-1.1.0.2 - extensible-exceptions-0.1.1.4 - filepath-1.3.0.0 - (ghc-7.4.1) - ghc-prim-0.2.0.0 - (haskell2010-1.1.0.1) - (haskell98-2.0.0.1) - hoopl-3.8.7.3 - hpc-0.5.1.1 - integer-gmp-0.4.0.0 - old-locale-1.0.0.4 - old-time-1.1.0.0 - pretty-1.1.1.0 - process-1.1.0.1 - rts-1.0 - template-haskell-2.7.0.0 - time-1.4 - unix-2.5.1.0 - -/home/massysett/multiarg/sunlight-29118/db: - bifunctors-0.1.3.1 - comonad-1.1.1.6 - contravariant-0.2.0.2 - multiarg-0.26.0.0 - semigroupoids-1.3.4 - semigroups-0.8.5 - transformers-0.3.0.0 - diff --git a/multiarg.cabal b/multiarg.cabal --- a/multiarg.cabal +++ b/multiarg.cabal @@ -1,57 +1,182 @@ -Name: multiarg -Version: 0.26.0.0 -Cabal-version: >=1.8 -Build-Type: Simple -License: BSD3 -Copyright: 2011-2013 Omari Norman. +-- This Cabal file generated using the Cartel library. +-- Cartel is available at: +-- http://www.github.com/massysett/cartel +-- +-- Script name used to generate: genCabal.hs +-- Generated on: 2015-09-09 21:55:24.296803 EDT +-- Cartel library version: 0.14.2.6 + +name: multiarg +version: 0.30.0.10 +cabal-version: >= 1.18 +license: BSD3 +license-file: LICENSE +build-type: Simple +copyright: Copyright 2011-2015 Omari Norman author: Omari Norman maintainer: omari@smileystation.com stability: Experimental homepage: https://github.com/massysett/multiarg -bug-reports: omari@smileystation.com -Category: Console, Parsing -License-File: LICENSE -synopsis: Combinators to build command line parsers -extra-source-files: ChangeLog, README.md, - minimum-versions.txt, current-versions.txt, - sunlight-test.hs - -tested-with: GHC==7.4.1, GHC==7.6.3 +bug-reports: https://github.com/massysett/multiarg/issues +synopsis: Command lines for options that take multiple arguments +description: + multiarg helps you build command-line parsers for + programs with options that take more than one argument. + See the documentation in the Multiarg module for details. +category: Console, Parsing +extra-source-files: + ChangeLog + README.md -description: multiarg is a parser combinator library to build command - line parsers. With it you can easily create parsers with options - that take more than one option argument--for example, I created - multiarg due to the apparent lack of such ability amongst other - parsers. Its basic design is loosely inspired by Parsec. - . - Provides Parser, a monad you use to build parsers. This monad exposes - multiarg's full functionality. The library also has a simple, - pre-built parser built with the underlying combinators, which works - for many situtations and shields you from the underlying complexity - if you don't need it. - . - See the documentation in the System.Console.MultiArg module for - details. +Library + hs-source-dirs: + lib + ghc-options: + -Wall + default-language: Haskell2010 + build-depends: + base >= 4.7.0.0 && < 5 + exposed-modules: + Multiarg + Multiarg.Examples + Multiarg.Examples.Grover + Multiarg.Examples.Telly + Multiarg.Internal + Multiarg.Limeline + Multiarg.Maddash + Multiarg.Mode + Multiarg.Mode.Internal + Multiarg.Types + Multiarg.Util + Multiarg.Vocabulary source-repository head - type: git - location: git://github.com/massysett/multiarg.git - -Library - Build-depends: - base >=4.5.0.0 && < 5 - , bifunctors >= 0.1.3.1 - , containers >=0.4.2.1 + type: git + location: https://github.com/massysett/multiarg.git - hs-source-dirs: lib +Executable grover + main-is: grover-main.hs + if flag(programs) + buildable: True + hs-source-dirs: + lib + ghc-options: + -Wall + default-language: Haskell2010 + build-depends: + base >= 4.7.0.0 && < 5 + build-depends: + QuickCheck >= 2.7 + , tasty >= 0.10 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 + other-modules: + Multiarg + Multiarg.Examples + Multiarg.Examples.Grover + Multiarg.Examples.Telly + Multiarg.Internal + Multiarg.Limeline + Multiarg.Maddash + Multiarg.Mode + Multiarg.Mode.Internal + Multiarg.Types + Multiarg.Util + Multiarg.Vocabulary + Ernie + Grover.Tests + Makeopt + Multiarg.Maddash.Instances + Multiarg.Maddash.Tests + Multiarg.Types.Instances + Telly.Tests + hs-source-dirs: + tests + else + buildable: False - Exposed-modules: - System.Console.MultiArg - , System.Console.MultiArg.Combinator - , System.Console.MultiArg.CommandLine - , System.Console.MultiArg.Option - , System.Console.MultiArg.Prim - , System.Console.MultiArg.SampleParser +Executable telly + main-is: telly-main.hs + if flag(programs) + buildable: True + hs-source-dirs: + lib + ghc-options: + -Wall + default-language: Haskell2010 + build-depends: + base >= 4.7.0.0 && < 5 + build-depends: + QuickCheck >= 2.7 + , tasty >= 0.10 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 + other-modules: + Multiarg + Multiarg.Examples + Multiarg.Examples.Grover + Multiarg.Examples.Telly + Multiarg.Internal + Multiarg.Limeline + Multiarg.Maddash + Multiarg.Mode + Multiarg.Mode.Internal + Multiarg.Types + Multiarg.Util + Multiarg.Vocabulary + Ernie + Grover.Tests + Makeopt + Multiarg.Maddash.Instances + Multiarg.Maddash.Tests + Multiarg.Types.Instances + Telly.Tests + hs-source-dirs: + tests + else + buildable: False - ghc-options: -Wall +Test-Suite multiarg-tests + hs-source-dirs: + lib + ghc-options: + -Wall + default-language: Haskell2010 + build-depends: + base >= 4.7.0.0 && < 5 + type: exitcode-stdio-1.0 + main-is: multiarg-tests.hs + other-modules: + Multiarg + Multiarg.Examples + Multiarg.Examples.Grover + Multiarg.Examples.Telly + Multiarg.Internal + Multiarg.Limeline + Multiarg.Maddash + Multiarg.Mode + Multiarg.Mode.Internal + Multiarg.Types + Multiarg.Util + Multiarg.Vocabulary + Ernie + Grover.Tests + Makeopt + Multiarg.Maddash.Instances + Multiarg.Maddash.Tests + Multiarg.Types.Instances + Telly.Tests + hs-source-dirs: + tests + other-extensions: + TemplateHaskell + build-depends: + QuickCheck >= 2.7 + , tasty >= 0.10 + , tasty-quickcheck >= 0.8 + , tasty-th >= 0.1 +Flag programs + description: Build sample programs + default: False + manual: True diff --git a/sunlight-test.hs b/sunlight-test.hs deleted file mode 100644 --- a/sunlight-test.hs +++ /dev/null @@ -1,15 +0,0 @@ -module Main where - -import Test.Sunlight - -ghc v = (v, "ghc-" ++ v, "ghc-pkg-" ++ v) - -inputs = TestInputs - { tiDescription = Nothing - , tiCabal = "cabal" - , tiLowest = ghc "7.4.1" - , tiDefault = [ ghc "7.4.1", ghc "7.6.3" ] - , tiTest = [] - } - -main = runTests inputs diff --git a/tests/Ernie.hs b/tests/Ernie.hs new file mode 100644 --- /dev/null +++ b/tests/Ernie.hs @@ -0,0 +1,122 @@ +-- | Functions to assist with testing. +module Ernie where + +import Control.Applicative +import Makeopt +import Multiarg.Types +import Test.QuickCheck + +-- | Generates words that start with a single hyphen. +startsWithOneHyphen :: Gen String +startsWithOneHyphen = fmap ('-':) (listOf1 arbitrary) + +-- | Generates words that start with two hyphens. +startsWithTwoHyphens :: Gen String +startsWithTwoHyphens = fmap ("--" ++) arbitrary + +-- | Generates words that do not start with a hyphen. +startsWithNonHyphen :: Gen String +startsWithNonHyphen = (:) <$> (arbitrary `suchThat` (/= '-')) + <*> arbitrary + +-- | Generates words for option arguments. Ensures that some start +-- with hyphens (these are valid option arguments.) +optArg :: Gen String +optArg = oneof [ startsWithOneHyphen, startsWithNonHyphen ] + +short :: Char -> [String] -> [[String]] +short c os = case shortName c of + Nothing -> error "Ernie.hs: error: could not create short name" + Just o -> processShortOptions [] (o, os) + +long :: String -> [String] -> [[String]] +long s os = case longName s of + Nothing -> error "Ernie.hs: error: could not create long name" + Just o -> processLongOption o os + +pickItem :: [a] -> Gen a +pickItem a + | null a = fail "pickItem: empty list" + | otherwise = fmap (a !!) (choose (0, length a - 1)) + +-- | Generates non-option positional arguments that appear to the +-- right of the stopper. This can be any word at all. +posArgRight :: Gen String +posArgRight = oneof + [ arbitrary, startsWithOneHyphen, startsWithTwoHyphens ] + +-- | Generates non-option positional arguments that appear to the left +-- of the stopper. Cannot be preceded by a dash; can, however, be a +-- single hyphen only. +posArgLeft :: Gen String +posArgLeft = + frequency [ (5, startsWithNonHyphen) + , (1, return "-") ] + +-- | Generates options, non-option positional arguments that are a +-- single hyphen only, and non-option positional arguments that do not +-- start with a hyphen; these may appear to the left of a stopper. +preStopper + :: Gen a + -- ^ Generates options + -> (String -> a) + -- ^ Creates non-option positional arguments + -> Gen [a] +preStopper genOpt fPos = + listOf (oneof [ genOpt, fmap fPos posArgLeft ]) + +-- | Generates any word at all, with a healthy mix of empty lists +-- (stoppers are unusual.) +postStopper + :: (String -> a) + -- ^ Creates non-option positional arguments + -> Gen [a] +postStopper fPos = + oneof [ return [], listOf (fmap fPos posArgRight) ] + +-- | Generates a valid list of interspersed command-line options; that +-- is, a list that the user could have entered in the command line. +-- This list may be transformed into strings, which can then be parsed +-- and compared against this original value. +-- +-- Returns a pair @(a, b)@, where @a@ is everything to the left of the +-- stopper, and @b@ (if non-empty) is everything to the right of the +-- stopper. + +interspersedLine + :: Gen a + -- ^ Generates options + -> (String -> a) + -- ^ Creates non-option positional arguments + -> Gen ([a], [a]) +interspersedLine genOpt fPos = + (,) + <$> preStopper genOpt fPos + <*> postStopper fPos + + +-- | Takes an interspersed line and creates a set of strings that +-- would, when parsed, yield the interspersed line. +interspersedLineToStrings + + :: ([a], [a]) + -- ^ @(a, b)@, where + -- + -- @a@ is everything to the left of the stopper, and + -- + -- @b@ is everything to the right of the stopper + + -> (a -> [[String]]) + -- ^ Converts a single item to a nested list of String. Each list + -- of String is a possible way to render this item. This list must + -- not be empty. + + -> Gen [String] + +interspersedLineToStrings (left, right) fConv = do + l <- fmap concat . mapM pickItem . map fConv $ left + r <- fmap concat . mapM pickItem . map fConv $ right + alwaysStopper <- arbitrary + let stop | not (null r) || alwaysStopper = ["--"] + | otherwise = [] + return $ l ++ stop ++ r diff --git a/tests/Grover/Tests.hs b/tests/Grover/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Grover/Tests.hs @@ -0,0 +1,136 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE TemplateHaskell #-} +module Grover.Tests where + +import Ernie +import Multiarg.Examples.Grover +import Control.Applicative +import Test.QuickCheck hiding (Result) +import Multiarg.Mode +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = $(testGroupGenerator) + +genGlobal :: Gen Global +genGlobal = oneof + [ return Help + , Verbose <$> arbitrary + , return Version + ] + +data GroverOpts + = GOInts [GroverOpt Int] + | GOStrings [GroverOpt String] + | GOMaybes [GroverOpt (Maybe Int)] + deriving (Eq, Ord, Show) + +instance Arbitrary GroverOpts where + arbitrary = oneof + [ fmap GOInts . listOf . genGroverOpt $ arbitrary + , fmap GOStrings . listOf . genGroverOpt $ arbitrary + , fmap GOMaybes . listOf . genGroverOpt $ arbitrary + ] + +-- | Generates a mode option. Does not generate positional arguments. +genGroverOpt + :: Gen a + -- ^ Generates arguments + -> Gen (GroverOpt a) +genGroverOpt g = oneof + [ return Zero + , Single <$> g + , Double <$> g <*> g + , Triple <$> g <*> g <*> g + ] + +globalToNestedList :: Global -> [[String]] +globalToNestedList glbl = case glbl of + Help -> long "help" [] ++ short 'h' [] + Verbose i -> long "verbose" [show i] ++ short 'v' [show i] + Version -> long "version" [] + +groverOptToNestedList :: Show a => GroverOpt a -> [[String]] +groverOptToNestedList gvr = case gvr of + Zero -> long "zero" [] ++ short 'z' [] + Single a -> long "single" ls ++ short 's' ls + where + ls = [show a] + Double a b -> long "double" ls ++ short 'd' ls + where + ls = [show a, show b] + Triple a b c -> long "triple" ls ++ short 't' ls + where + ls = [show a, show b, show c] + PosArg s -> [[s]] + +-- | A valid Grover AST, combined with a set of strings that, when +-- parsed, should yield that AST. +data ValidGrover + = ValidGrover [Global] (Either [String] Result) [String] + -- ^ @ValidGrover a b c@, where + -- + -- @a@ is the list of global options + -- + -- @b@ is either a list of strings (indicates that the user entered + -- no mode), or the mode, and its associated options + -- + -- @c@ is a list of strings that, when parsed, should return @a@ and @b@. + deriving (Eq, Ord, Show) + +instance Arbitrary ValidGrover where + arbitrary = do + globals <- listOf genGlobal + glblStrings <- fmap concat . mapM pickItem + . map globalToNestedList $ globals + (ei, endStrings) <- oneof + [ resultAndStrings Ints "int" + , resultAndStrings Strings "string" + , resultAndStrings Maybes "maybe" + ] + return $ ValidGrover globals ei (glblStrings ++ endStrings) + +-- | Generates a list of String, where the first String will not be +-- interpreted as a mode. + +genNonModePosArg :: Gen [String] +genNonModePosArg = frequency ([ (1, return []), (3, nonEmpty)]) + where + nonEmpty = (:) <$> firstWord <*> listOf arbitrary + where + firstWord = arbitrary `suchThat` + (\s -> not (s `elem` ["int", "string", "maybe"]) + && not (startsWithHyphen s)) + startsWithHyphen s = case s of + '-':_ -> True + _ -> False + + +resultAndStrings + :: (Arbitrary a, Show a) + + => ([Either String (GroverOpt a)] -> Result) + -- ^ Function that creates a Result + + -> String + -- ^ Name of mode + + -> Gen (Either [String] Result, [String]) +resultAndStrings fRes modeName = frequency [(1, nonMode), (4, withMode)] + where + nonMode = fmap (\ls -> (Left ls, ls)) genNonModePosArg + withMode = do + ispLine <- interspersedLine (genGroverOpt arbitrary) PosArg + strings <- interspersedLineToStrings ispLine groverOptToNestedList + return ( Right . fRes . map Right $ fst ispLine ++ snd ispLine + , modeName : strings ) + +prop_ValidGrover (ValidGrover globals ei strings) = result === expected + where + result = parseModeLine globalOptSpecs modes strings + expected = Right (ModeResult (map Right globals) ei) + + +prop_alwaysTrue = True diff --git a/tests/Makeopt.hs b/tests/Makeopt.hs new file mode 100644 --- /dev/null +++ b/tests/Makeopt.hs @@ -0,0 +1,62 @@ +-- | Makeopt produces all possible partitions for a given set of +-- command line options. + +module Makeopt where + +import Multiarg.Maddash + +processShortOptions + :: [ShortName] + -> (ShortName, [String]) + -> [[String]] +processShortOptions firstNames (inLast, args) + = shortPartitions firstName restNames args + where + (firstName, restNames) = case firstNames of + [] -> (shortNameToChar inLast, []) + (x:xs) -> (shortNameToChar x, map shortNameToChar $ xs ++ [inLast]) + +processLongOption + :: LongName + -> [String] + -> [[String]] +processLongOption lngName ss = lists ss + where + lng = "--" ++ longNameToString lngName + lists [] = [[lng]] + lists (x:xs) = [ (lng ++ "=" ++ x) : xs + , lng : x : xs + ] + +partitions :: [a] -> [[[a]]] +partitions [] = [[]] +partitions (x:xs) = [[x]:p | p <- partitions xs] + ++ [(x:ys):yss | (ys:yss) <- partitions xs] + + +shortPartitions + :: Char + -- ^ First flag + -> String + -- ^ Remaining flags + -> [String] + -- ^ Arguments + -> [[String]] +shortPartitions c1 cs args = case args of + [] -> flags + x:xs + | null x -> separate + | otherwise -> together ++ separate + where + separate = [ list ++ (x:xs) | list <- flags ] + together = do + list <- flags + case addToEnd list x of + Nothing -> error "shortPartitions: error" + Just r -> return $ r ++ xs + where + flags = map (map ('-':)) $ partitions (c1 : cs) + +addToEnd :: [[a]] -> [a] -> Maybe [[a]] +addToEnd [] _ = Nothing +addToEnd xs toAdd = Just (init xs ++ [last xs ++ toAdd]) diff --git a/tests/Multiarg/Maddash/Instances.hs b/tests/Multiarg/Maddash/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Multiarg/Maddash/Instances.hs @@ -0,0 +1,31 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Multiarg.Maddash.Instances where + +import Control.Applicative +import Test.QuickCheck +import Multiarg.Maddash +import Multiarg.Types.Instances () + +instance Arbitrary OptionError where + arbitrary = oneof + [ BadOption <$> arbitrary + , LongArgumentForZeroArgumentOption <$> arbitrary <*> arbitrary + ] + +instance Arbitrary a => Arbitrary (Output a) where + arbitrary = oneof + [ Good <$> arbitrary + , OptionError <$> arbitrary + ] + +instance Arbitrary a => Arbitrary (Pallet a) where + arbitrary = oneof + [ return NotAnOption + , Full <$> arbitrary + ] + +instance Arbitrary a => Arbitrary (State a) where + arbitrary = oneof + [ return Ready + , Pending <$> arbitrary <*> arbitrary + ] diff --git a/tests/Multiarg/Maddash/Tests.hs b/tests/Multiarg/Maddash/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Multiarg/Maddash/Tests.hs @@ -0,0 +1,138 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE TemplateHaskell #-} +module Multiarg.Maddash.Tests where + +import Control.Applicative +import Multiarg.Types +import Multiarg.Maddash +import Makeopt +import Test.QuickCheck +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck +import Multiarg.Types.Instances () +import Multiarg.Maddash.Instances () +import Multiarg.Types.Instances () + +tests :: TestTree +tests = $(testGroupGenerator) + +genInt :: Gen Int +genInt = arbitrary + +singleDash :: Multiarg.Types.Word +singleDash = Multiarg.Types.Word "-" + +stopper :: Multiarg.Types.Word +stopper = Multiarg.Types.Word "--" + +genNonOptWord :: Gen Multiarg.Types.Word +genNonOptWord = oneof + [ return singleDash + , return stopper + , do + c1 <- arbitrary `suchThat` (/= '-') + cs <- listOf arbitrary + return $ Multiarg.Types.Word (c1 : cs) + ] + +genPending :: Arbitrary a => Gen (State a) +genPending = Pending <$> arbitrary <*> arbitrary + +-- * Properties + +-- | Non-option token always returns NotAnOption if State is Ready +prop_nonOptWordNotAnOptionIfStateIsReady :: Property +prop_nonOptWordNotAnOptionIfStateIsReady = + forAll arbitrary $ \shorts -> + forAll arbitrary $ \longs -> + forAll genNonOptWord $ \token -> + let (pallet, _) = processWord shorts longs Ready token + _types = shorts :: [(ShortName, ArgSpec Int)] + in pallet == NotAnOption + +-- | Stopper always returns NotAnOption if State is Ready +prop_stopperNotAnOptionIfStateIsReady :: Property +prop_stopperNotAnOptionIfStateIsReady = + forAll arbitrary $ \shorts -> + forAll arbitrary $ \longs -> + let (pallet, _) = processWord shorts longs Ready stopper + _types = shorts :: [(ShortName, ArgSpec Int)] + in pallet == NotAnOption + +-- | Single dash always returns NotAnOption if State is Ready +prop_singleDashNotAnOptionIfStateIsReady :: Property +prop_singleDashNotAnOptionIfStateIsReady = + forAll arbitrary $ \shorts -> + forAll arbitrary $ \longs -> + let (pallet, _) = processWord shorts longs Ready singleDash + _types = shorts :: [(ShortName, ArgSpec Int)] + in pallet == NotAnOption + +-- | processWord never returns NotAnOption when input is Pending +prop_processWordNeverReturnsNotAnOptionOnPending = + forAll arbitrary $ \shorts -> + forAll arbitrary $ \longs -> + forAll genPending $ \state -> + forAll arbitrary $ \token -> + let (pallet, _) = processWord shorts longs state token + _types = shorts :: [(ShortName, ArgSpec Int)] + in pallet /= NotAnOption + +-- | NotAnOption is always returned with Ready +prop_processWordNotAnOptionWithReady = + forAll arbitrary $ \shorts -> + forAll arbitrary $ \longs -> + forAll arbitrary $ \state -> + forAll arbitrary $ \token -> + let (pallet, state') = processWord shorts longs state token + _types = shorts :: [(ShortName, ArgSpec Int)] + in pallet == NotAnOption ==> isReady state' + +pickOne :: [a] -> Gen a +pickOne ls + | null ls = error "pickOne: null list" + | otherwise = fmap (\ix -> ls !! ix) (choose (0, length ls - 1)) + +data OptionWithToks = OptionWithToks + { owtOptName :: OptName + , owtArgSpec :: ArgSpec Int + , owtArgs :: [String] + , owtWords :: [Multiarg.Types.Word] + , owtResultOuts :: [[Output Int]] + , owtResultToks :: Maybe [Multiarg.Types.Word] + , owtExpected :: Int + } deriving Show + +instance Arbitrary OptionWithToks where + arbitrary = do + OptName on <- arbitrary + as <- arbitrary + (args, expected) <- case as of + ZeroArg a -> return ([], a) + OneArg f -> do + s <- arbitrary + return ([s], f s) + TwoArg f -> do + s1:s2:[] <- vectorOf 2 arbitrary + return ([s1,s2], f s1 s2) + ThreeArg f -> do + s1:s2:s3:[] <- vectorOf 3 arbitrary + return ([s1,s2,s3], f s1 s2 s3) + let strings = case on of + Left shrt -> processShortOptions [] (shrt, args) + Right lng -> processLongOption lng args + toks <- fmap (map Multiarg.Types.Word) $ pickOne strings + let (shrts, lngs) = case on of + Left shrt -> ([(shrt, as)], []) + Right lng -> ([], [(lng, as)]) + (procRslts, procEi) = processWords shrts lngs toks + mayToks = either (const Nothing) Just procEi + return $ OptionWithToks (OptName on) as args toks procRslts + mayToks expected + +prop_optionWithToksResultToksEmpty = (== Just []) . owtResultToks + +prop_optionWithToksResultIsExpected owt + = concat (owtResultOuts owt) == [Good . owtExpected $ owt] + diff --git a/tests/Multiarg/Types/Instances.hs b/tests/Multiarg/Types/Instances.hs new file mode 100644 --- /dev/null +++ b/tests/Multiarg/Types/Instances.hs @@ -0,0 +1,42 @@ +{-# OPTIONS_GHC -fno-warn-orphans #-} +module Multiarg.Types.Instances where + +import Control.Applicative +import Test.QuickCheck +import Multiarg.Types + +instance Arbitrary a => Arbitrary (ArgSpec a) where + arbitrary = oneof + [ ZeroArg <$> arbitrary + , OneArg <$> arbitrary + , TwoArg <$> arbitrary + , ThreeArg <$> arbitrary + ] + +instance Arbitrary ShortName where + arbitrary = do + c <- arbitrary + case shortName c of + Nothing -> arbitrary + Just n -> return n + +instance Arbitrary LongName where + arbitrary = do + c1 <- arbitrary `suchThat` (\c -> c /= '-' && c /= '=') + cs <- listOf (arbitrary `suchThat` (/= '=')) + case longName (c1 : cs) of + Nothing -> error $ "could not generate long name: " ++ (c1:cs) + Just n -> return n + +instance Arbitrary OptName where + arbitrary = fmap OptName arbitrary + +instance Arbitrary Multiarg.Types.Word where + arbitrary = Multiarg.Types.Word <$> arbitrary + +instance CoArbitrary Multiarg.Types.Word where + coarbitrary (Multiarg.Types.Word s) = coarbitrary s + +instance Arbitrary OptArg where + arbitrary = OptArg <$> arbitrary + diff --git a/tests/Telly/Tests.hs b/tests/Telly/Tests.hs new file mode 100644 --- /dev/null +++ b/tests/Telly/Tests.hs @@ -0,0 +1,81 @@ +{-# OPTIONS_GHC -fno-warn-missing-signatures #-} +{-# LANGUAGE TemplateHaskell #-} +module Telly.Tests where + +import Multiarg.Examples.Telly +import Test.QuickCheck +import Control.Applicative +import Ernie +import Multiarg.Internal +import Test.Tasty +import Test.Tasty.TH +import Test.Tasty.QuickCheck + +tests :: TestTree +tests = $(testGroupGenerator) + +-- | Generates any option. +option :: Gen Telly +option = oneof + [ return Empty + , Single <$> optArg + , Double <$> optArg <*> optArg + , Triple <$> optArg <*> optArg <*> optArg + + , return Zero + , One <$> optArg + , Two <$> optArg <*> optArg + , Three <$> optArg <*> optArg <*> optArg + + , return Cero + , Uno <$> optArg + , Dos <$> optArg <*> optArg + , Tres <$> optArg <*> optArg <*> optArg + ] + +tellyToNestedList :: Telly -> [[String]] +tellyToNestedList telly = case telly of + PosArg s -> [[s]] + Empty -> long "empty" [] ++ short 'e' [] + Single s -> long "single" [s] ++ short 's' [s] + Double s1 s2 -> long "double" [s1, s2] ++ short 'd' [s1, s2] + Triple s1 s2 s3 -> long "triple" [s1, s2, s3] + ++ short 't' [s1, s2, s3] + + Zero -> short '0' [] + One s -> short '1' [s] + Two s1 s2 -> short '2' [s1, s2] + Three s1 s2 s3 -> short '3' [s1, s2, s3] + + Cero -> long "cero" [] + Uno s -> long "uno" [s] + Dos s1 s2 -> long "dos" [s1, s2] + Tres s1 s2 s3 -> long "tres" [s1, s2, s3] + +tellyToStrings :: Telly -> Gen [String] +tellyToStrings = pickItem . tellyToNestedList + +validTellyStrings :: Gen ([Telly], [String]) +validTellyStrings = do + unneededStopper <- arbitrary + (start, end) <- interspersedLine option PosArg + let startStrings = map tellyToNestedList start + endStrings = map tellyToNestedList end + startList <- fmap concat $ mapM pickItem startStrings + endList <- fmap concat $ mapM pickItem endStrings + let endList' + | null end && not unneededStopper = endList + | otherwise = "--" : endList + return (start ++ end, startList ++ endList') + +prop_parseStringsYieldsTellies + = forAll validTellyStrings $ \(tellies, strings) -> + let ParsedCommandLine ls _ + = parseCommandLinePure optSpecs PosArg strings + in map Right tellies === ls + +prop_parseStringsYieldsNoEndError + = forAll validTellyStrings $ \(_, strings) -> + let ParsedCommandLine _ mayOpt + = parseCommandLinePure optSpecs PosArg strings + in mayOpt === Nothing diff --git a/tests/grover-main.hs b/tests/grover-main.hs new file mode 100644 --- /dev/null +++ b/tests/grover-main.hs @@ -0,0 +1,9 @@ +module Main where + +import Multiarg.Examples.Grover +import System.Environment + +main :: IO () +main = do + as <- getArgs + putStrLn . show $ parseGrover as diff --git a/tests/multiarg-tests.hs b/tests/multiarg-tests.hs new file mode 100644 --- /dev/null +++ b/tests/multiarg-tests.hs @@ -0,0 +1,13 @@ +module Main where + +import qualified Multiarg.Maddash.Tests +import qualified Grover.Tests +import qualified Telly.Tests +import Test.Tasty + +main :: IO () +main = defaultMain $ testGroup "all properties" + [ Multiarg.Maddash.Tests.tests + , Grover.Tests.tests + , Telly.Tests.tests + ] diff --git a/tests/telly-main.hs b/tests/telly-main.hs new file mode 100644 --- /dev/null +++ b/tests/telly-main.hs @@ -0,0 +1,6 @@ +module Main where + +import Multiarg.Examples.Telly + +main :: IO () +main = parse >>= print