cmdtheline 0.1.1 → 0.2.3
raw patch · 29 files changed
Files
- README.md +11/−5
- cmdtheline.cabal +62/−8
- doc/examples/FizzBuzz.hs +10/−10
- doc/examples/arith.hs +19/−35
- doc/examples/cipher.hs +26/−27
- doc/examples/cp.hs +20/−45
- doc/examples/fail.hs +12/−12
- doc/examples/grep.hs +3/−3
- doc/examples/hello.hs +6/−7
- src/System/Console/CmdTheLine.hs +23/−29
- src/System/Console/CmdTheLine/Arg.hs +169/−126
- src/System/Console/CmdTheLine/ArgVal.hs +195/−179
- src/System/Console/CmdTheLine/CmdLine.hs +13/−13
- src/System/Console/CmdTheLine/Common.hs +55/−53
- src/System/Console/CmdTheLine/Err.hs +50/−5
- src/System/Console/CmdTheLine/GetOpt.hs +34/−0
- src/System/Console/CmdTheLine/Help.hs +39/−33
- src/System/Console/CmdTheLine/Manpage.hs +5/−11
- src/System/Console/CmdTheLine/Term.hs +102/−94
- src/System/Console/CmdTheLine/Trie.hs +35/−33
- src/System/Console/CmdTheLine/Util.hs +81/−0
- test/Arith.hs +177/−0
- test/CP.hs +79/−0
- test/Cipher.hs +227/−0
- test/Fail.hs +83/−0
- test/FizzBuzz.hs +68/−0
- test/Grep.hs +28/−0
- test/Hello.hs +23/−0
- test/Main.hs +117/−0
README.md view
@@ -1,6 +1,8 @@-CmdTheLine v0.1+CmdTheLine v0.2.1 =============== +[](http://travis-ci.org/eli-frey/cmdtheline)+ Command line option parsing with applicative functors. Installation@@ -12,8 +14,7 @@ Depends ------- All dependencies are provided by the [Haskell-Platform](http://hackage.haskell.org/platform). See cmdtheline.cabal for library-dependencies.+Platform](http://hackage.haskell.org/platform). Docs ----@@ -31,13 +32,18 @@ -------- ###master-The currently stable branch.+The currently (0.2) stable branch. ###dev Bug fixes and aditions that don't break compatibility with master. -###0.2+###0.3 The next release candidate.++Contributors+------------++Bas Van Dijk -- GetOpt adapter LICENSE -------
cmdtheline.cabal view
@@ -1,9 +1,9 @@ Name: cmdtheline-Version: 0.1.1-Synopsis: Declaritive command-line option parsing and documentation library.+Version: 0.2.3+Synopsis: Declarative command-line option parsing and documentation library. Description: CmdTheLine aims to remove tedium from the definition of command-line- programs, producing usage, help and man pages with little effort.+ programs, producing usage and help with little effort. . The inspiration was found in Daniel Bunzli's <http://erratique.ch/software/cmdliner> library.@@ -12,9 +12,40 @@ mechanism for defining command-line programs by lifting regular Haskell functions over argument parsers. .+ A tutorial can be found at+ <http://elifrey.com/2012/07/23/CmdTheLine-Tutorial/>.+ . Suggestions, comments, and bug reports are appreciated. Please see the bug and issue tracker at <http://github.com/eli-frey/cmdtheline>.-+ .+ Changes since 0.1:+ .+ * More type safety: Types in CmdTheLine.Arg have been made more explicit to+ disalow unwanted behavior. Positional argument information and optional+ argument information are distinguished from each other. As well 'Arg's must+ be transformed into 'Term' before use, as some operations make since to+ perform on 'Arg' but not on 'Term'.+ .+ * ArgVal has only one method: 'parser' and 'pp' have been fused into a tuple, so+ that instantiation of 'ArgVal' can be simplified for all parties.+ .+ * Err is an instance of MonadIO: The 'Err' monad now supports IO action.+ .+ * File and Directory path validation: Taking advantage of new 'Err'+ capabilities, the library provides new functions for validating 'String's+ inside of 'Term's as being valid\/existent file\/directory paths.+ .+ Changes since 0.2.0:+ .+ * Test friendly 'unwrap' functions: To allow the testing of terms, there are+ now two new functions exported with System.Console.CmdTheLine.Term, 'unwrap'+ and 'unwrapChoice'. As well a datatype representing cause of early exit,+ 'EvalExit' is exported.+ .+ Changes since 0.2.1+ .+ * Added adapter for interfacing with Getopt in module+ 'System.Console.CmdTheLine'. Homepage: http://github.com/eli-frey/cmdtheline License: MIT@@ -23,7 +54,7 @@ Maintainer: Eli Frey <eli.lee.frey gmail com> Stability: Experimental Category: Console-Cabal-version: >=1.6+Cabal-version: >=1.8 Build-type: Simple Extra-source-files: doc/examples/*.hs, README.md@@ -35,14 +66,17 @@ Library hs-source-dirs: src extensions: FlexibleInstances- build-depends: base >= 4.5 && < 5, containers >= 0.4 && < 0.5,+ build-depends: base >= 4.5 && < 5, containers >= 0.4 && < 0.6, parsec >= 3.1 && < 3.2, pretty >= 1.1 && < 1.2,- process >= 1.1, directory >= 1.1, data-default >= 0.4+ process >= 1.1, directory >= 1.1,+ transformers >= 0.2 && < 0.4, filepath >= 1.3 && < 1.4 exposed-modules: System.Console.CmdTheLine, System.Console.CmdTheLine.Arg, System.Console.CmdTheLine.ArgVal,- System.Console.CmdTheLine.Term+ System.Console.CmdTheLine.Term,+ System.Console.CmdTheLine.Util+ System.Console.CmdTheLine.GetOpt other-modules: System.Console.CmdTheLine.Common, System.Console.CmdTheLine.Err,@@ -50,3 +84,23 @@ System.Console.CmdTheLine.Trie, System.Console.CmdTheLine.Manpage, System.Console.CmdTheLine.CmdLine++test-suite Main+ type: exitcode-stdio-1.0+ build-depends: base >= 4 && < 5, HUnit >= 1.2.4 && < 2,+ test-framework >= 0.6 && < 0.9,+ test-framework-hunit >= 0.2 && < 0.4,+ containers >= 0.4 && < 0.6,+ parsec >= 3.1 && < 3.2, pretty >= 1.1 && < 1.2,+ process >= 1.1, directory >= 1.1,+ transformers >= 0.2 && < 0.4, filepath >= 1.3 && < 1.4+ ghc-options: -Wall -Werror -fno-warn-name-shadowing -rtsopts+ hs-source-dirs: src, test+ main-is: Main.hs+ other-modules: Arith,+ Cipher,+ CP,+ Fail,+ FizzBuzz,+ Grep,+ Hello
doc/examples/FizzBuzz.hs view
@@ -35,29 +35,29 @@ ] where verbose =(optInfo [ "verbose", "v" ])- { argDoc = "Give verbose output." }+ { optDoc = "Give verbose output." } silent =(optInfo [ "quiet", "silent", "q", "s" ])- { argDoc = "Provide no output." }+ { optDoc = "Provide no output." } fizz, buzz :: Term String-fizz = opt "Fizz" $ (optInfo [ "Fizz", "fizz", "f" ])- { argDoc = "A string to print in the 'Fizz' case." }+fizz = value $ opt "Fizz" (optInfo [ "Fizz", "fizz", "f" ])+ { optDoc = "A string to print in the 'Fizz' case." } -buzz = opt "Buzz" $ (optInfo [ "Buzz", "buzz", "b" ])- { argDoc = "A string to print in the 'Buzz' case." }+buzz = value $ opt "Buzz" (optInfo [ "Buzz", "buzz", "b" ])+ { optDoc = "A string to print in the 'Buzz' case." } times :: Term Int-times = opt 100 $ (optInfo [ "times", "t" ])- { argName = "TIMES"- , argDoc = "Run $(mname) for the numbers 1 to $(argName)."+times = value $ opt 100 (optInfo [ "times", "t" ])+ { optName = "TIMES"+ , optDoc = "Run $(mname) for the numbers 1 to $(argName)." } term :: Term (IO ()) term = fizzBuzz <$> verbosity <*> fizz <*> buzz <*> times termInfo :: TermInfo-termInfo = def+termInfo = defTI { termName = "FizzBuzz" , version = "v1.0" , termDoc = "An implementation of the world renowned FizzBuzz algorithm."
doc/examples/arith.hs view
@@ -19,19 +19,11 @@ type Parser a = Parsec String () a -data Bin = Pow- | Mul- | Div- | Add- | Sub+data Bin = Pow | Mul | Div | Add | Sub prec :: Bin -> Int prec b = case b of- Pow -> 3- Mul -> 2- Div -> 2- Add -> 1- Sub -> 1+ { Pow -> 3 ; Mul -> 2 ; Div -> 2 ; Add -> 1 ; Sub -> 1 } assoc :: Bin -> Assoc assoc b = case b of@@ -40,35 +32,28 @@ toFunc :: Bin -> (Int -> Int -> Int) toFunc b = case b of- Pow -> (^)- Mul -> (*)- Div -> div- Add -> (+)- Sub -> (-)+ { Pow -> (^) ; Mul -> (*) ; Div -> div ; Add -> (+) ; Sub -> (-) } data Exp = IntExp Int | VarExp String | BinExp Bin Exp Exp instance ArgVal Exp where- parser = fromParsec onErr exp+ converter = ( parser, pretty 0 ) where+ parser = fromParsec onErr exp onErr str = PP.text "invalid expression" PP.<+> PP.quotes (PP.text str) - pp = pretty 0- instance ArgVal (Maybe Exp) where- parser = just- pp = maybePP+ converter = just +instance ArgVal ( String, Exp ) where+ converter = pair '='+ data Assoc = L | R type Env = M.Map String Exp -instance ArgVal ( String, Exp ) where- parser = pair '='- pp = pairPP '='- catParsers :: [Parser String] -> Parser String catParsers = foldl (liftA2 (++)) (return "") @@ -152,31 +137,30 @@ Sub -> PP.char '-' arith :: Bool -> [( String, Exp )] -> Exp -> IO ()-arith pp assoc e = if pp- then maybe badEnv (print . pretty 0) $ beta (M.fromList assoc) e- else maybe badEnv (print . eval) $ beta (M.fromList assoc) e+arith pp assoc = maybe badEnv method . beta (M.fromList assoc) where+ method = if pp then print . pretty 0 else print . eval badEnv = hPutStrLn stderr "arith: bad environment" arithTerm = ( arith <$> pp <*> env <*> e, ti ) where- pp = flag (optInfo [ "pretty", "p" ])- { argName = "PP"- , argDoc = "If present, pretty print instead of evaluating EXP."+ pp = value $ flag (optInfo [ "pretty", "p" ])+ { optName = "PP"+ , optDoc = "If present, pretty print instead of evaluating EXP." } env = nonEmpty $ posRight 0 [] posInfo- { argName = "ENV"- , argDoc = "One or more assignments of the form '<name>=<exp>' to be "+ { posName = "ENV"+ , posDoc = "One or more assignments of the form '<name>=<exp>' to be " ++ "substituted in the input expression." } e = required $ pos 0 Nothing posInfo- { argName = "EXP"- , argDoc = "An arithmetic expression to be evaluated."+ { posName = "EXP"+ , posDoc = "An arithmetic expression to be evaluated." } - ti = def+ ti = defTI { termName = "arith" , version = "0.3" , termDoc = "Evaluate mathematical functions demonstrating precedence "
doc/examples/cipher.hs view
@@ -1,6 +1,5 @@ import System.Console.CmdTheLine import Control.Applicative-import Data.Default import Data.Char ( isUpper, isAlpha, isAlphaNum, isSpace , toLower@@ -136,8 +135,8 @@ comOpts = "COMMON OPTIONS" -- A modified default 'TermInfo' to be shared by commands.-def' :: TermInfo-def' = def+defTI' :: TermInfo+defTI' = defTI { man = [ S comOpts , P "These options are common to all commands."@@ -146,57 +145,57 @@ , S "BUGS" , P "Email bug reports to <snideHighland@example.com>" ]- , stdOptSection = comOpts+ , stdOptSec = comOpts } --- 'input' is a common option. We set its 'argSection' field to 'comOpts' so--- that it is placed under that heading instead of the default '"OPTIONS"'--- heading, which we will reserve for command-specific options.-input = opt Nothing (optInfo [ "input", "i" ])- { argName = "INPUT"- , argDoc = "For specifying input on the command line. If present, "- ++ "input is not read form standard-in."- , argSection = comOpts+-- 'input' is a common option. We set its 'optSec' field to 'comOpts' so+-- that it is placed under that section instead of the default '"OPTIONS"'+-- section, which we will reserve for command-specific options.+input = value $ opt Nothing (optInfo [ "input", "i" ])+ { optName = "INPUT"+ , optDoc = "For specifying input on the command line. If present, "+ ++ "input is not read form standard-in."+ , optSec = comOpts } rotTerm = ( rot <$> back <*> n <*> input, termInfo ) where- back = flag (optInfo [ "back", "b" ])- { argName = "BACK"- , argDoc = "Rotate backwards instead of forwards."+ back = value $ flag (optInfo [ "back", "b" ])+ { optName = "BACK"+ , optDoc = "Rotate backwards instead of forwards." } - n = opt 13 (optInfo [ "n" ])- { argName = "N"- , argDoc = "How many places to rotate by."+ n = value $ opt 13 (optInfo [ "n" ])+ { optName = "N"+ , optDoc = "How many places to rotate by." } - termInfo = def'+ termInfo = defTI' { termName = "rot" , termDoc = "Rotate the input characters by N." , man = [ S "DESCRIPTION" , P $ "Rotate input gathered from INPUT or standard-in N " ++ "places. The input must be composed totally of " ++ "alphabetic characters and spaces."- ] ++ man def'+ ] ++ man defTI' } morseTerm = ( morse <$> from <*> input, termInfo ) where- from = flag (optInfo [ "from", "f" ])- { argName = "FROM"- , argDoc = "Convert from morse-code to the Latin alphabet. "+ from = value $ flag (optInfo [ "from", "f" ])+ { optName = "FROM"+ , optDoc = "Convert from morse-code to the Latin alphabet. " ++ "If absent, convert from Latin alphabet to morse-code." } - termInfo = def'+ termInfo = defTI' { termName = "morse" , termDoc = "Convert to and from morse-code." , man = [ S "DESCRIPTION" , P desc- ] ++ man def'+ ] ++ man defTI' } desc = concat@@ -207,11 +206,11 @@ ] -defaultTerm = ( ret $ const (Left $ HelpFail Pager Nothing) <$> input+defaultTerm = ( ret $ const (helpFail Pager Nothing) <$> input , termInfo ) where- termInfo = def'+ termInfo = defTI' { termName = "cipher" , version = "v1.0" , termDoc = doc
doc/examples/cp.hs view
@@ -2,7 +2,6 @@ import Control.Applicative import System.Directory ( copyFile- , doesFileExist , doesDirectoryExist ) import System.FilePath ( takeFileName@@ -15,82 +14,58 @@ sep = [pathSeparator] -infixr 1 ?--- Like C's ternary operator. 'predicate ? then-clause $ else-clause'.--- Nice for nested, if-elseif style boolean bifurcation.-(?) True = const-(?) False = flip const- cp :: Bool -> [String] -> String -> IO () cp dry sources dest = chooseTactic =<< doesDirectoryExist dest where- chooseTactic isDir = - singleFile ? singleCopy isDir $- not isDir ? notDirErr $- mapM_ copySourcesToDir sources+ chooseTactic isDir+ | singleFile = singleCopy $ head sources+ | not isDir = notDirErr+ | otherwise = mapM_ copyToDir sources+ where+ singleCopy = if isDir then copyToDir else copyToFile singleFile = length sources == 1 - -- Errors notDirErr = do- hPutStrLn stderr $ "cp: target '" ++ dest ++ "' is not a directory"- exitFailure-- notFileErr str = do- hPutStrLn stderr $ "cp: '" ++ str ++ "': no such file"+ hPutStrLn stderr "cp: DEST is not a directory and SOURCES is of length >1." exitFailure - -- Tactics- singleCopy isDir = do- choose =<< doesFileExist filePath- where- choose isFile =- isFile && isDir ? copyToDir filePath $- isFile ? copyToFile filePath $- notFileErr filePath-- filePath = head sources-- copySourcesToDir filePath = do- isFile <- doesFileExist filePath- isFile ? copyToDir filePath- $ notFileErr filePath-- -- File copying copyToDir filePath = if dry then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest' ] else copyFile filePath dest' where dest' = withTrailingSep ++ takeFileName filePath- withTrailingSep = hasTrailingPathSeparator dest ? dest $ dest ++ sep+ withTrailingSep =+ if hasTrailingPathSeparator dest then dest else dest ++ sep copyToFile filePath = if dry then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest ] else copyFile filePath dest --- An example of using the 'rev' and 'Left' variants of 'pos'.-cpTerm = cp <$> dry <*> sources <*> dest+-- An example of using the 'rev' and 'Left' variants of 'pos', as well as+-- validating file paths.+cpTerm = cp <$> dry <*> filesExist sources <*> validPath dest where- dry = flag (optInfo [ "dry", "d" ])- { argName = "DRY"- , argDoc = "Perform a dry run. Print what would be copied, but do not "+ dry = value $ flag (optInfo [ "dry", "d" ])+ { optName = "DRY"+ , optDoc = "Perform a dry run. Print what would be copied, but do not " ++ "copy it." } sources = nonEmpty $ revPosLeft 0 [] posInfo- { argName = "SOURCES"- , argDoc = "Source file(s) to copy."+ { posName = "SOURCES"+ , posDoc = "Source file(s) to copy." } dest = required $ revPos 0 Nothing posInfo- { argName = "DEST"- , argDoc = "Destination of the copy. Must be a directory if there "+ { posName = "DEST"+ , posDoc = "Destination of the copy. Must be a directory if there " ++ "is more than one $(i,SOURCE)." } -termInfo = def+termInfo = defTI { termName = "cp" , version = "v1.0" , termDoc = "Copy files from SOURCES to DEST."
doc/examples/fail.hs view
@@ -13,23 +13,23 @@ cmdNames = [ "msg", "usage", "help", "success" ] failMsg, failUsage, success :: [String] -> Err String-failMsg strs = Left . MsgFail . fsep $ map text strs-failUsage strs = Left . UsageFail . fsep $ map text strs-success strs = Right . concat $ intersperse " " strs+failMsg strs = msgFail . fsep $ map text strs+failUsage strs = usageFail . fsep $ map text strs+success strs = return . concat $ intersperse " " strs help :: String -> Err String help name- | any (== name) cmdNames = Left . HelpFail Pager $ Just name- | name == "" = Left $ HelpFail Pager Nothing+ | any (== name) cmdNames = helpFail Pager $ Just name+ | name == "" = helpFail Pager Nothing | otherwise =- Left . UsageFail $ quotes (text name) <+> text "is not the name of a command"+ usageFail $ quotes (text name) <+> text "is not the name of a command" noCmd :: Err String-noCmd = Left $ HelpFail Pager Nothing+noCmd = helpFail Pager Nothing -def' = def- { stdOptSection = "COMMON OPTIONS"+def' = defTI+ { stdOptSec = "COMMON OPTIONS" , man = [ S "COMMON OPTIONS" , P "These options are common to all commands."@@ -42,8 +42,8 @@ input :: Term [String] input = nonEmpty $ posAny [] posInfo- { argName = "INPUT"- , argDoc = "Some input you would like printed to the screen on failure "+ { posName = "INPUT"+ , posDoc = "Some input you would like printed to the screen on failure " ++ "or success." } @@ -67,7 +67,7 @@ } ) - , ( ret $ help <$> (pos 0 "" posInfo { argName = "TERM" })+ , ( ret $ help <$> value (pos 0 "" posInfo { posName = "TERM" }) , def' { termName = "help" , termDoc = "Display help for a command." }
doc/examples/grep.hs view
@@ -13,9 +13,9 @@ -- An example of using the 'pos' and 'posRight' Terms. grepTerm = ( grep <$> pattern <*> files, termInfo ) where- pattern = required $ pos 0 Nothing posInfo { argName = "PATTERN" }- files = posRight 0 [] posInfo { argName = "FILE" }- termInfo = def+ pattern = required $ pos 0 Nothing posInfo { posName = "PATTERN" }+ files = value $ posRight 0 [] posInfo { posName = "FILE" }+ termInfo = defTI { termName = "grep" , version = "2.5" , termDoc = "Search for PATTERN in FILE(s) or standard in."
doc/examples/hello.hs view
@@ -1,26 +1,25 @@ import System.Console.CmdTheLine import Control.Applicative +import Control.Monad ( when )+ -- Define a flag argument under the names '--silent' and '-s' silent :: Term Bool-silent = flag $ optInfo [ "silent", "s" ]+silent = value . flag $ optInfo [ "silent", "s" ] -- Define the 0th positional argument, defaulting to the value '"world"' in -- absence. greeted :: Term String-greeted = pos 0 "world" posInfo { argName = "GREETED" }+greeted = value $ pos 0 "world" posInfo { posName = "GREETED" } hello :: Bool -> String -> IO ()-hello silent str =- if silent- then return ()- else putStrLn $ "Hello, " ++ str ++ "!"+hello silent str = when (not silent) . putStrLn $ "Hello, " ++ str ++ "!" term :: Term (IO ()) term = hello <$> silent <*> greeted termInfo :: TermInfo-termInfo = def { termName = "Hello", version = "1.0" }+termInfo = defTI { termName = "Hello", version = "1.0" } main :: IO () main = run ( term, termInfo )
src/System/Console/CmdTheLine.hs view
@@ -6,32 +6,31 @@ ( module System.Console.CmdTheLine.Term , module System.Console.CmdTheLine.Arg , module System.Console.CmdTheLine.ArgVal+ , module System.Console.CmdTheLine.Util -- * Terms -- $term , Term() , TermInfo(..)- , Default(..)+ , defTI -- * Manpages , ManBlock(..) - -- * Argument information- , ArgInfo( argDoc, argName, argSection )- -- * User error reporting -- $err- , Fail(..), HelpFormat(..), Err, ret+ , HelpFormat(..), Err()+ , msgFail, usageFail, helpFail+ , ret ) where -import Data.Default import System.Console.CmdTheLine.Common import System.Console.CmdTheLine.Term import System.Console.CmdTheLine.Arg import System.Console.CmdTheLine.ArgVal--import Control.Monad ( join )+import System.Console.CmdTheLine.Err+import System.Console.CmdTheLine.Util {-$term @@ -41,26 +40,25 @@ > import System.Console.CmdTheLine > import Control.Applicative >+> import Control.Monad ( when )+> > -- Define a flag argument under the names '--silent' and '-s' > silent :: Term Bool-> silent = flag $ optInfo [ "silent", "s" ]+> silent = value . flag $ optInfo [ "silent", "s" ] > > -- Define the 0th positional argument, defaulting to the value '"world"' in > -- absence. > greeted :: Term String-> greeted = pos 0 "world" posInfo { argName = "GREETED" }+> greeted = value $ pos 0 "world" posInfo { posName = "GREETED" } > > hello :: Bool -> String -> IO ()-> hello silent str =-> if silent-> then return ()-> else putStrLn $ "Hello, " ++ str ++ "!"+> hello silent str = when (not silent) . putStrLn $ "Hello, " ++ str ++ "!" > > term :: Term (IO ()) > term = hello <$> silent <*> greeted > > termInfo :: TermInfo-> termInfo = def { termName = "Hello", version = "1.0" }+> termInfo = defTI { termName = "Hello", version = "1.0" } > > main :: IO () > main = run ( term, termInfo )@@ -97,19 +95,19 @@ > import Data.List ( intersperse ) > > failMsg, failUsage, success :: [String] -> Err String-> failMsg strs = Left . MsgFail . fsep $ map text strs-> failUsage strs = Left . UsageFail . fsep $ map text strs-> success strs = Right . concat $ intersperse " " strs+> failMsg strs = msgFail . fsep $ map text strs+> failUsage strs = usageFail . fsep $ map text strs+> success strs = return . concat $ intersperse " " strs > > help :: String -> Err String > help name-> | any (== name) cmdNames = Left . HelpFail Pager $ Just name-> | name == "" = Left $ HelpFail Pager Nothing+> | any (== name) cmdNames = helpFail Pager $ Just name+> | name == "" = helpFail Pager Nothing > | otherwise =-> Left . UsageFail $ quotes (text name) <+> text "is not the name of a command"+> usageFail $ quotes (text name) <+> text "is not the name of a command" > > noCmd :: Err String-> noCmd = Left $ HelpFail Pager Nothing+> noCmd = helpFail Pager Nothing We can now turn any of these functions into a @Term String@ by lifting into 'Term' and passing the result to 'ret' to fold the 'Err' monad into the@@ -120,11 +118,7 @@ > > prepedNoCmdTerm :: Term String > prepedNoCmdTerm = ret noCmdTerm--} --- | 'ret' @term@ folds @term@'s 'Err' context into the library to be handled--- internally and as seamlessly as other error messages that are built in.-ret :: Term (Err a) -> Term a-ret (Term ais yield) = Term ais yield'- where- yield' ei cl = join $ yield ei cl+ For other examples of ways to use the 'Err' monad, see the source of the+ *Exists family of functions in "System.Console.CmdTheLine.Util".+-}
src/System/Console/CmdTheLine/Arg.hs view
@@ -3,9 +3,10 @@ - See the file 'LICENSE' for further information. -} module System.Console.CmdTheLine.Arg- (- -- * Creating ArgInfos- optInfo, posInfo+ ( Arg+ -- * Argument Information+ , OptInfo( optName, optDoc, optSec ), PosInfo( posName, posDoc, posSec )+ , optInfo, posInfo -- * Optional arguments -- $opt@@ -20,81 +21,127 @@ -- $pos , pos, revPos, posAny, posLeft, posRight, revPosLeft, revPosRight - -- * Constraining Terms- , required, nonEmpty, lastOf+ -- * Arguments as Terms+ , value, required, nonEmpty, lastOf ) where -import System.Console.CmdTheLine.Common+import System.Console.CmdTheLine.Common hiding ( Arg ) import System.Console.CmdTheLine.CmdLine ( optArg, posArg )-import System.Console.CmdTheLine.ArgVal ( ArgVal(..) )+import System.Console.CmdTheLine.ArgVal ( ArgVal, pp, parser ) import qualified System.Console.CmdTheLine.Err as E-import qualified System.Console.CmdTheLine.Trie as T import Control.Applicative+import Control.Arrow ( second )++import Control.Monad.Trans.Error ( throwError )+ import Text.PrettyPrint -import Data.List ( sort, sortBy )+import Data.List ( sortBy, foldl' ) import Data.Function ( on ) - argFail :: Doc -> Err a-argFail = Left . MsgFail+argFail = throwError . MsgFail --- | Initialize an 'ArgInfo' by providing a list of names. The fields--- @argName@(found at "System.Console.CmdTheLine#argName"),--- @argDoc@(found at "System.Console.CmdTheLine#argDoc"), and--- @argSection@(found at "System.Console.CmdTheLine#argSection")--- can then be manipulated post-mortem, as in+-- | The type of command line arguments.+newtype Arg a = Arg (Term a)++-- | Information about an optional argument. Exposes the folowing fields. ----- > inf =(optInfo [ "i", "insufflation" ])--- > { argName = "INSUFFERABLE"--- > , argDoc = "in the haunted house's harrow"--- > , argSection = "NOT FOR AUGHT"--- > }+-- [@optName@] :: String: defaults to @\"\"@. ----- Names of one character in length will be prefixed by @-@ on the--- command line, while longer names will be prefixed by @--@.+-- [@optDoc@] :: String: defaults to @\"\"@. ----- This function is meant to be used with optional arguments produced by 'flag',--- 'opt', and friends-- not with positional arguments. Positional arguments--- provided with names will yield a run-time error, halting any and all program--- runs. Use 'posInfo' for positional arguments.+-- [@optSec@] :: String: defaults to @\"OPTIONS\"@.+data OptInfo = OInf+ { unOInf :: ArgInfo+ , optName :: String+ , optDoc :: String+ , optSec :: String+ }++fromOptInfo :: OptInfo -> ArgInfo+fromOptInfo oi = (unOInf oi)+ { argName = optName oi+ , argDoc = optDoc oi+ , argSec = optSec oi+ }++-- | Information about a positional argument. Exposes the folowing fields. ----- Likewise, if an optional argument is created with an 'ArgInfo' produced by--- passing an empty list of names to 'optInfo', a run-time error will occur.--- All optional arguments must have names.-optInfo :: [String] -> ArgInfo-optInfo names = ArgInfo+-- [@posName@] :: String: defaults to @\"\"@.+--+-- [@posDoc@] :: String: defaults to @\"\"@.+--+-- [@posSec@] :: String: defautts to @\"ARGUMENTS\"@.+data PosInfo = PInf+ { unPInf :: ArgInfo+ , posName :: String+ , posDoc :: String+ , posSec :: String+ }++fromPosInfo :: PosInfo -> ArgInfo+fromPosInfo pi = (unPInf pi)+ { argName = posName pi+ , argDoc = posDoc pi+ , argSec = posSec pi+ }++mkInfo :: [String] -> ArgInfo+mkInfo names = ArgInfo { absence = Present "" , argDoc = "" , argName = ""- , argSection = defaultSection+ , argSec = "" , posKind = PosAny , optKind = FlagKind , optNames = map dash names , repeatable = False } where- defaultSection- | names == [] = "ARGUMENTS"- | otherwise = "OPTIONS"- dash "" =- error "System.Console.CmdTheLine.Arg.optInfo recieved empty string as name"+ error "System.Console.CmdTheLine.Arg.mkInfo recieved empty string as name" dash str@[_] = "-" ++ str dash str = "--" ++ str --- | As 'optInfo' but for positional arguments, which by virtue of their--- positions require no names. If a positional argument is created with a--- name, a run-time error will occur halting any and all program runs.+-- | Initialize an 'OptInfo' by providing a list of names. The fields+-- @optName@, @optDoc@, and @optSec@ can then be manipulated post-mortem,+-- as in ----- If you mean to create an optional argument, use 'optInfo', and be sure to--- give it a non-empty list of names to avoid these errors.-posInfo :: ArgInfo-posInfo = optInfo []+-- > inf =(optInfo [ "i", "insufflation" ])+-- > { optName = "INSUFFERABLE"+-- > , optDoc = "in the haunted house's harrow"+-- > , optSec = "NOT FOR AUGHT"+-- > }+--+-- Names of one character in length will be prefixed by @-@ on the command line,+-- while longer names will be prefixed by @--@.+--+-- It is considered a programming error to provide an empty list of names to+-- optInfo.+optInfo :: [String] -> OptInfo+optInfo [] =+ error "System.Console.CmdTheLine.Arg.optInfo recieved empty list of names."+optInfo names = OInf (mkInfo names) "" "" "OPTIONS" +-- | Initialize a 'PosInfo'. The fields @posName@, @posDoc@, and @posSec@+-- can then be manipulated post-mortem, as in+--+-- > inf = posInfo+-- > { posName = "DEST"+-- > , posDoc = "A destination for the operation."+-- > , posSec = "DESTINATIONS"+-- > }+--+-- The fields @posName@ and @posDoc@ must be non-empty strings for the argument+-- to be listed with its documentation under the section @posSec@ of generated+-- help.+posInfo :: PosInfo+posInfo = PInf (mkInfo []) "" "" "ARGUMENTS" + {- $opt An optional argument is specified on the command line by a /name/ possibly@@ -133,15 +180,13 @@ -- | Create a command line flag that can appear at most once on the -- command line. Yields @False@ in absence and @True@ in presence.-flag :: ArgInfo -> Term Bool-flag ai =- if isPos ai- then error E.errNotPos- else Term [ai] yield+flag :: OptInfo -> Arg Bool+flag oi = Arg $ Term [ai] yield where+ ai = fromOptInfo oi yield _ cl = case optArg cl ai of- [] -> Right False- [( _, _, Nothing )] -> Right True+ [] -> return False+ [( _, _, Nothing )] -> return True [( _, f, Just v )] -> argFail $ E.flagValue f v (( _, f, _ ) :@@ -150,36 +195,33 @@ -- | As 'flag' but may appear an infinity of times. Yields a list of @True@s -- as long as the number of times present.-flagAll :: ArgInfo -> Term [Bool]-flagAll ai- | isPos ai = error E.errNotPos- | otherwise = Term [ai'] yield+flagAll :: OptInfo -> Arg [Bool]+flagAll oi = Arg $ Term [ai'] yield where+ ai = fromOptInfo oi ai' = ai { repeatable = True } yield _ cl = case optArg cl ai' of- [] -> Right []+ [] -> return [] xs -> mapM truth xs truth ( _, f, mv ) = case mv of- Nothing -> Right True+ Nothing -> return True Just v -> argFail $ E.flagValue f v -- | 'vFlag' @v [ ( v1, ai1 ), ... ]@ is an argument that can be present at most -- once on the command line. It takes on the value @vn@ when appearing as -- @ain@.-vFlag :: a -> [( a, ArgInfo )] -> Term a-vFlag v assoc = Term (map flag assoc) yield+vFlag :: a -> [( a, OptInfo )] -> Arg a+vFlag v assoc = Arg $ Term (map snd assoc') yield where- flag ( _, ai )- | isPos ai = error E.errNotPos- | otherwise = ai+ assoc' = map (second fromOptInfo) assoc - yield _ cl = go Nothing assoc+ yield _ cl = go Nothing assoc' where go mv [] = case mv of- Nothing -> Right v- Just ( _, v ) -> Right v+ Nothing -> return v+ Just ( _, v ) -> return v go mv (( v, ai ) : rest) = case optArg cl ai of [] -> go mv rest@@ -197,15 +239,16 @@ -- | 'vFlagAll' @vs assoc@ is as 'vFlag' except that it can be present an -- infinity of times. In absence, @vs@ is yielded. When present, each -- value is collected in the order they appear.-vFlagAll :: [a] -> [( a, ArgInfo)] -> Term [a]-vFlagAll vs assoc = Term (map flag assoc) yield+vFlagAll :: [a] -> [( a, OptInfo)] -> Arg [a]+vFlagAll vs assoc = Arg $ Term (map flag assoc') yield where+ assoc' = map (second fromOptInfo) assoc flag ( _, ai ) | isPos ai = error E.errNotOpt | otherwise = ai { repeatable = True } yield _ cl = do- result <- foldl addLookup (Right []) assoc+ result <- foldl' addLookup (return []) assoc' case result of [] -> return vs _ -> return . map snd $ sortBy (compare `on` fst) result@@ -215,7 +258,7 @@ xs -> (++) <$> mapM flagVal xs <*> acc where flagVal ( pos, f, mv ) = case mv of- Nothing -> Right ( pos, v )+ Nothing -> return ( pos, v ) Just v -> argFail $ E.flagValue f v @@ -225,26 +268,25 @@ parseOptValue :: ArgVal a => String -> String -> Err a parseOptValue f v = case parser v of- Left e -> Left . UsageFail $ E.optParseValue f e- Right v -> Right v+ Left e -> throwError . UsageFail $ E.optParseValue f e+ Right v -> return v -mkOpt :: ArgVal a => Maybe a -> a -> ArgInfo -> Term a-mkOpt vopt v ai- | isPos ai = error E.errNotOpt- | otherwise = Term [ai'] yield+mkOpt :: ArgVal a => Maybe a -> a -> OptInfo -> Arg a+mkOpt vopt v oi = Arg $ Term [ai'] yield where+ ai = fromOptInfo oi ai' = ai { absence = Present . show $ pp v , optKind = case vopt of Nothing -> OptKind Just dv -> OptVal . show $ pp dv } yield _ cl = case optArg cl ai' of- [] -> Right v+ [] -> return v [( _, f, Just v )] -> parseOptValue f v [( _, f, Nothing )] -> case vopt of Nothing -> argFail $ E.optValueMissing f- Just optv -> Right optv+ Just optv -> return optv (( _, f, _ ) : ( _, g, _ ) :@@ -253,19 +295,18 @@ -- | 'opt' @v ai@ is an optional argument that yields @v@ in absence, or an -- assigned value in presence. If the option is present, but no value is -- assigned, it is considered a user-error and usage is printed on exit.-opt :: ArgVal a => a -> ArgInfo -> Term a+opt :: ArgVal a => a -> OptInfo -> Arg a opt = mkOpt Nothing -- | 'defaultOpt' @def v ai@ is as 'opt' except if it is present and no value is -- assigned on the command line, @def@ is the result.-defaultOpt :: ArgVal a => a -> a -> ArgInfo -> Term a+defaultOpt :: ArgVal a => a -> a -> OptInfo -> Arg a defaultOpt x = mkOpt $ Just x -mkOptAll :: ( ArgVal a, Ord a ) => Maybe a -> [a] -> ArgInfo -> Term [a]-mkOptAll vopt vs ai- | isPos ai = error E.errNotOpt- | otherwise = Term [ai'] yield+mkOptAll :: ( ArgVal a, Ord a ) => Maybe a -> [a] -> OptInfo -> Arg [a]+mkOptAll vopt vs oi = Arg $ Term [ai'] yield where+ ai = fromOptInfo oi ai' = ai { absence = Present "" , repeatable = True , optKind = case vopt of@@ -274,25 +315,25 @@ } yield _ cl = case optArg cl ai' of- [] -> Right vs+ [] -> return vs xs -> map snd . sortBy (compare `on` fst) <$> mapM parse xs parse ( pos, f, mv' ) = case mv' of Just v -> (,) pos <$> parseOptValue f v Nothing -> case vopt of Nothing -> argFail $ E.optValueMissing f- Just dv -> Right ( pos, dv )+ Just dv -> return ( pos, dv ) -- | 'optAll' @vs ai@ is like 'opt' except that it yields @vs@ in absence and -- can appear an infinity of times. The values it is assigned on the command -- line are accumulated in the order they appear.-optAll :: ( ArgVal a, Ord a ) => [a] -> ArgInfo -> Term [a]+optAll :: ( ArgVal a, Ord a ) => [a] -> OptInfo -> Arg [a] optAll = mkOptAll Nothing -- | 'defaultOptAll' @def vs ai@ is like 'optAll' except that if it is present -- without being assigned a value, the value @def@ takes its place in the list -- of results.-defaultOptAll :: ( ArgVal a, Ord a ) => a -> [a] -> ArgInfo -> Term [a]+defaultOptAll :: ( ArgVal a, Ord a ) => a -> [a] -> OptInfo -> Arg [a] defaultOptAll x = mkOptAll $ Just x @@ -317,63 +358,63 @@ parsePosValue :: ArgVal a => ArgInfo -> String -> Err a parsePosValue ai v = case parser v of- Left e -> Left . UsageFail $ E.posParseValue ai e- Right v -> Right v+ Left e -> throwError . UsageFail $ E.posParseValue ai e+ Right v -> return v -mkPos :: ArgVal a => Bool -> Int -> a -> ArgInfo -> Term a-mkPos rev pos v ai = Term [ai'] yield+mkPos :: ArgVal a => Bool -> Int -> a -> PosInfo -> Arg a+mkPos rev pos v oi = Arg $ Term [ai'] yield where+ ai = fromPosInfo oi ai' = ai { absence = Present . show $ pp v , posKind = PosN rev pos } yield _ cl = case posArg cl ai' of- [] -> Right v+ [] -> return v [v] -> parsePosValue ai' v _ -> error "saw list with more than one member in pos converter" -- | 'pos' @n v ai@ is an argument defined by the @n@th positional argument -- on the command line. If absent the value @v@ is returned.-pos :: ArgVal a => Int -> a -> ArgInfo -> Term a+pos :: ArgVal a => Int -> a -> PosInfo -> Arg a pos = mkPos False -- | 'revPos' @n v ai@ is as 'pos' but counting from the end of the command line -- to the front.-revPos :: ArgVal a => Int -> a -> ArgInfo -> Term a+revPos :: ArgVal a => Int -> a -> PosInfo -> Arg a revPos = mkPos True -posList :: ArgVal a => PosKind -> [a] -> ArgInfo -> Term [a]-posList kind vs ai- | isOpt ai = error E.errNotPos- | otherwise = Term [ai'] yield+posList :: ArgVal a => PosKind -> [a] -> PosInfo -> Arg [a]+posList kind vs oi = Arg $ Term [ai'] yield where+ ai = fromPosInfo oi ai' = ai { posKind = kind } yield _ cl = case posArg cl ai' of- [] -> Right vs+ [] -> return vs xs -> mapM (parsePosValue ai') xs -- | 'posAny' @vs ai@ yields a list of all positional arguments or @vs@ if none -- are present.-posAny :: ArgVal a => [a] -> ArgInfo -> Term [a]+posAny :: ArgVal a => [a] -> PosInfo -> Arg [a] posAny = posList PosAny -- | 'posLeft' @n vs ai@ yield a list of all positional arguments to the left of -- the @n@th positional argument or @vs@ if there are none.-posLeft :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]+posLeft :: ArgVal a => Int -> [a] -> PosInfo -> Arg [a] posLeft = posList . PosL False -- | 'posRight' @n vs ai@ is as 'posLeft' except yielding all values to the right -- of the @n@th positional argument.-posRight :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]+posRight :: ArgVal a => Int -> [a] -> PosInfo -> Arg [a] posRight = posList . PosR False -- | 'revPosLeft' @n vs ai@ is as 'posLeft' except @n@ counts from the end of the -- command line to the front.-revPosLeft :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]+revPosLeft :: ArgVal a => Int -> [a] -> PosInfo -> Arg [a] revPosLeft = posList . PosL True -- | 'revPosRight' @n vs ai@ is as 'posRight' except @n@ counts from the end of -- the command line to the front.-revPosRight :: ArgVal a => Int -> [a] -> ArgInfo -> Term [a]+revPosRight :: ArgVal a => Int -> [a] -> PosInfo -> Arg [a] revPosRight = posList . PosR True @@ -381,41 +422,43 @@ -- Arguments as terms. -- +absent :: [ArgInfo] -> [ArgInfo] absent = map (\ ai -> ai { absence = Absent }) --- | 'required' @term@ converts @term@ so that it fails in the 'Nothing' and--- yields @a@ in the 'Just'.+-- | 'value' @arg@ makes @arg@ into a 'Term'.+value :: Arg a -> Term a+value (Arg term) = term++-- | 'required' @arg@ converts @arg@ into a 'Term' such that it fails in the+-- 'Nothing' and yields @a@ in the 'Just'. -- -- This is used for required positional arguments. There is nothing -- stopping you from using it with optional arguments, except that they -- would no longer be optional and it would be confusing from a user's -- perspective.-required :: Term (Maybe a) -> Term a-required (Term ais yield) = Term ais' yield'+required :: Arg (Maybe a) -> Term a+required (Arg (Term ais yield)) = Term ais' yield' where ais' = absent ais- yield' ei cl = case yield ei cl of- Left e -> Left e- Right mv -> maybe (argFail . E.argMissing $ head ais') Right mv+ yield' ei cl = aux =<< yield ei cl+ aux = maybe (argFail . E.argMissing $ head ais') return --- | 'nonEmpty' @term@ is a term that fails if its result is empty. Intended+-- | 'nonEmpty' @arg@ is a 'Term' that fails if its result is empty. Intended -- for non-empty lists of positional arguments.-nonEmpty :: Term [a] -> Term [a]-nonEmpty (Term ais yield) = Term ais' yield'+nonEmpty :: Arg [a] -> Term [a]+nonEmpty (Arg (Term ais yield)) = Term ais' yield' where ais' = absent ais- yield' ei cl = case yield ei cl of- Left e -> Left e- Right [] -> argFail . E.argMissing $ head ais'- Right xs -> Right xs+ yield' ei cl = aux =<< yield ei cl+ aux [] = argFail . E.argMissing $ head ais'+ aux xs = return xs --- | 'lastOf' @term@ is a term that fails if its result is empty and evaluates+-- | 'lastOf' @arg@ is a 'Term' that fails if its result is empty and evaluates -- to the last element of the resulting list otherwise. Intended for lists -- of flags or options where the last takes precedence.-lastOf :: Term [a] -> Term a-lastOf (Term ais yield) = Term ais yield'+lastOf :: Arg [a] -> Term a+lastOf (Arg (Term ais yield)) = Term ais yield' where- yield' ei cl = case yield ei cl of- Left e -> Left e- Right [] -> argFail . E.argMissing $ head ais- Right xs -> Right $ last xs+ yield' ei cl = aux =<< yield ei cl+ aux [] = argFail . E.argMissing $ head ais+ aux xs = return $ last xs
src/System/Console/CmdTheLine/ArgVal.hs view
@@ -6,47 +6,63 @@ module System.Console.CmdTheLine.ArgVal ( -- * Parsing values from the command line- ArgVal(..), ArgParser, ArgPrinter+ ArgParser, ArgPrinter, Converter, ArgVal(..), pp, parser -- ** Helpers for instantiating ArgVal , fromParsec , enum -- *** Maybe values- , just, maybePP+ , just -- *** List values- , list, listPP+ , list -- *** Tuple values- , pair, pairPP- , triple, triplePP- , quadruple, quadruplePP- , quintuple, quintuplePP+ , pair, triple, quadruple, quintuple ) where -import System.Console.CmdTheLine.Common ( splitOn )+import System.Console.CmdTheLine.Common ( splitOn, select, HelpFormat(..) ) import qualified System.Console.CmdTheLine.Err as E import qualified System.Console.CmdTheLine.Trie as T import Control.Arrow ( first, (***) ) import Data.Function ( on )-import Data.List ( sort, unfoldr )+import Data.List ( sort, unfoldr, foldl' ) import Data.Ratio ( Ratio )-import Data.Default+import Data.Tuple ( swap ) import Control.Applicative hiding ( (<|>), empty ) import Text.Parsec hiding ( char ) import Text.PrettyPrint + -- | The type of parsers of individual command line argument values.-type ArgParser a = String -> Either Doc a+type ArgParser a = String -> Either Doc a -- | The type of printers of values retrieved from the command line. type ArgPrinter a = a -> Doc +-- | A converter is just a pair of a parser and a printer.+type Converter a = ( ArgParser a, ArgPrinter a )++-- | The class of values that can be converted from the command line.+class ArgVal a where+ converter :: Converter a++-- | The parsing part of a 'converter'.+parser :: ArgVal a => ArgParser a+parser = fst converter++-- | The pretty printing part of a 'converter'.+pp :: ArgVal a => ArgPrinter a+pp = snd converter++decPoint, digits, sign :: Parsec String () String decPoint = string "." digits = many1 digit-concatParsers = foldl (liftA2 (++)) $ return [] sign = option "" $ string "-" +concatParsers :: [Parsec String () String] -> Parsec String () String+concatParsers = foldl' (liftA2 (++)) $ return []+ pInteger :: ( Read a, Integral a ) => Parsec String () a pFloating :: ( Read a, Floating a ) => Parsec String () a pInteger = read <$> concatParsers [ sign, digits ]@@ -59,234 +75,234 @@ fromParsec onErr p str = either (const . Left $ onErr str) Right $ parse p "" str --- | A parser of 'Maybe' values of 'ArgVal' instances. A convenient default--- that merely lifts the 'ArgVal' instance's parsed value with 'Just'.-just :: ArgVal a => ArgParser (Maybe a)-just = either Left (Right . Just) . parser---- | A printer of 'Maybe' values of 'ArgVal' instances. A convenient default--- that prints nothing on the 'Nothing' and just the value on the 'Just'.-maybePP :: ArgVal a => ArgPrinter (Maybe a)-maybePP = maybe empty id . fmap pp+-- | A converter of 'Maybe' values of 'ArgVal' instances.+-- +-- Parses as:+--+-- > fmap Just . parser+--+-- Pretty prints as:+--+-- > maybe empty pp+just :: ArgVal a => Converter (Maybe a)+just = ( fmap Just . parser, maybe empty pp ) --- | A parser of enumerated values conveyed as an association list of+-- | A converter of enumerated values conveyed as an association list of -- @( string, value )@ pairs. Unambiguous prefixes of @string@ map to -- @value@.-enum :: [( String, a )] -> ArgParser a-enum assoc str = case T.lookup str trie of- Right v -> Right v- Left T.Ambiguous -> Left $ E.ambiguous "enum value" str ambs- Left T.NotFound -> Left . E.invalidVal (text str) $ text "expected" <+> alts+enum :: Eq a => [( String, a )] -> Converter a+enum assoc = ( parser, pp ) where- ambs = sort $ T.ambiguities trie str- alts = E.alts $ map fst assoc- trie = T.fromList assoc+ pp val = select notFoundErr $ map (((== val) *** text) . swap) assoc+ notFoundErr = error $ unlines+ [ "System.Console.CmdTheLine.ArgVal.enum pretty printer saw value not in"+ , "provided association list"+ ] --- | @'list' sep@ creates a parser of lists of an 'ArgVal' instance separated+ parser str = case T.lookup str trie of+ Right v -> Right v+ Left T.Ambiguous -> Left $ E.ambiguous "enum value" str ambs+ Left T.NotFound -> Left $ E.invalidVal (text str) expected+ where+ trie = T.fromList assoc++ expected = text "expected" <+> alts+ alts = E.alts $ map fst assoc++ ambs = sort $ T.ambiguities trie str++-- | @'list' sep@ creates a converter of lists of an 'ArgVal' instance separated -- by @sep@.-list :: ArgVal a => Char -> ArgParser [a]-list sep str = either (Left . E.element "list" str)- Right- . sequence $ unfoldr parseElem str+list :: ArgVal a => Char -> Converter [a]+list sep = ( parser', pp' ) where- parseElem [] = Nothing- parseElem str = Just . first parser $ splitOn sep str+ pp' = fsep . punctuate (char sep) . map pp --- | @'listPP' sep@ creates a pretty printer of lists of an 'ArgVal' instance--- seperated by @sep@.-listPP :: ArgVal a => Char -> ArgPrinter [a]-listPP sep = fsep . punctuate (char sep) . map pp+ parser' str = either (Left . E.element "list" str)+ Right+ . sequence $ unfoldr parseElem str+ where+ parseElem [] = Nothing+ parseElem str = Just . first parser $ splitOn sep str --- | @'pair' sep@ creates a parser of pairs of 'ArgVal' instances separated+-- | @'pair' sep@ creates a converter of pairs of 'ArgVal' instances separated -- by @sep@.-pair :: ( ArgVal a, ArgVal b ) => Char -> ArgParser ( a, b )-pair sep str = do- case yStr of- [] -> Left $ E.sepMiss sep str- _ -> return ()- case ( eX, eY ) of- ( Right x, Right y ) -> Right ( x, y )- ( Left e, _ ) -> Left $ E.element "pair" xStr e- ( _, Left e ) -> Left $ E.element "pair" yStr e+pair :: ( ArgVal a, ArgVal b ) => Char -> Converter ( a, b )+pair sep = ( parser', pp' ) where- ( eX, eY ) = parser *** parser $ xyStr- xyStr@( xStr, yStr ) = splitOn sep str+ pp' ( x, y ) = pp x <> char sep <+> pp y --- | @'pairPP' sep@ creates a pretty printer of pairs of 'ArgVal' instances--- separated by @sep@-pairPP :: ( ArgVal a, ArgVal b ) => Char -> ArgPrinter ( a, b )-pairPP sep ( x, y ) = pp x <> char sep <+> pp y+ parser' str = do+ case yStr of+ [] -> Left $ E.sepMiss sep str+ _ -> return ()+ case ( eX, eY ) of+ ( Right x, Right y ) -> Right ( x, y )+ ( Left e, _ ) -> Left $ E.element "pair" xStr e+ ( _, Left e ) -> Left $ E.element "pair" yStr e+ where+ ( eX, eY ) = parser *** parser $ xyStr+ xyStr@( xStr, yStr ) = splitOn sep str --- | @'triple' sep@ creates a parser of triples of 'ArgVal' instances separated+-- | @'triple' sep@ creates a converter of triples of 'ArgVal' instances separated -- by @sep@.-triple :: ( ArgVal a, ArgVal b, ArgVal c ) => Char -> ArgParser ( a, b, c )-triple sep str = do- [ xStr, yStr, zStr ] <-- if length strs == 3- then Right strs- else Left $ E.sepMiss sep str- case ( parser xStr, parser yStr, parser zStr ) of- ( Right x, Right y, Right z ) -> Right ( x, y, z )- ( Left e, _ , _ ) -> Left $ E.element "pair" xStr e- ( _, Left e, _ ) -> Left $ E.element "pair" yStr e- ( _, _ , Left e ) -> Left $ E.element "pair" zStr e+triple :: ( ArgVal a, ArgVal b, ArgVal c ) => Char -> Converter ( a, b, c )+triple sep = ( parser', pp' ) where- strs = unfoldr split str+ pp' ( x, y, z ) = pp x <> char sep <+> pp y <> char sep <+> pp z - split [] = Nothing- split str = Just $ splitOn sep str+ parser' str = do+ [ xStr, yStr, zStr ] <-+ if length strs == 3+ then Right strs+ else Left $ E.sepMiss sep str+ case ( parser xStr, parser yStr, parser zStr ) of+ ( Right x, Right y, Right z ) -> Right ( x, y, z )+ ( Left e, _ , _ ) -> Left $ E.element "pair" xStr e+ ( _, Left e, _ ) -> Left $ E.element "pair" yStr e+ ( _, _ , Left e ) -> Left $ E.element "pair" zStr e+ where+ strs = unfoldr split str --- | @'triplePP' sep@ creates a pretty printer of triples of 'ArgVal' instances--- separated by @sep@-triplePP :: ( ArgVal a, ArgVal b, ArgVal c ) => Char -> ArgPrinter ( a, b, c )-triplePP sep ( x, y, z ) = pp x <> char sep <+> pp y <> char sep <+> pp z+ split [] = Nothing+ split str = Just $ splitOn sep str --- | @'quadruple' sep@ creates a parser of quadruples of 'ArgVal' instances+-- | @'quadruple' sep@ creates a converter of quadruples of 'ArgVal' instances -- separated by @sep@. quadruple :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d ) =>- Char -> ArgParser ( a, b, c, d )-quadruple sep str = do- [ xStr, yStr, zStr, wStr ] <-- if length strs == 4- then Right strs- else Left $ E.sepMiss sep str-- case ( parser xStr, parser yStr, parser zStr, parser wStr ) of- ( Right x, Right y, Right z, Right w ) -> Right ( x, y, z, w )- ( Left e, _ , _ , _ ) -> Left $ E.element "pair" xStr e- ( _, Left e, _ , _ ) -> Left $ E.element "pair" yStr e- ( _, _ , Left e , _ ) -> Left $ E.element "pair" zStr e- ( _, _ , _ , Left e ) -> Left $ E.element "pair" wStr e+ Char -> Converter ( a, b, c, d )+quadruple sep = ( parser', pp' ) where- strs = unfoldr split str+ pp' ( x, y, z, w ) =+ pp x <> char sep <+> pp y <> char sep <+> pp z <> char sep <+> pp w - split [] = Nothing- split str = Just $ splitOn sep str+ parser' str = do+ [ xStr, yStr, zStr, wStr ] <-+ if length strs == 4+ then Right strs+ else Left $ E.sepMiss sep str --- | @'quadruplePP' sep@ creates a pretty printer of quadruples of 'ArgVal'--- instances separated by @sep@-quadruplePP :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d ) =>- Char -> ArgPrinter ( a, b, c, d )-quadruplePP sep ( x, y, z, w ) =- pp x <> char sep <+> pp y <> char sep <+> pp z <> char sep <+> pp w+ case ( parser xStr, parser yStr, parser zStr, parser wStr ) of+ ( Right x, Right y, Right z, Right w ) -> Right ( x, y, z, w )+ ( Left e, _ , _ , _ ) -> Left $ E.element "pair" xStr e+ ( _, Left e, _ , _ ) -> Left $ E.element "pair" yStr e+ ( _, _ , Left e , _ ) -> Left $ E.element "pair" zStr e+ ( _, _ , _ , Left e ) -> Left $ E.element "pair" wStr e+ where+ strs = unfoldr split str --- | @'quintuple' sep@ creates a parser of quintuples of 'ArgVal' instances+ split [] = Nothing+ split str = Just $ splitOn sep str++-- | @'quintuple' sep@ creates a converter of quintuples of 'ArgVal' instances -- separated by @sep@. quintuple :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d, ArgVal e ) =>- Char -> ArgParser ( a, b, c, d, e )-quintuple sep str = do- [ xStr, yStr, zStr, wStr, vStr ] <-- if length strs == 3- then Right strs- else Left $ E.sepMiss sep str- case ( parser xStr, parser yStr, parser zStr, parser wStr, parser vStr ) of- ( Right x, Right y, Right z, Right w, Right v ) -> Right ( x, y, z, w, v )- ( Left e, _ , _ , _ , _ ) ->- Left $ E.element "pair" xStr e- ( _, Left e, _ , _ , _ ) ->- Left $ E.element "pair" yStr e- ( _, _ , Left e , _ , _ ) ->- Left $ E.element "pair" zStr e- ( _, _ , _ , Left e , _ ) ->- Left $ E.element "pair" wStr e- ( _, _ , _ , _ , Left e ) ->- Left $ E.element "pair" vStr e+ Char -> Converter ( a, b, c, d, e )+quintuple sep = ( parser', pp' ) where- strs = unfoldr split str+ pp' ( x, y, z, w, v ) =+ pp x <> char sep <+> pp y <> char sep <+> pp z <> char sep <+>+ pp w <> char sep <+> pp v - split [] = Nothing- split str = Just $ splitOn sep str+ parser' str = do+ [ xStr, yStr, zStr, wStr, vStr ] <-+ if length strs == 3+ then Right strs+ else Left $ E.sepMiss sep str+ case ( parser xStr, parser yStr, parser zStr, parser wStr, parser vStr ) of+ ( Right x, Right y, Right z, Right w, Right v ) -> Right ( x, y, z, w, v )+ ( Left e, _ , _ , _ , _ ) ->+ Left $ E.element "pair" xStr e+ ( _, Left e, _ , _ , _ ) ->+ Left $ E.element "pair" yStr e+ ( _, _ , Left e , _ , _ ) ->+ Left $ E.element "pair" zStr e+ ( _, _ , _ , Left e , _ ) ->+ Left $ E.element "pair" wStr e+ ( _, _ , _ , _ , Left e ) ->+ Left $ E.element "pair" vStr e+ where+ strs = unfoldr split str --- | @'quintuplePP' sep@ creates a pretty printer of quintuples of 'ArgVal'--- instances separated by @sep@-quintuplePP :: ( ArgVal a, ArgVal b, ArgVal c, ArgVal d, ArgVal e ) =>- Char -> ArgPrinter ( a, b, c, d, e )-quintuplePP sep ( x, y, z, w, v ) =- pp x <> char sep <+> pp y <> char sep <+> pp z <> char sep <+>- pp w <> char sep <+> pp v+ split [] = Nothing+ split str = Just $ splitOn sep str +invalidVal :: String -> String -> Doc invalidVal = E.invalidVal `on` text --- | The class of values that can be parsed from the command line. Instances--- must provide both 'parser' and 'pp'.-class ArgVal a where- parser :: ArgParser a -- ^ A parser of instance values.- pp :: ArgPrinter a -- ^ A pretty printer for instance values.- instance ArgVal Bool where- parser = fromParsec onErr- $ (True <$ string "true") <|> (False <$ string "false")- where- onErr str = E.invalidVal (text str) $ E.alts [ "true", "false" ]-- pp True = text "true"- pp False = text "false"+ converter = enum [( "true", True ), ( "false", False )] instance ArgVal (Maybe Bool) where- parser = just- pp = maybePP+ converter = just instance ArgVal [Char] where- parser = Right- pp = text+ converter = ( Right, text ) instance ArgVal (Maybe [Char]) where- parser = just- pp = maybePP+ converter = just instance ArgVal Int where- parser = fromParsec onErr pInteger+ converter = ( parser, int ) where- onErr str = invalidVal str "expected an integer"- pp = int+ parser = fromParsec onErr pInteger+ where+ onErr str = invalidVal str "expected an integer" instance ArgVal (Maybe Int) where- parser = just- pp = maybePP+ converter = just instance ArgVal Integer where- parser = fromParsec onErr pInteger+ converter = ( parser, integer ) where- onErr str = invalidVal str "expected an integer"- pp = integer+ parser = fromParsec onErr pInteger+ where+ onErr str = invalidVal str "expected an integer" instance ArgVal (Maybe Integer) where- parser = just- pp = maybePP+ converter = just instance ArgVal Float where- parser = fromParsec onErr pFloating+ converter = ( parser, float ) where- onErr str = invalidVal str "expected a floating point number"- pp = float+ parser = fromParsec onErr pFloating+ where+ onErr str = invalidVal str "expected a floating point number" instance ArgVal (Maybe Float) where- parser = just- pp = maybePP+ converter = just instance ArgVal Double where- parser = fromParsec onErr pFloating+ converter = ( parser, double ) where- onErr str = invalidVal str "expected a floating point number"- pp = double+ parser = fromParsec onErr pFloating+ where+ onErr str = invalidVal str "expected a floating point number" instance ArgVal (Maybe Double) where- parser = just- pp = maybePP+ converter = just instance ArgVal (Ratio Integer) where- parser = fromParsec onErr- $ read <$> concatParsers [ int <* spaces- , string "%"- , spaces >> int- ]+ converter = ( parser, rational ) where- int = concatParsers [ sign, digits ]- onErr str =- invalidVal str "expected a ratio in the form '<numerator> % <denominator>'"-- pp = rational+ parser = fromParsec onErr+ $ read <$> concatParsers [ int <* spaces+ , string "%"+ , spaces >> int+ ]+ where+ int = concatParsers [ sign, digits ]+ onErr str =+ invalidVal str "expected a ratio in the form '<numerator> % <denominator>'" instance ArgVal (Maybe (Ratio Integer)) where- parser = just- pp = maybePP+ converter = just++instance ArgVal HelpFormat where+ converter = enum [ ( "pager", Pager )+ , ( "plain", Plain )+ , ( "groff", Groff )+ ]++instance ArgVal (Maybe HelpFormat) where+ converter = just
src/System/Console/CmdTheLine/CmdLine.hs view
@@ -11,15 +11,15 @@ import Control.Applicative import Control.Arrow ( second ) +import Control.Monad.Trans.Error ( throwError )+ import Text.PrettyPrint import Text.Parsec as P import qualified System.Console.CmdTheLine.Trie as T import qualified Data.Map as M -import Data.List ( sort )-import Data.Function ( on )-+import Data.List ( sort, foldl' ) optArg :: CmdLine -> ArgInfo -> [( Int, String, Maybe String )] optArg cl ai = case M.lookup ai cl of@@ -40,19 +40,19 @@ - ArgInfo to an empty list of Arg. -} argInfoIndexes :: [ArgInfo] -> ( T.Trie ArgInfo, [ArgInfo], CmdLine )-argInfoIndexes = foldl go ( T.empty, [], M.empty )+argInfoIndexes = foldl' go ( T.empty, [], M.empty ) where go ( optTrie, posAis, cl ) ai | isPos ai = ( optTrie , ai : posAis , M.insert ai (Pos []) cl )- | otherwise = ( foldl add optTrie $ optNames ai+ | otherwise = ( foldl' add optTrie $ optNames ai , posAis , M.insert ai (Opt []) cl ) where- add t name = T.add t name ai+ add t name = T.add name ai t parseOptArg :: String -> ( String, Maybe String ) parseOptArg str@@ -82,7 +82,7 @@ -- Everything after '"--"' is a position argument. ( args', rest ) = splitOn "--" args go k cl posArgs args = case args of- [] -> Right ( cl, posArgs )+ [] -> return ( cl, posArgs ) str : rest -> if isOpt str then asignOptValue str rest@@ -109,8 +109,8 @@ , tail rest ) - handleErr T.NotFound = Left $ UsageFail unknown- handleErr T.Ambiguous = Left $ UsageFail ambiguous+ handleErr T.NotFound = throwError $ UsageFail unknown+ handleErr T.Ambiguous = throwError $ UsageFail ambiguous unknown = E.unknown "option" name ambiguous = E.ambiguous "option" name ambs@@ -123,15 +123,15 @@ - argument values 'args'. -} processPosArgs :: [ArgInfo] -> ( CmdLine, [String] ) -> Err CmdLine-processPosArgs _ ( cl, [] ) = Right cl+processPosArgs _ ( cl, [] ) = return cl processPosArgs posInfo ( cl, args )- | last <= maxSpec = Right cl'- | otherwise = Left $ UsageFail excess+ | last <= maxSpec = return cl'+ | otherwise = throwError $ UsageFail excess where last = length args - 1 excess = E.posExcess . map text $ takeEnd (last - maxSpec) args - ( cl', maxSpec ) = foldl go ( cl, -1 ) posInfo+ ( cl', maxSpec ) = foldl' go ( cl, -1 ) posInfo takeEnd n = reverse . take n . reverse
src/System/Console/CmdTheLine/Common.hs view
@@ -4,12 +4,14 @@ -} module System.Console.CmdTheLine.Common where -import Data.Default import Data.Function ( on )-import Text.PrettyPrint ( Doc )+import Text.PrettyPrint ( Doc, text )+import Control.Applicative ( Applicative(..) ) import qualified Data.Map as M +import Control.Monad.Trans.Error+ data Absence = Absent | Present String deriving ( Eq )@@ -25,29 +27,11 @@ | PosR Bool Int deriving ( Eq, Ord ) --- | Information about an argument. The following fields are exported for your--- use.------ #argName# ------ [@argName@] :: 'String' A name to be used in the documentation to--- refer to the argument's value. Defaults to @\"\"@.------ #argDoc# ------ [@argDoc@] :: 'String' A documentation string for the argument.--- Defaults to @\"\"@.------ #argSection# ------ [@argSection@] :: 'String' The section under which to place the argument's--- documentation. Defaults to @\"OPTIONS\"@ for optional arguments and--- @\"ARGUMENTS\"@ for positional arguments. data ArgInfo = ArgInfo { absence :: Absence , argDoc :: String , argName :: String- , argSection :: String+ , argSec :: String , posKind :: PosKind , optKind :: OptKind , optNames :: [String]@@ -114,9 +98,9 @@ type Page = ( Title, [ManBlock] ) -- | Information about a 'Term'. It is recommended that 'TermInfo's be--- created by customizing the 'Data.Default' instance, as in+-- created by customizing 'defTI', as in ----- > termInfo = def+-- > termInfo = defTI -- > { termName = "caroline-no" -- > , termDoc = "carry a line off" -- > }@@ -124,36 +108,37 @@ { -- | The name of the command or program represented by the term. Defaults to -- @\"\"@.- termName :: String+ termName :: String -- | Documentation for the term. Defaults to @\"\"@.- , termDoc :: String+ , termDoc :: String -- | The section under which to place the terms documentation. -- Defaults to @\"COMMANDS\"@.- , termSection :: String+ , termSec :: String -- | The section under which to place a term's argument's -- documentation by default. Defaults to @\"OPTIONS\"@.- , stdOptSection :: String+ , stdOptSec :: String -- | A version string. Must be left blank for commands. Defaults to @\"\"@.- , version :: String+ , version :: String -- | A list of 'ManBlock's to append to the default @[ManBlock]@. Defaults -- to @[]@.- , man :: [ManBlock]+ , man :: [ManBlock] } deriving ( Eq ) -instance Default TermInfo where- def = TermInfo- { termName = ""- , version = ""- , termDoc = ""- , termSection = "COMMANDS"- , stdOptSection = "OPTIONS"- , man = []- }+-- | A default 'TermInfo'.+defTI :: TermInfo+defTI = TermInfo+ { termName = ""+ , version = ""+ , termDoc = ""+ , termSec = "COMMANDS"+ , stdOptSec = "OPTIONS"+ , man = []+ } type Command = ( TermInfo, [ArgInfo] ) @@ -163,35 +148,45 @@ , choices :: [Command] -- A list of command-terms. } -data EvalKind = Simple -- The program has no commands.- | Main -- The default program is running.- | Choice -- A command has been chosen.- -- | The format to print help in.-data HelpFormat = Pager | Plain | Groff--data Fail =- -- | An arbitrary message to be printed on failure.- MsgFail Doc+data HelpFormat = Pager | Plain | Groff deriving ( Eq ) - -- | A message to be printed along with the usage on failure.+data Fail = MsgFail Doc | UsageFail Doc-- -- | A format to print the help in and an optional name of the term- -- to print help for. If 'Nothing' is supplied, help will be printed- -- for the currently evaluating term. | HelpFail HelpFormat (Maybe String) +instance Error Fail where+ strMsg = MsgFail . text+ -- | A monad for values in the context of possibly failing with a helpful -- message.-type Err a = Either Fail a+type Err = ErrorT Fail IO + type Yield a = EvalInfo -> CmdLine -> Err a -- | The underlying Applicative of the library. A @Term@ represents a value -- in the context of being computed from the command line arguments. data Term a = Term [ArgInfo] (Yield a) +instance Functor Term where+ fmap = yield . result . result . fmap+ where+ yield f (Term ais y) = Term ais (f y)+ result = (.)++instance Applicative Term where+ pure v = Term [] (\ _ _ -> return v)++ (Term args f) <*> (Term args' v) = Term (args ++ args') wrapped+ where+ wrapped ei cl = f ei cl <*> v ei cl+++data EvalKind = Simple -- The program has no commands.+ | Main -- The default program is running.+ | Choice -- A command has been chosen.+ evalKind :: EvalInfo -> EvalKind evalKind ei | choices ei == [] = Simple@@ -201,7 +196,14 @@ descCompare :: Ord a => a -> a -> Ordering descCompare = flip compare +splitOn :: Eq a => a -> [a] -> ( [a], [a] ) splitOn sep xs = ( left, rest' ) where rest' = if rest == [] then rest else tail rest -- Skip the 'sep'. ( left, rest ) = span (/= sep) xs++select :: a -> [( Bool, a )] -> a+select baseCase = foldr (uncurry (?)) baseCase+ where+ (?) True = const+ (?) False = flip const
src/System/Console/CmdTheLine/Err.hs view
@@ -8,61 +8,105 @@ import qualified System.Console.CmdTheLine.Help as H import Text.PrettyPrint-import Data.List ( intersperse ) +import Control.Monad ( join )+import Control.Monad.Trans.Error+ import System.IO +-- | Fail with an arbitrary message on failure.+msgFail :: Doc -> Err a+msgFail = throwError . MsgFail++-- | Fail with a message along with the usage on failure.+usageFail :: Doc -> Err a+usageFail = throwError . UsageFail++-- | A format to print the help in and an optional name of the term to print+-- help for. If 'Nothing' is supplied, help will be printed for the currently+-- evaluating term.+helpFail :: HelpFormat -> Maybe String -> Err a+helpFail fmt = throwError . HelpFail fmt++-- | 'ret' @term@ folds @term@'s 'Err' context into the library to be handled+-- internally and as seamlessly as other error messages that are built in.+ret :: Term (Err a) -> Term a+ret (Term ais yield) = Term ais yield'+ where+ yield' ei cl = join $ yield ei cl++ hsepMap :: (a -> Doc) -> [a] -> Doc hsepMap f = hsep . map f -doc `leadBy` str = str $+$ nest 0 doc+errArgv :: Doc+errArgv = text "argv array must have at least one element" -errArgv = text "argv array must have at least one element"+errNotOpt, errNotPos :: String errNotOpt = "Option argument without name" errNotPos = "Positional argument with a name"++errHelp :: Doc -> Doc errHelp doc = text "term error, help requested for unknown command" <+> doc +alts :: [String] -> Doc alts [] = error "alts called on empty list"-alts [x] = error "alts called on singleton list"+alts [_] = error "alts called on singleton list" alts [x,y] = hsepMap text [ "either", x, "or", y ] alts xs = text "one of:" <+> fsep (punctuate (char ',') (map text xs)) +invalid :: String -> Doc -> Doc -> Doc invalid kind s exp = hsep [ text "invalid", text kind, quotes s<>char ',', exp ] +invalidVal :: Doc -> Doc -> Doc invalidVal = invalid "value" -no kind s = sep [ text "no", quotes $ s, kind ]+no :: String -> String -> Doc+no kind s = sep [ text "no such", text kind, quotes $ text s ] +notDir :: Doc -> Doc notDir s = quotes (s) <+> text "is not a directory" +isDir :: Doc -> Doc isDir s = quotes (s) <+> text "is a directory" +element :: String -> String -> Doc -> Doc element kind str exp = fsep [ text "invalid element in", text kind, parens . quotes $ text str, exp ] +sepMiss :: Char -> String -> Doc sepMiss sep str = invalidVal (text str) $ hsep [ text "missing a", quotes $ char sep, text "separator" ] +unknown :: String -> String -> Doc unknown kind v = sep [ text "unknown", text kind, quotes $ text v ] +ambiguous :: String -> String -> [String] -> Doc ambiguous kind s ambs = hsep [ text kind, quotes $ text s, text "ambiguous, could be", alts ambs ] +posExcess :: [Doc] -> Doc posExcess excess = text "too many arguments, don't know what to do with" <+> hsepMap prep excess where prep = (<> text ",") . quotes +flagValue :: String -> String -> Doc flagValue f v = hsep [ text "option", quotes $ text f , text "is a flag, it cannot take the argument", quotes $ text v ] +optValueMissing :: String -> Doc optValueMissing f = hsep [ text "option", quotes $ text f, text "needs an argument" ]++optParseValue :: String -> Doc -> Doc optParseValue f e = sep [ text "option" <+> (quotes (text f)<>char ':'), e ]++optRepeated :: String -> String -> Doc optRepeated f f' | f == f' = hsep [ text "option", quotes $ text f, text "cannot be repeated" ]@@ -94,6 +138,7 @@ longName (x : xs) | length x > 2 || xs == [] = x | otherwise = longName xs+ longName [] = undefined print :: Handle -> EvalInfo -> Doc -> IO () print h ei e = hPrint h $ (text . termName . fst $ main ei) <> char ':' <+> e
+ src/System/Console/CmdTheLine/GetOpt.hs view
@@ -0,0 +1,34 @@+-- | Adapter for "System.Console.GetOpt".+module System.Console.CmdTheLine.GetOpt where++import Data.Maybe+import Data.Traversable+import System.Console.GetOpt+import System.Console.CmdTheLine++-- | Sequence a list of @'OptDescr's@ into a term. Absent flags+-- (specified with 'NoArg') are filtered out.+optDescrsTerm :: [OptDescr a] -> Term [a]+optDescrsTerm = fmap catMaybes . sequenceA . map optDescrToTerm++-- | Convert an 'OptDescr' into a 'Term' which returns 'Nothing' if+-- 'NoArg' is specified and the flag is absent or 'Just' the argument+-- otherwise.+optDescrToTerm :: OptDescr a -> Term (Maybe a)+optDescrToTerm (Option shorts longs argDescr descr) =+ case argDescr of+ NoArg x -> fmap (optional x) $ value $ flag $ optInf ""+ ReqArg to name -> fmap (fmap to) $ value $ opt Nothing $ optInf name+ OptArg to name -> fmap (Just . to) $ value $ defaultOpt Nothing Nothing $ optInf name+ where+ optional :: a -> Bool -> Maybe a+ optional x present | present = Just x+ | otherwise = Nothing++ optInf :: String -> OptInfo+ optInf name = (optInfo options) { optDoc = descr+ , optName = name+ }++ options :: [String]+ options = map (:[]) shorts ++ longs
src/System/Console/CmdTheLine/Help.hs view
@@ -2,20 +2,22 @@ - This is open source software distributed under a MIT license. - See the file 'LICENSE' for further information. -}-module System.Console.CmdTheLine.Help where+module System.Console.CmdTheLine.Help+ ( printVersion, invocation, prepSynopsis, print ) where +import Prelude hiding ( print )+ import System.Console.CmdTheLine.Common import qualified System.Console.CmdTheLine.Manpage as Man import Control.Applicative-import Control.Arrow ( first, second )+import Control.Arrow ( first ) import Data.Char ( toUpper, toLower )-import Data.List ( intersperse, sort, sortBy, partition )+import Data.List ( intersperse, sort, sortBy, partition, foldl' ) import Data.Function ( on )-import Data.Maybe ( catMaybes ) -import System.IO+import System.IO hiding ( print ) invocation :: Char -> EvalInfo -> String@@ -60,7 +62,7 @@ where args = concat . intersperse " " $ map snd args' where- args' = sortBy revCmp . foldl formatPos [] . snd $ term ei+ args' = sortBy compare' . foldl' formatPos [] . snd $ term ei formatPos acc ai | isOpt ai = acc@@ -78,38 +80,40 @@ PosN _ _ -> "" _ -> "..." - revCmp ( p, _ ) ( p', _ ) = case ( p', p ) of- ( _, PosAny ) -> LT- ( PosAny, _ ) -> GT- ( PosL _ _, PosR _ _ ) -> LT- ( PosR _ _, PosL _ _ ) -> GT- ( p, p' ) -> bifurcate+ compare' ( p, _ ) ( p', _ ) = case ( p', p ) of+ ( _, PosAny ) -> LT+ ( PosAny, _ ) -> GT+ ( PosL _ _, PosR _ _ ) -> LT+ ( PosR _ _, PosL _ _ ) -> GT+ _ -> comparePos k k' where- bifurcate- | not (getBool p) && not (getBool p') = case ( p, p' ) of- ( PosL _ _, PosN _ _ ) -> if k <= k' then LT else GT- ( PosN _ _, PosL _ _ ) -> if k >= k' then GT else LT- ( PosN _ _, _ ) -> if k <= k' then LT else GT- _ -> if k >= k' then GT else LT-+ comparePos | getBool p && getBool p' = case ( p, p' ) of- ( PosL _ _, PosN _ _ ) -> if k >= k' then LT else GT- ( PosN _ _, PosL _ _ ) -> if k <= k' then GT else LT- ( PosN _ _, _ ) -> if k >= k' then LT else GT- _ -> if k <= k' then GT else LT- where- k = getPos p- k' = getPos p'+ ( PosL _ _, PosN _ _ ) -> flip compare -- if k >= k' then LT else GT+ ( PosN _ _, PosL _ _ ) -> compare -- if k <= k' then GT else LT+ ( PosN _ _, _ ) -> flip compare -- if k >= k' then LT else GT+ _ -> compare -- if k <= k' then GT else LT + | otherwise = case ( p, p' ) of+ ( PosL _ _, PosN _ _ ) -> compare -- if k <= k' then LT else GT+ ( PosN _ _, PosL _ _ ) -> flip compare -- if k >= k' then GT else LT+ ( PosN _ _, _ ) -> compare -- if k <= k' then LT else GT+ _ -> flip compare -- if k >= k' then GT else LT++ k = getPos p+ k' = getPos p'+ getPos x = case x of PosL _ pos -> pos PosR _ pos -> pos PosN _ pos -> pos+ _ -> undefined getBool x = case x of PosL b _ -> b PosR b _ -> b PosN b _ -> b+ _ -> undefined synopsisSection :: EvalInfo -> [ManBlock] synopsisSection ei = [ S "SYNOPSIS", P (synopsis ei) ]@@ -148,7 +152,7 @@ revCmp ai' ai = if secCmp /= EQ then secCmp else compare' ai ai' where- secCmp = (compare `on` argSection) ai ai'+ secCmp = (compare `on` argSec) ai ai' compare' = case ( isOpt ai, isOpt ai' ) of ( True, True ) -> compare `on` key . optNames@@ -162,7 +166,7 @@ where k = map toLower . head $ sortBy descCompare names - format ai = ( argSection ai, I label text )+ format ai = ( argSec ai, I label text ) where label = makeArgLabel ai ++ argvDoc text = substDocName (argName ai) (argDoc ai)@@ -190,21 +194,21 @@ makeCmdItems ei = case evalKind ei of Simple -> [] Choice -> []- Main -> sortBy (descCompare `on` fst) . foldl addCmd [] $ choices ei+ Main -> sortBy (descCompare `on` fst) . foldl' addCmd [] $ choices ei where- addCmd acc ( ti, _ ) = ( termSection ti, I (label ti) (termDoc ti) )+ addCmd acc ( ti, _ ) = ( termSec ti, I (label ti) (termDoc ti) ) : acc label ti = "$(b," ++ termName ti ++ ")" mergeOrphans :: ( [( String, ManBlock )], [Maybe ManBlock] ) -> [ManBlock]-mergeOrphans ( orphans, marked ) = fst $ foldl go ( [], orphans ) marked+mergeOrphans ( orphans, marked ) = fst $ foldl' go ( [], orphans ) marked where go ( acc, orphans ) (Just block) = ( block : acc, orphans ) go ( acc, orphans ) Nothing = ( acc', [] ) where acc' = case orphans of [] -> acc- ( s, _ ) : _ -> let ( result, s' ) = foldl merge ( acc, s ) orphans+ ( s, _ ) : _ -> let ( result, s' ) = foldl' merge ( acc, s ) orphans in S s' : result merge ( acc, secName ) ( secName', item )@@ -215,7 +219,7 @@ -> ( [( String, ManBlock )], [Maybe ManBlock] ) mergeItems items blocks = ( orphans, marked ) where- ( marked, _, _, orphans ) = foldl go ( [Nothing], [], False, items ) blocks+ ( marked, _, _, orphans ) = foldl' go ( [Nothing], [], False, items ) blocks -- 'toInsert' is a list of manblocks that belong in the current section. go ( acc, toInsert, mark, items ) block = case block of@@ -227,6 +231,7 @@ ( toInsert', is' ) = first (map snd) $ partition ((== str) . fst) items acc' = Just sec : marked mark' = str == "DESCRIPTION"+ transition _ = undefined marked = if mark then Nothing : acc' else acc' where@@ -240,6 +245,7 @@ cmp = descCompare `on` fst items = sortBy cmp $ cmds ++ args +eiSubst :: EvalInfo -> [( String, String )] eiSubst ei = [ ( "tname", termName . fst $ term ei ) , ( "mname", termName . fst $ main ei )
src/System/Console/CmdTheLine/Manpage.hs view
@@ -19,7 +19,6 @@ import Data.Maybe ( catMaybes ) import Data.Char ( isSpace )-import Data.List ( subsequences, words ) import Text.Parsec import Text.PrettyPrint hiding ( char )@@ -27,6 +26,7 @@ type Subst = [( String, String )] -- An association list of -- ( replacing, replacement ) pairs. +paragraphIndent, labelIndent :: Int paragraphIndent = 7 labelIndent = 4 @@ -52,17 +52,11 @@ scan = many $ try (string "\\$") <|> try replace <|> pure <$> anyChar - replace = do- string "$("- replacement <- try escape <|> choice replacers <|> safeChars- char ')'- return replacement+ replace = string "$(" >> content <* char ')'+ where+ content = try escape <|> choice replacers <|> safeChars - escape = do- c <- anyChar- char ','- str <- try replace <|> safeChars- return $ esc c str+ escape = esc <$> (anyChar <* char ',') <*> (try replace <|> safeChars) safeChars = many1 $ satisfy (/= ')')
src/System/Console/CmdTheLine/Term.hs view
@@ -2,68 +2,80 @@ - This is open source software distributed under a MIT license. - See the file 'LICENSE' for further information. -}+{-# LANGUAGE FlexibleInstances #-} module System.Console.CmdTheLine.Term ( -- * Evaluating Terms -- ** Simple command line programs- eval, exec, run+ eval, exec, run, unwrap -- ** Multi-command command line programs- , evalChoice, execChoice, runChoice+ , evalChoice, execChoice, runChoice, unwrapChoice++ -- * Exit information for testing+ , EvalExit(..) ) where import System.Console.CmdTheLine.Common import System.Console.CmdTheLine.CmdLine ( create ) import System.Console.CmdTheLine.Arg-import System.Console.CmdTheLine.ArgVal import qualified System.Console.CmdTheLine.Err as E import qualified System.Console.CmdTheLine.Help as H import qualified System.Console.CmdTheLine.Trie as T -import Control.Applicative hiding ( (<|>), empty ) import Control.Arrow ( second )-import Control.Monad ( join )+import Control.Monad ( join, (<=<) ) +import Control.Monad.Trans.Error+ import Data.List ( find, sort ) import Data.Maybe ( fromJust ) import System.Environment ( getArgs )-import System.Exit ( exitFailure )+import System.Exit ( exitFailure, exitSuccess ) import System.IO import Text.PrettyPrint-import Text.Parsec -- -- EvalErr -- -data EvalFail = Help HelpFormat (Maybe String)+-- | Information about the way a 'Term' exited early. Obtained by either+-- 'unwrap'ing or 'unwrapChoice'ing some Term. Handy for testing programs when+-- it is undesirable to exit execution of the entire program when a Term exits+-- early.+data EvalExit = Help HelpFormat (Maybe String) | Usage Doc | Msg Doc | Version -type EvalErr = Either EvalFail+instance Error EvalExit where+ strMsg = Msg . text -fromFail :: Fail -> EvalErr a-fromFail (MsgFail d) = Left $ Msg d-fromFail (UsageFail d) = Left $ Usage d-fromFail (HelpFail fmt mName) = Left $ Help fmt mName+type EvalErr = ErrorT EvalExit IO +fromFail :: Fail -> EvalExit+fromFail (MsgFail d) = Msg d+fromFail (UsageFail d) = Usage d+fromFail (HelpFail fmt mName) = Help fmt mName+ fromErr :: Err a -> EvalErr a-fromErr = either fromFail return+fromErr = mapErrorT . fmap $ either (Left . fromFail) Right -printEvalErr :: EvalInfo -> EvalFail -> IO ()+printEvalErr :: EvalInfo -> EvalExit -> IO a printEvalErr ei fail = case fail of Usage doc -> do E.printUsage stderr ei doc exitFailure Msg doc -> do E.print stderr ei doc exitFailure- Version -> H.printVersion stdout ei- Help fmt mName -> either print (H.print fmt stdout) (eEi mName)+ Version -> do H.printVersion stdout ei+ exitSuccess+ Help fmt mName -> do either print (H.print fmt stdout) (eEi mName)+ exitSuccess where- -- Either we are in the default term, or the commands name is in `mName`.+ -- Either we are in the default Term, or the commands name is in `mName`. eEi = maybe (Right ei { term = main ei }) process -- Either the command name exists, or else it does not and we're in trouble.@@ -75,42 +87,9 @@ ----- Terms as Applicative Functors-----instance Functor Term where- fmap = yield . result . result . fmap- where- yield f (Term ais y) = Term ais (f y)- result = (.)--instance Applicative Term where- pure v = Term [] (\ _ _ -> Right v)-- (Term args f) <*> (Term args' v) = Term (args ++ args') wrapped- where- wrapped ei cl = f ei cl <*> v ei cl----- -- Standard Options -- -instance ArgVal HelpFormat where- parser = enum [ ( "pager", Pager )- , ( "plain", Plain )- , ( "groff", Groff )- ]-- pp Pager = text "pager"- pp Plain = text "plain"- pp Groff = text "groff"--instance ArgVal (Maybe HelpFormat) where- parser = just-- pp = maybePP- addStdOpts :: EvalInfo -> ( Yield (Maybe HelpFormat) , Maybe (Yield Bool) , EvalInfo@@ -121,20 +100,22 @@ "" -> ( [], Nothing ) _ -> ( ais, Just lookup ) where- Term ais lookup = flag (optInfo ["version"])- { argSection = section- , argDoc = "Show version information."+ Term ais lookup = value+ $ flag (optInfo ["version"])+ { optSec = section+ , optDoc = "Show version information." } ( args', hLookup ) = ( ais ++ args, lookup ) where- Term ais lookup = defaultOpt (Just Pager) Nothing (optInfo ["help"])- { argSection = section- , argName = "FMT"- , argDoc = doc+ Term ais lookup = value+ $ defaultOpt (Just Pager) Nothing (optInfo ["help"])+ { optSec = section+ , optName = "FMT"+ , optDoc = doc } - section = stdOptSection . fst $ term ei+ section = stdOptSec . fst $ term ei doc = "Show this help in format $(argName) (pager, plain, or groff)." addArgs = second (args' ++)@@ -148,23 +129,30 @@ -- Evaluation of Terms -- +-- For testing of term, unwrap the value but do not handle errors.+unwrapTerm :: EvalInfo -> Yield a -> [String] -> IO (Either EvalExit a)+unwrapTerm ei yield args = runErrorT $ do+ cl <- fromErr $ create (snd $ term ei) args+ fromErr $ yield ei cl+ evalTerm :: EvalInfo -> Yield a -> [String] -> IO a-evalTerm ei yield args = either handleErr return $ do- ( cl, mResult ) <- fromErr $ do- cl <- create (snd $ term ei') args- mResult <- helpArg ei' cl+evalTerm ei yield args = either handleErr return <=< runErrorT $ do+ ( cl, mResult ) <- fromErr $ do+ cl <- create (snd $ term ei') args+ mResult <- helpArg ei' cl - return ( cl, mResult )+ return ( cl, mResult ) - let success = fromErr $ yield ei' cl+ let success = fromErr $ yield ei' cl - case ( mResult, versionArg ) of- ( Just fmt, _ ) -> Left $ Help fmt mName- ( Nothing, Just vArg ) -> case vArg ei' cl of- Left e -> fromFail e- Right True -> Left Version- Right False -> success- _ -> success+ case ( mResult, versionArg ) of+ ( Just fmt, _ ) -> throwError $ Help fmt mName+ ( Nothing, Just vArg ) -> do tf <- fromErr $ vArg ei' cl+ if tf+ then throwError Version+ else success+ _ -> success+ where ( helpArg, versionArg, ei' ) = addStdOpts ei @@ -175,23 +163,22 @@ defName = termName . fst $ main ei' evalName = termName . fst $ term ei' - handleErr e = do printEvalErr ei' e- exitFailure+ handleErr = printEvalErr ei' chooseTerm :: TermInfo -> [( TermInfo, a )] -> [String] -> Err ( TermInfo, [String] )-chooseTerm ti _ [] = Right ( ti, [] )+chooseTerm ti _ [] = return ( ti, [] ) chooseTerm ti choices args@( arg : rest )- | length arg > 1 && head arg == '-' = Right ( ti, args )+ | length arg > 1 && head arg == '-' = return ( ti, args ) | otherwise = case T.lookup arg index of- Right choice -> Right ( choice, rest )- Left T.NotFound -> Left . UsageFail $ E.unknown com arg- Left T.Ambiguous -> Left . UsageFail $ E.ambiguous com arg ambs+ Right choice -> return ( choice, rest )+ Left T.NotFound -> throwError . UsageFail $ E.unknown com arg+ Left T.Ambiguous -> throwError . UsageFail $ E.ambiguous com arg ambs where index = foldl add T.empty choices- add acc ( choice, _ ) = T.add acc (termName choice) choice+ add acc ( choice, _ ) = T.add (termName choice) choice acc com = "command" ambs = sort $ T.ambiguities index arg@@ -211,16 +198,22 @@ -- User-Facing Functionality -- +type ProcessTo a b = EvalInfo -> Yield a -> [String] -> IO b++-- Share code between 'eval' and 'unwrap' with this HOF.+evalBy :: ProcessTo a b -> [String] -> ( Term a, TermInfo ) -> IO b+evalBy method args termPair@( term, _ ) = method ei yield args+ where+ (Term _ yield) = term+ command = mkCommand termPair+ ei = EvalInfo command command []+ -- | 'eval' @args ( term, termInfo )@ allows the user to pass @args@ directly to -- the evaluation mechanism. This is useful if some kind of pre-processing is -- required. If you do not need to pre-process command line arguments, use one -- of 'exec' or 'run'. On failure the program exits. eval :: [String] -> ( Term a, TermInfo ) -> IO a-eval args termPair@( term, _ ) = evalTerm ei yield args- where- (Term _ yield) = term- command = mkCommand termPair- ei = EvalInfo command command []+eval = evalBy evalTerm -- | 'exec' @( term, termInfo )@ executes a command line program, directly -- grabbing the command line arguments from the environment and returning the@@ -236,27 +229,37 @@ run :: ( Term (IO a), TermInfo ) -> IO a run = join . exec --- | 'evalChoice' @args mainTerm choices@ is analogous to 'eval', but for--- programs that provide a choice of commands.-evalChoice :: [String] -> ( Term a, TermInfo ) -> [( Term a, TermInfo )] -> IO a-evalChoice args mainTerm@( term, termInfo ) choices = do- ( chosen, args' ) <- either handleErr return . fromErr- $ chooseTerm termInfo eiChoices args+-- | 'unwrap' @args ( term, termInfo )@ unwraps a 'Term' without handling errors.+-- The intent is for use in testing of Terms where the programmer would like+-- to consult error state without the program exiting.+unwrap :: [String] -> ( Term a, TermInfo ) -> IO (Either EvalExit a)+unwrap = evalBy unwrapTerm +-- Share code between 'evalChoice' and 'unwrapChoice' with this HOF.+evalChoiceBy :: ProcessTo a b+ -> [String] -> ( Term a, TermInfo ) -> [( Term a, TermInfo )] -> IO b+evalChoiceBy method args mainTerm@( _, termInfo ) choices = do+ ( chosen, args' ) <- either handleErr return =<<+ (runErrorT . fromErr $ chooseTerm termInfo eiChoices args)+ let (Term ais yield) = fst . fromJust . find ((== chosen) . snd) $ mainTerm : choices ei = EvalInfo ( chosen, ais ) mainEi eiChoices - evalTerm ei yield args'+ method ei yield args' where mainEi = mkCommand mainTerm eiChoices = map mkCommand choices -- Only handles errors caused by chooseTerm.- handleErr e = do printEvalErr (chooseTermEi mainTerm choices) e- exitFailure+ handleErr = printEvalErr (chooseTermEi mainTerm choices) +-- | 'evalChoice' @args mainTerm choices@ is analogous to 'eval', but for+-- programs that provide a choice of commands.+evalChoice :: [String] -> ( Term a, TermInfo ) -> [( Term a, TermInfo )] -> IO a+evalChoice = evalChoiceBy evalTerm+ -- | Analogous to 'exec', but for programs that provide a choice of commands. execChoice :: ( Term a, TermInfo ) -> [( Term a, TermInfo )] -> IO a execChoice main choices = do@@ -266,3 +269,8 @@ -- | Analogous to 'run', but for programs that provide a choice of commands. runChoice :: ( Term (IO a), TermInfo ) -> [( Term (IO a), TermInfo )] -> IO a runChoice main = join . execChoice main++-- | Analogous to 'unwrap', but for programs that provide a choice of commands.+unwrapChoice :: [String] -> ( Term a, TermInfo ) -> [( Term a, TermInfo )]+ -> IO (Either EvalExit a)+unwrapChoice = evalChoiceBy unwrapTerm
src/System/Console/CmdTheLine/Trie.hs view
@@ -2,9 +2,14 @@ - This is open source software distributed under a MIT license. - See the file 'LICENSE' for further information. -}-module System.Console.CmdTheLine.Trie where+module System.Console.CmdTheLine.Trie+ ( add, lookup, empty, isEmpty, fromList, ambiguities+ , Trie, LookupFail(..)+ ) where +import Prelude hiding ( lookup ) import qualified Data.Map as M+import Data.List (foldl') {- - This implementation maps any non-ambiguous prefix of a key to its value.@@ -16,12 +21,12 @@ | Key a -- Value bound by an entire key. | Amb -- No Value bound due to ambiguity in the key. | Nil -- Attempt to retrieve a Value from an empty Trie.- deriving (Eq)+ deriving ( Eq ) data Trie a = Trie { val :: Value a- , succs :: CMap (Trie a)- } deriving (Eq)+ , nexts :: CMap (Trie a)+ } deriving ( Eq ) data LookupFail = Ambiguous | NotFound deriving (Show) @@ -31,37 +36,31 @@ isEmpty :: Eq a => Trie a -> Bool isEmpty = (== empty) -add :: Trie a -> String -> a -> Trie a-add t k v = go t k (length k) 0 v (Pre v {- Allocate less. -})+add :: String -> a -> Trie a -> Trie a+add k v t = go t k where- go t k len i v preV =- if i == len- then Trie (Key v) (succs t)- else Trie newVal newSuccs+ go t s = case s of+ [] -> Trie (Key v) next+ c:rest ->+ let t' = maybe empty id $ M.lookup c next+ newNexts = M.insert c (go t' rest) next + in Trie newVal newNexts where- newVal = case val t of- Amb -> Amb- Pre _ -> Amb- v@(Key _) -> v- Nil -> preV+ next = nexts t - newSuccs = M.insert (k !! i) (go t' k len (i + 1) v preV) (succs t)- where- t' = maybe empty id $ M.lookup (k !! i) (succs t)+ newVal = case val t of+ Amb -> Amb+ Pre _ -> Amb+ v'@(Key _) -> v'+ Nil -> Pre v -findNode :: String -> Trie a -> Maybe (Trie a)-findNode k t = go t k (length k) 0+findNode :: Trie a -> String -> Maybe (Trie a)+findNode t = foldl' go (Just t) where- go t k len i =- if i == len- then Just t- else goNext =<< M.lookup (k !! i) (succs t)- where- goNext t' = go t' k len (i + 1)-+ go acc c = M.lookup c . nexts =<< acc lookup :: String -> Trie a -> Either LookupFail a-lookup k t = case findNode k t of+lookup k t = case findNode t k of Nothing -> Left NotFound Just t' -> case val t' of Key v -> Right v@@ -70,10 +69,10 @@ Nil -> Left NotFound ambiguities :: Trie a -> String -> [String]-ambiguities t pre = case findNode pre t of+ambiguities t pre = case findNode t pre of Nothing -> [] Just t' -> case val t' of- Amb -> go [] pre $ M.toList (succs t') : []+ Amb -> go [] pre $ M.toList (nexts t') : [] _ -> [] where@@ -87,7 +86,7 @@ where ( c, t'' ) = top - assocs' = M.toList (succs t'') : bottom : rest+ assocs' = M.toList (nexts t'') : bottom : rest pre' = pre ++ return c acc' = case val t'' of@@ -95,7 +94,10 @@ Nil -> error "saw Nil on descent" _ -> acc + -- FIXME: Handle this better. At least produce a meaningful error message.+ descend _ = undefined+ fromList :: [( String, a )] -> Trie a-fromList assoc = foldl consume empty assoc+fromList assoc = foldl' consume empty assoc where- consume t ( k, v ) = add t k v+ consume t ( k, v ) = add k v t
+ src/System/Console/CmdTheLine/Util.hs view
@@ -0,0 +1,81 @@+{- Copyright © 2012, Vincent Elisha Lee Frey. All rights reserved.+ - This is open source software distributed under a MIT license.+ - See the file 'LICENSE' for further information.+ -}+module System.Console.CmdTheLine.Util+ (+ -- * File path validation+ -- ** Existing path check+ fileExists, dirExists, pathExists+ -- ** Existing paths check+ , filesExist, dirsExist, pathsExist+ -- ** Valid path+ , validPath+ ) where++import Control.Applicative+import Text.PrettyPrint++import System.Console.CmdTheLine.Common+import System.Console.CmdTheLine.Err++import Control.Monad.IO.Class ( liftIO )++import System.Directory ( doesFileExist, doesDirectoryExist )+import System.FilePath ( isValid )++doesFileOrDirExist :: String -> IO Bool+doesFileOrDirExist = liftA2 (||) <$> doesFileExist <*> doesDirectoryExist++check :: (String -> IO Bool) -> String -> String -> Err String+check test errStr path = do+ isDir <- liftIO $ test path+ if isDir+ then return path+ else msgFail $ no errStr path++validate :: (String -> IO Bool) -> String -> Term String -> Term String+validate test errStr = ret . fmap (check test errStr)++validates :: (String -> IO Bool) -> String -> Term [String] -> Term [String]+validates test errStr = ret . fmap (mapM $ check test errStr)++-- | 'fileExists' @term@ checks that 'String' in @term@ is a path to an existing+-- /file/. If it is not, exit with an explanatory message for the user.+fileExists :: Term String -> Term String+fileExists = validate doesFileExist "file"++-- | 'dirExists' @term@ checks that 'String' in @term@ is a path to an existing+-- /directory/. If it is not, exit with an explanatory message for the user.+dirExists :: Term String -> Term String+dirExists = validate doesDirectoryExist "directory"++-- | 'pathExists' @term@ checks that 'String' in @term@ is a path to an existing+-- /file or directory/. If it is not, exit with an explanatory message for the+-- user.+pathExists :: Term String -> Term String+pathExists = validate doesFileOrDirExist "file or directory"++-- | 'filesExist' @term@ is as 'fileExists' but for a @term@ containing a list+-- of file paths.+filesExist :: Term [String] -> Term [String]+filesExist = validates doesFileExist "file"++-- | 'dirsExist' @term@ is as 'dirExists' but for a @term@ containing a list+-- of directory paths.+dirsExist :: Term [String] -> Term [String]+dirsExist = validates doesDirectoryExist "directory"++-- | 'pathsExist' @term@ is as 'pathExists' but for a @term@ containing a list+-- of paths.+pathsExist :: Term [String] -> Term [String]+pathsExist = validates doesFileOrDirExist "file or directory"++-- | 'validPath' @term@ checks that 'String' in @term@ is a valid path under+-- the current operating system. If it is not, exit with an explanatory+-- message for the user.+validPath :: Term String -> Term String+validPath = ret . fmap check+ where+ check str = if isValid str then return str else msgFail $ failDoc str+ failDoc str = quotes (text str) <+> text "is not a valid file path."
+ test/Arith.hs view
@@ -0,0 +1,177 @@+-- We need 'FlexibleInstances to instance 'ArgVal' for 'Maybe Exp' and+-- '( String, Exp )'.+{-# LANGUAGE FlexibleInstances #-}+module Arith where++import Prelude hiding ( exp )+import System.Console.CmdTheLine hiding ( eval )+import Control.Applicative hiding ( (<|>) )++import Control.Monad ( guard )+import Data.Char ( isAlpha )+import Data.Function ( on )++import Text.Parsec+import qualified Text.PrettyPrint as PP++import qualified Data.Map as M++import System.IO++type Parser a = Parsec String () a++data Bin = Pow | Mul | Div | Add | Sub++prec :: Bin -> Int+prec b = case b of+ { Pow -> 3 ; Mul -> 2 ; Div -> 2 ; Add -> 1 ; Sub -> 1 }++assoc :: Bin -> Assoc+assoc b = case b of+ Pow -> R+ _ -> L++toFunc :: Bin -> (Int -> Int -> Int)+toFunc b = case b of+ { Pow -> (^) ; Mul -> (*) ; Div -> div ; Add -> (+) ; Sub -> (-) }++data Exp = IntExp Int+ | VarExp String+ | BinExp Bin Exp Exp++instance ArgVal Exp where+ converter = ( parser, pretty 0 )+ where+ parser = fromParsec onErr exp+ onErr str = PP.text "invalid expression" PP.<+> PP.quotes (PP.text str)++instance ArgVal (Maybe Exp) where+ converter = just++instance ArgVal ( String, Exp ) where+ converter = pair '='++data Assoc = L | R++type Env = M.Map String Exp++catParsers :: [Parser String] -> Parser String+catParsers = foldl (liftA2 (++)) (return "")++integer :: Parser Int+integer = read <$> catParsers [ option "" $ string "-", many1 digit ]++tok :: Parser a -> Parser a+tok p = p <* spaces++parens :: Parser a -> Parser a+parens = between op cp+ where+ op = tok $ char '('+ cp = tok $ char ')'++-- Parse a terminal expression.+term :: Parser Exp+term = parens exp <|> int <|> var+ where+ int = tok $ IntExp <$> try integer -- Try so '-<not-digits>' won't fail.+ var = tok $ VarExp <$> many1 (satisfy isAlpha)++-- Parse a binary operator.+bin :: Parser Bin+bin = choice [ pow, mul, div, add, sub ]+ where+ pow = tok $ Pow <$ char '^'+ mul = tok $ Mul <$ char '*'+ div = tok $ Div <$ char '/'+ add = tok $ Add <$ char '+'+ sub = tok $ Sub <$ char '-'++exp :: Parser Exp+exp = e 0++-- Precedence climbing expressions. See+-- <www.engr.mun.ca/~theo/Misc/exp_parsing.htm> for further information.+e :: Int -> Parser Exp+e p = do+ t <- term+ try (go t) <|> return t+ where+ go e1 = do+ b <- bin+ guard $ prec b >= p++ let q = case assoc b of+ R -> prec b+ L -> prec b + 1+ e2 <- e q++ let expr = BinExp b e1 e2+ try (go expr) <|> return expr++-- Beta reduce by replacing variables in 'e' with values in 'env'.+beta :: Env -> Exp -> Maybe Exp+beta env e = case e of+ VarExp str -> M.lookup str env+ int@(IntExp _) -> return int+ BinExp b e1 e2 -> (liftA2 (BinExp b) `on` beta env) e1 e2++eval :: Exp -> Int+eval e = case e of+ VarExp str -> error $ "saw VarExp " ++ str ++ " while evaluating"+ IntExp i -> i+ BinExp b e1 e2 -> (toFunc b `on` eval) e1 e2++pretty :: Int -> Exp -> PP.Doc+pretty p e = case e of+ VarExp str -> PP.text str+ IntExp i -> PP.int i+ BinExp b e1 e2 -> let q = prec b+ in parensOrNot q $ PP.cat [ pretty q e1, ppBin b, pretty q e2 ]+ where+ parensOrNot q = if q < p then PP.parens else id++ppBin :: Bin -> PP.Doc+ppBin b = case b of+ Pow -> PP.char '^'+ Mul -> PP.char '*'+ Div -> PP.char '/'+ Add -> PP.char '+'+ Sub -> PP.char '-'++arith :: Bool -> [( String, Exp )] -> Exp -> IO ()+arith pp assoc = maybe badEnv method . beta (M.fromList assoc)+ where+ method = if pp then print . pretty 0 else print . eval+ badEnv = hPutStrLn stderr "arith: bad environment"++arithTerm :: Term (IO ())+arithTerm = arith <$> pp <*> env <*> e+ where+ pp = value $ flag (optInfo [ "pretty", "p" ])+ { optName = "PP"+ , optDoc = "If present, pretty print instead of evaluating EXP."+ }++ env = nonEmpty $ posRight 0 [] posInfo+ { posName = "ENV"+ , posDoc = "One or more assignments of the form '<name>=<exp>' to be "+ ++ "substituted in the input expression."+ }++ e = required $ pos 0 Nothing posInfo+ { posName = "EXP"+ , posDoc = "An arithmetic expression to be evaluated."+ }++termInfo :: TermInfo+termInfo = defTI+ { termName = "arith"+ , version = "0.3"+ , termDoc = "Evaluate mathematical functions demonstrating precedence "+ ++ "climbing and instantiating 'ArgVal' for tuples and Parsec "+ ++ "parsers."+ , man = [ S "BUGS"+ , P "Email bug reports to <fitsCarolDo@example.com>"+ ]+ }
+ test/CP.hs view
@@ -0,0 +1,79 @@+module CP where+import System.Console.CmdTheLine+import Control.Applicative++import System.Directory ( copyFile+ , doesDirectoryExist+ )+import System.FilePath ( takeFileName+ , pathSeparator+ , hasTrailingPathSeparator+ )++import System.IO+import System.Exit ( exitFailure )++sep :: String+sep = [pathSeparator]++cp :: Bool -> [String] -> String -> IO ()+cp dry sources dest =+ chooseTactic =<< doesDirectoryExist dest+ where+ chooseTactic isDir+ | singleFile = singleCopy $ head sources+ | not isDir = notDirErr+ | otherwise = mapM_ copyToDir sources+ where+ singleCopy = if isDir then copyToDir else copyToFile++ singleFile = length sources == 1++ notDirErr = do+ hPutStrLn stderr "cp: DEST is not a directory and SOURCES is of length >1."+ exitFailure++ copyToDir filePath = if dry+ then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest' ]+ else copyFile filePath dest'+ where+ dest' = withTrailingSep ++ takeFileName filePath+ withTrailingSep =+ if hasTrailingPathSeparator dest then dest else dest ++ sep++ copyToFile filePath = if dry+ then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest ]+ else copyFile filePath dest+++-- An example of using the 'rev' and 'Left' variants of 'pos', as well as+-- validating file paths.+term :: Term (IO ())+term = cp <$> dry <*> filesExist sources <*> validPath dest+ where+ dry = value $ flag (optInfo [ "dry", "d" ])+ { optName = "DRY"+ , optDoc = "Perform a dry run. Print what would be copied, but do not "+ ++ "copy it."+ }++ sources = nonEmpty $ revPosLeft 0 [] posInfo+ { posName = "SOURCES"+ , posDoc = "Source file(s) to copy."+ }++ dest = required $ revPos 0 Nothing posInfo+ { posName = "DEST"+ , posDoc = "Destination of the copy. Must be a directory if there "+ ++ "is more than one $(i,SOURCE)."+ }++termInfo :: TermInfo+termInfo = defTI+ { termName = "cp"+ , version = "v1.0"+ , termDoc = "Copy files from SOURCES to DEST."+ , man = [ S "BUGS"+ , P "Email bug reports to <portManTwo@example.com>"+ ]+ }
+ test/Cipher.hs view
@@ -0,0 +1,227 @@+module Cipher where+import System.Console.CmdTheLine+import Control.Applicative++import Data.Char ( isUpper, isAlpha, isAlphaNum, isSpace+ , toLower+ )+import Data.List ( intersperse )++import System.IO+import System.Exit++infixr 2 <||>+-- Split a value between predicates and 'or' the results together+(<||>) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+p <||> p' = (||) <$> p <*> p'+++--+-- Rot+--++data Cycle a = Cycle+ { backward :: (Cycle a)+ , at :: a+ , forward :: (Cycle a)+ }++fromList :: [a] -> Cycle a+fromList [] = error "Cycle must have at least one element"+fromList xs = first+ where+ ( first, last ) = go last xs first++ go :: Cycle a -> [a] -> Cycle a -> ( Cycle a, Cycle a )+ go prev [] next = ( next, prev )+ go prev (x : xs) next = ( this, last )+ where+ this = Cycle prev x rest+ (rest,last) = go this xs next++-- Return a Cycle centered on x.+seekTo :: Eq a => a -> Cycle a -> Cycle a+seekTo x xs+ | x == at xs = xs+ | otherwise = seekTo x $ forward xs+ +-- Seek n places forwards or backwards.+seek :: Bool -> Int -> Cycle a -> Cycle a+seek _ 0 xs = xs+seek back n xs = seek back (n - 1) (dir xs)+ where+ dir = if back then backward else forward++lowers, uppers :: Cycle Char+lowers = fromList ['a'..'z']+uppers = fromList ['A'..'Z']++rot :: Bool -> Int -> Maybe String -> IO ()+rot back n mStr = do+ input <- case mStr of+ Nothing -> getContents+ Just str -> return str++ putStrLn $ map rotChar input+ where+ rotChar c = if isAlpha c then c' else c+ where+ c' = at . seek back n $ seekTo c cycle+ cycle = if isUpper c then uppers else lowers+++--+-- Morse+--++switch :: ( a, b ) -> ( b, a )+switch ( x, y ) = ( y, x )++fromCode :: [( String, Char )]+fromCode = map switch toCode++toCode :: [( Char, String )]+toCode =+ [ ( 'a', ".-" ), ( 'b', "-..." ), ( 'c', "-.-." ), ( 'd', "-.." )+ , ( 'e', "." ), ( 'f', "..-." ), ( 'g', "--." ), ( 'h', "...." )+ , ( 'i', ".." ), ( 'j', ".---" ), ( 'k', "-.-" ), ( 'l', ".-.." )+ , ( 'm', "--" ), ( 'n', "-." ), ( 'o', "---" ), ( 'p', ".--." )+ , ( 'q', "--.-" ), ( 'r', ".-." ), ( 's', "..." ), ( 't', "-" )+ , ( 'u', "..-" ), ( 'v', "...-" ), ( 'w', ".--" ), ( 'x', "-..-" )+ , ( 'y', "-.--" ), ( 'z', "--.." ), ( '1', ".----" ), ( '2', "..---" )+ , ( '3', "...--" ), ( '4', "....-" ), ( '5', "....." ), ( '6', "-...." )+ , ( '7', "--..." ), ( '8', "---.." ), ( '9', "----." ), ( '0', "-----" )+ , ( ' ', "/" )+ ]++fromMorse, toMorse :: [String] -> Maybe String+fromMorse = mapM (`lookup` fromCode)+toMorse strs = sepCat " / " <$> mapM convertLetters strs+ where+ convertLetters chars = sepCat " " <$> mapM (`lookup` toCode) chars++ sepCat sep = concat . intersperse sep++morse :: Bool -> Maybe String -> IO ()+morse from mStr = do+ input <- case mStr of+ Nothing -> getContents+ Just str -> return str++ if all pred input+ then return ()+ else do hPutStrLn stderr err+ exitFailure++ convert input+ where+ pred = if from then (== '/') <||> (== '-') <||> (== '.') <||> isSpace+ else isAlphaNum <||> isSpace++ err = if from+ then "cipher: morse input must be all spaces, '/'s, '-'s, and '.'s."+ else "cipher: morse input must be alphanumeric and/or spaces"++ convert str = maybe badConvert putStrLn . convert' . words $ map toLower str+ where+ badConvert = hPutStrLn stderr err >> exitFailure+ where+ err = if from then "cipher: could not convert from morse"+ else "cipher: could not convert to morse"++ convert' = if from then fromMorse else toMorse+++--+-- Terms+--++-- The heading under which to place common options.+comOpts :: String+comOpts = "COMMON OPTIONS"++-- A modified default 'TermInfo' to be shared by commands.+defTI' :: TermInfo+defTI' = defTI+ { man =+ [ S comOpts+ , P "These options are common to all commands."+ , S "MORE HELP"+ , P "Use '$(mname) $(i,COMMAND) --help' for help on a single command."+ , S "BUGS"+ , P "Email bug reports to <snideHighland@example.com>"+ ]+ , stdOptSec = comOpts+ }++-- 'input' is a common option. We set its 'optSec' field to 'comOpts' so+-- that it is placed under that section instead of the default '"OPTIONS"'+-- section, which we will reserve for command-specific options.+input :: Term (Maybe String)+input = value $ opt Nothing (optInfo [ "input", "i" ])+ { optName = "INPUT"+ , optDoc = "For specifying input on the command line. If present, "+ ++ "input is not read form standard-in."+ , optSec = comOpts+ }++rotTerm :: ( Term (IO ()), TermInfo )+rotTerm = ( rot <$> back <*> n <*> input, termInfo )+ where+ back = value $ flag (optInfo [ "back", "b" ])+ { optName = "BACK"+ , optDoc = "Rotate backwards instead of forwards."+ }++ n = value $ opt 13 (optInfo [ "n" ])+ { optName = "N"+ , optDoc = "How many places to rotate by."+ }++ termInfo = defTI'+ { termName = "rot"+ , termDoc = "Rotate the input characters by N."+ , man = [ S "DESCRIPTION"+ , P $ "Rotate input gathered from INPUT or standard-in N "+ ++ "places. The input must be composed totally of "+ ++ "alphabetic characters and spaces."+ ] ++ man defTI'+ }++morseTerm :: ( Term (IO ()), TermInfo )+morseTerm = ( morse <$> from <*> input, termInfo )+ where+ from = value $ flag (optInfo [ "from", "f" ])+ { optName = "FROM"+ , optDoc = "Convert from morse-code to the Latin alphabet. "+ ++ "If absent, convert from Latin alphabet to morse-code."+ }++ termInfo = defTI'+ { termName = "morse"+ , termDoc = "Convert to and from morse-code."+ , man = [ S "DESCRIPTION"+ , P desc+ ] ++ man defTI'+ }++ desc = concat+ [ "Converts input gathered from INPUT or standard in to and from morse "+ , "code. 'dah' is represented by '-', 'dit' by '.'. Each morse character "+ , "is separated from the next by one or more ' '. Morse words are "+ , "separated by a '/'."+ ]+++defaultTerm :: ( Term a, TermInfo )+defaultTerm = ( ret $ const (helpFail Pager Nothing) <$> input+ , termInfo+ )+ where+ termInfo = defTI'+ { termName = "cipher"+ , version = "v1.0"+ , termDoc = doc+ }++ doc = "An implementation of the morse-code and rotational(Caesar) ciphers."
+ test/Fail.hs view
@@ -0,0 +1,83 @@+module Fail where+import System.Console.CmdTheLine+import Control.Applicative++import Text.PrettyPrint ( fsep -- Paragraph fill a list of 'Doc'.+ , text -- Make a 'String' into a 'Doc'.+ , quotes -- Quote a 'Doc'.+ , (<+>) -- Glue two 'Doc' together with a space.+ )++import Data.List ( intersperse )+++cmdNames = [ "msg", "usage", "help", "success" ]++failMsg, failUsage, success :: [String] -> Err String+failMsg strs = msgFail . fsep $ map text strs+failUsage strs = usageFail . fsep $ map text strs+success strs = return . concat $ intersperse " " strs++help :: String -> Err String+help name+ | any (== name) cmdNames = helpFail Pager $ Just name+ | name == "" = helpFail Pager Nothing+ | otherwise =+ usageFail $ quotes (text name) <+> text "is not the name of a command"++noCmd :: Err String+noCmd = helpFail Pager Nothing+++def' = defTI+ { stdOptSec = "COMMON OPTIONS"+ , man =+ [ S "COMMON OPTIONS"+ , P "These options are common to all commands."+ , S "MORE HELP"+ , P "Use '$(mname) $(i,COMMAND) --help' for help on a single command."+ , S "BUGS"+ , P "Email bug reports to <dogWalter@example.com>"+ ]+ }++input :: Term [String]+input = nonEmpty $ posAny [] posInfo+ { posName = "INPUT"+ , posDoc = "Some input you would like printed to the screen on failure "+ ++ "or success."+ }++cmds :: [( Term String, TermInfo )]+cmds =+ [ ( ret $ failMsg <$> input+ , def' { termName = "msg"+ , termDoc = "Print a failure message."+ }+ )++ , ( ret $ failUsage <$> input+ , def' { termName = "usage"+ , termDoc = "Print a usage message."+ }+ )++ , ( ret $ success <$> input+ , def' { termName = "success"+ , termDoc = "Print a message to the screen"+ }+ )++ , ( ret $ help <$> value (pos 0 "" posInfo { posName = "TERM" })+ , def' { termName = "help"+ , termDoc = "Display help for a command."+ }+ )+ ]++noCmdTerm = ( ret $ pure noCmd+ , def' { termName = "fail"+ , termDoc = "A program demoing CmdTheLine's user "+ ++ "error functionality."+ }+ )
+ test/FizzBuzz.hs view
@@ -0,0 +1,68 @@+module FizzBuzz where+import System.Console.CmdTheLine+import Control.Applicative++import System.Exit ( exitSuccess )++data Verbosity = Verbose | Normal | Silent++fizzBuzz :: Verbosity -> String -> String -> Int -> IO ()+fizzBuzz verb fizz buzz n = do+ case verb of+ Verbose -> putStrLn $ concat+ [ "FizzBuzz: Printing the result of FizzBuzz over the numbers 1 to ", show n+ , "\nFizz = ", fizz, "\nBuzz = ", buzz+ ]+ Silent -> exitSuccess+ _ -> return ()++ mapM_ fizzAndBuzzOr [1..n]+ where+ fizzAndBuzzOr n = putStrLn output+ where+ output = case fizz' ++ buzz' of+ "" -> show n+ str -> str++ fizz' = if (n `mod` 3) == 0 then fizz else ""+ buzz' = if (n `mod` 5) == 0 then buzz else ""+++-- A flag that can appear many times on the command line, only the last of+-- which will be counted.+verbosity :: Term Verbosity+verbosity = lastOf $ vFlagAll [Normal] [ ( Verbose, verbose )+ , ( Silent, silent )+ ]+ where+ verbose =(optInfo [ "verbose", "v" ])+ { optDoc = "Give verbose output." }++ silent =(optInfo [ "quiet", "silent", "q", "s" ])+ { optDoc = "Provide no output." }++fizz, buzz :: Term String+fizz = value $ opt "Fizz" (optInfo [ "Fizz", "fizz", "f" ])+ { optDoc = "A string to print in the 'Fizz' case." }++buzz = value $ opt "Buzz" (optInfo [ "Buzz", "buzz", "b" ])+ { optDoc = "A string to print in the 'Buzz' case." }++times :: Term Int+times = value $ opt 100 (optInfo [ "times", "t" ])+ { optName = "TIMES"+ , optDoc = "Run $(mname) for the numbers 1 to $(argName)."+ }++term :: Term (IO ())+term = fizzBuzz <$> verbosity <*> fizz <*> buzz <*> times++termInfo :: TermInfo+termInfo = defTI+ { termName = "FizzBuzz"+ , version = "v1.0"+ , termDoc = "An implementation of the world renowned FizzBuzz algorithm."+ , man = [ S "BUGS"+ , P "Email bug reports to <sirFrancisDrank@example.com>"+ ]+ }
+ test/Grep.hs view
@@ -0,0 +1,28 @@+module Grep where+import System.Console.CmdTheLine+import Control.Applicative++import Data.List ( intersperse )++import System.Cmd ( system )+import System.Exit ( exitWith )++grep :: String -> [String] -> IO ()+grep pattern dests = do+ exitWith =<< system (concat . intersperse " " $ [ "grep", pattern ] ++ dests)++-- An example of using the 'pos' and 'posRight' Terms.+term = grep <$> pattern <*> files+ where+ pattern = required $ pos 0 Nothing posInfo { posName = "PATTERN" }+ files = value $ posRight 0 [] posInfo { posName = "FILE" }++termInfo = defTI+ { termName = "grep"+ , version = "2.5"+ , termDoc = "Search for PATTERN in FILE(s) or standard in."+ , man =+ [ S "BUGS"+ , P "Please send bug reports to <throatWobblerMangrove@example.com>"+ ]+ }
+ test/Hello.hs view
@@ -0,0 +1,23 @@+module Hello where+import System.Console.CmdTheLine+import Control.Applicative++import Control.Monad ( when )++-- Define a flag argument under the names '--silent' and '-s'+silent :: Term Bool+silent = value . flag $ optInfo [ "silent", "s" ]++-- Define the 0th positional argument, defaulting to the value '"world"' in+-- absence.+greeted :: Term String+greeted = value $ pos 0 "world" posInfo { posName = "GREETED" }++hello :: Bool -> String -> IO ()+hello silent str = when (not silent) . putStrLn $ "Hello, " ++ str ++ "!"++term :: Term (IO ())+term = hello <$> silent <*> greeted++termInfo :: TermInfo+termInfo = defTI { termName = "Hello", version = "1.0" }
+ test/Main.hs view
@@ -0,0 +1,117 @@+{-# LANGUAGE CPP #-}+module Main where++import qualified FizzBuzz as FB+import qualified Arith as Ar+import qualified Cipher as Ci+import qualified CP++import Test.HUnit hiding ( Test )+import Test.Framework ( defaultMain, testGroup, Test )+import Test.Framework.Providers.HUnit++import GHC.IO.Handle ( hDuplicate, hDuplicateTo )+import System.IO+import System.Directory ( getTemporaryDirectory )+import System.FilePath ( (</>) )++import System.Console.CmdTheLine ( unwrap, unwrapChoice, EvalExit )+import System.Console.CmdTheLine.Manpage ( substitute, plainEsc )++import Control.Applicative ( (<$>) )++isRight, isLeft :: Either a b -> Bool++isRight (Right _) = True+isRight (Left _) = False++isLeft (Left _) = True+isLeft (Right _) = False++devNull :: String+#if defined(mingw_32_HOST_OS) || defined(__MINGW32__)+devNull = "nul"+#else+devNull = "/dev/null"+#endif++mute :: IO a -> IO a+mute action = do+ withFile devNull WriteMode $ (\ h -> do+ stdout_bak <- hDuplicate stdout+ hDuplicateTo h stdout++ v <- action++ hDuplicateTo stdout_bak stdout+ return v)++withInput :: [String] -> IO a -> IO a+withInput input action = do+ tmpDir <- getTemporaryDirectory+ withFile (tmpDir </> "cmdtheline_test_input") ReadWriteMode (\ h -> do+ stdin_bak <- hDuplicate stdin+ hDuplicateTo h stdin++ mapM_ (hPutStrLn stdin) input+ v <- action++ hDuplicateTo stdin_bak stdin+ return v)++unwrapFB, unwrapAr, unwrapCP, unwrapCi :: [String] -> IO (Either EvalExit (IO ()))+unwrapFB args = unwrap args ( FB.term, FB.termInfo )+unwrapAr args = unwrap args ( Ar.arithTerm, Ar.termInfo )+unwrapCP args = unwrap args ( CP.term, CP.termInfo )+unwrapCi args = unwrapChoice args Ci.defaultTerm [ Ci.rotTerm, Ci.morseTerm ]++tests :: [Test]+tests =+ -- With FizzBuzz we'll test the different forms of option assignment and+ -- flags.+ [ testGroup "FizzBuzz"+ [ testCase " w/o args" . assert $ isRight <$> unwrapFB []+ , testCase " w/ good args" . assert $+ isRight <$> unwrapFB [ "-q", "-s", "-v"+ , "-f", "bob", "--buzz", "ann", "-t20"+ ]+ , testCase " w/ bad args" . assert $ isLeft <$> unwrapFB [ "-zork" ]+ ]++ -- With arith we'll test 'posRight' 'pos' positional argument partitioning.+ , testGroup "arith"+ [ testCase " w/o args" . assert $ isLeft <$> unwrapAr []+ , testCase " w/ good args many" . assert $+ isRight <$> unwrapAr [ "x^2+y*1", "x=2", "y=(11-1)/5" ]+ , testCase " w/ good args one" . assert $+ isRight <$> unwrapAr [ "x^2", "x=2" ]+ , testCase " w/ bad args" . assert $+ isLeft <$> unwrapAr [ "-pretty", "x^2", "x=2" ]+ ]++ -- With cipher we'll test subcommands.+ , testGroup "cipher"+ [ testCase " w/o args" . assert $ isLeft <$> unwrapCi []+ , testCase " morse" . assert $+ isRight <$> withInput ["bob"] (unwrapCi [ "morse" ])+ , testCase " rot" . assert $+ isRight <$> withInput ["bob"] (unwrapCi [ "rot" ])+ ]++ -- With cp we'll test 'revPosLeft' 'revPos' positional argument partitioning.+ , testGroup "cp"+ [ testCase " w/o args" . assert $ isLeft <$> unwrapCP []+ , testCase " w/ good args many" . assert $+ isRight <$> unwrapCP [ "-d", "cmdtheline.cabal", "LICENSE", "test" ]+ , testCase " w/ good args one" . assert $+ isRight <$> unwrapCP [ "-d", "cmdtheline.cabal", "foo" ]+ ]++ , testGroup "unittests"+ [ testCase " escaping $(i,...)" . assert $ substitute plainEsc [] "$(i,foo)" == "foo"+ , testCase " escaping $(b,...)" . assert $ substitute plainEsc [] "$(b,foo)" == "foo"+ ]+ ]++main :: IO ()+main = defaultMain tests