diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,8 @@ -CmdTheLine v0.1 +CmdTheLine v0.2.1 =============== +[![Build Status](https://secure.travis-ci.org/eli-frey/cmdtheline.png)](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 ------- diff --git a/cmdtheline.cabal b/cmdtheline.cabal --- a/cmdtheline.cabal +++ b/cmdtheline.cabal @@ -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 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 + . + . Suggestions, comments, and bug reports are appreciated. Please see the bug and issue tracker at . - + . + 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 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 diff --git a/doc/examples/FizzBuzz.hs b/doc/examples/FizzBuzz.hs --- a/doc/examples/FizzBuzz.hs +++ b/doc/examples/FizzBuzz.hs @@ -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." diff --git a/doc/examples/arith.hs b/doc/examples/arith.hs --- a/doc/examples/arith.hs +++ b/doc/examples/arith.hs @@ -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 '=' to be " + { posName = "ENV" + , posDoc = "One or more assignments of the form '=' 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 " diff --git a/doc/examples/cipher.hs b/doc/examples/cipher.hs --- a/doc/examples/cipher.hs +++ b/doc/examples/cipher.hs @@ -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 " ] - , 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 diff --git a/doc/examples/cp.hs b/doc/examples/cp.hs --- a/doc/examples/cp.hs +++ b/doc/examples/cp.hs @@ -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." diff --git a/doc/examples/fail.hs b/doc/examples/fail.hs --- a/doc/examples/fail.hs +++ b/doc/examples/fail.hs @@ -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." } diff --git a/doc/examples/grep.hs b/doc/examples/grep.hs --- a/doc/examples/grep.hs +++ b/doc/examples/grep.hs @@ -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." diff --git a/doc/examples/hello.hs b/doc/examples/hello.hs --- a/doc/examples/hello.hs +++ b/doc/examples/hello.hs @@ -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 ) diff --git a/src/System/Console/CmdTheLine.hs b/src/System/Console/CmdTheLine.hs --- a/src/System/Console/CmdTheLine.hs +++ b/src/System/Console/CmdTheLine.hs @@ -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". +-} diff --git a/src/System/Console/CmdTheLine/Arg.hs b/src/System/Console/CmdTheLine/Arg.hs --- a/src/System/Console/CmdTheLine/Arg.hs +++ b/src/System/Console/CmdTheLine/Arg.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/ArgVal.hs b/src/System/Console/CmdTheLine/ArgVal.hs --- a/src/System/Console/CmdTheLine/ArgVal.hs +++ b/src/System/Console/CmdTheLine/ArgVal.hs @@ -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 ' % '" - - 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 ' % '" 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 diff --git a/src/System/Console/CmdTheLine/CmdLine.hs b/src/System/Console/CmdTheLine/CmdLine.hs --- a/src/System/Console/CmdTheLine/CmdLine.hs +++ b/src/System/Console/CmdTheLine/CmdLine.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Common.hs b/src/System/Console/CmdTheLine/Common.hs --- a/src/System/Console/CmdTheLine/Common.hs +++ b/src/System/Console/CmdTheLine/Common.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Err.hs b/src/System/Console/CmdTheLine/Err.hs --- a/src/System/Console/CmdTheLine/Err.hs +++ b/src/System/Console/CmdTheLine/Err.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/GetOpt.hs b/src/System/Console/CmdTheLine/GetOpt.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/GetOpt.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Help.hs b/src/System/Console/CmdTheLine/Help.hs --- a/src/System/Console/CmdTheLine/Help.hs +++ b/src/System/Console/CmdTheLine/Help.hs @@ -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 ) diff --git a/src/System/Console/CmdTheLine/Manpage.hs b/src/System/Console/CmdTheLine/Manpage.hs --- a/src/System/Console/CmdTheLine/Manpage.hs +++ b/src/System/Console/CmdTheLine/Manpage.hs @@ -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 (/= ')') diff --git a/src/System/Console/CmdTheLine/Term.hs b/src/System/Console/CmdTheLine/Term.hs --- a/src/System/Console/CmdTheLine/Term.hs +++ b/src/System/Console/CmdTheLine/Term.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Trie.hs b/src/System/Console/CmdTheLine/Trie.hs --- a/src/System/Console/CmdTheLine/Trie.hs +++ b/src/System/Console/CmdTheLine/Trie.hs @@ -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 diff --git a/src/System/Console/CmdTheLine/Util.hs b/src/System/Console/CmdTheLine/Util.hs new file mode 100644 --- /dev/null +++ b/src/System/Console/CmdTheLine/Util.hs @@ -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." diff --git a/test/Arith.hs b/test/Arith.hs new file mode 100644 --- /dev/null +++ b/test/Arith.hs @@ -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 '-' 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 +-- 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 '=' 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 " + ] + } diff --git a/test/CP.hs b/test/CP.hs new file mode 100644 --- /dev/null +++ b/test/CP.hs @@ -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 " + ] + } diff --git a/test/Cipher.hs b/test/Cipher.hs new file mode 100644 --- /dev/null +++ b/test/Cipher.hs @@ -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 " + ] + , 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." diff --git a/test/Fail.hs b/test/Fail.hs new file mode 100644 --- /dev/null +++ b/test/Fail.hs @@ -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 " + ] + } + +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." + } + ) diff --git a/test/FizzBuzz.hs b/test/FizzBuzz.hs new file mode 100644 --- /dev/null +++ b/test/FizzBuzz.hs @@ -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 " + ] + } diff --git a/test/Grep.hs b/test/Grep.hs new file mode 100644 --- /dev/null +++ b/test/Grep.hs @@ -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 " + ] + } diff --git a/test/Hello.hs b/test/Hello.hs new file mode 100644 --- /dev/null +++ b/test/Hello.hs @@ -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" } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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