cmdtheline 0.1.1 → 0.2.0.0
raw patch · 20 files changed
+700/−583 lines, 20 filesdep +filepathdep +transformersdep −data-default
Dependencies added: filepath, transformers
Dependencies removed: data-default
Files
- README.md +1/−1
- cmdtheline.cabal +23/−4
- doc/examples/FizzBuzz.hs +10/−10
- doc/examples/arith.hs +19/−35
- doc/examples/cipher.hs +26/−27
- doc/examples/cp.hs +20/−45
- doc/examples/fail.hs +12/−12
- doc/examples/grep.hs +3/−3
- doc/examples/hello.hs +6/−7
- src/System/Console/CmdTheLine.hs +26/−27
- src/System/Console/CmdTheLine/Arg.hs +166/−124
- src/System/Console/CmdTheLine/ArgVal.hs +180/−177
- src/System/Console/CmdTheLine/CmdLine.hs +8/−6
- src/System/Console/CmdTheLine/Common.hs +39/−53
- src/System/Console/CmdTheLine/Err.hs +26/−3
- src/System/Console/CmdTheLine/Help.hs +3/−3
- src/System/Console/CmdTheLine/Manpage.hs +0/−0
- src/System/Console/CmdTheLine/Term.hs +50/−46
- src/System/Console/CmdTheLine/Trie.hs +0/−0
- src/System/Console/CmdTheLine/Util.hs +82/−0
README.md view
@@ -1,4 +1,4 @@-CmdTheLine v0.1+CmdTheLine v0.2 =============== Command line option parsing with applicative functors.
cmdtheline.cabal view
@@ -1,6 +1,6 @@ Name: cmdtheline-Version: 0.1.1-Synopsis: Declaritive command-line option parsing and documentation library.+Version: 0.2.0.0+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.@@ -14,6 +14,23 @@ . Suggestions, comments, and bug reports are appreciated. Please see the bug and issue tracker at <http://github.com/eli-frey/cmdtheline>.+ .+ Changes since 0.1:+ .+ * More type safety: Types in CmdTheLine.Arg have been made more explicit to+ disalow unwanted behavior. Positional argument information and optional+ argument information are distinguished from each other. As well 'Arg's must+ be transformed into 'Term' before use, as some operations make since to+ perform on 'Arg' but not on 'Term'.+ .+ * ArgVal has only one method: 'parser' and 'pp' have been fused into a tuple, so+ that instantiation of 'ArgVal' can be simplified for all parties.+ .+ * Err is an instance of MonadIO: The 'Err' monad now supports IO action.+ .+ * File and Directory path validation: Taking advantage of new 'Err'+ capabilities, the library provides new functions for validating 'String's+ inside of 'Term's as being valid\/existent file\/directory paths. Homepage: http://github.com/eli-frey/cmdtheline@@ -37,12 +54,14 @@ extensions: FlexibleInstances build-depends: base >= 4.5 && < 5, containers >= 0.4 && < 0.5, 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.3 && < 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 other-modules: System.Console.CmdTheLine.Common, System.Console.CmdTheLine.Err,
doc/examples/FizzBuzz.hs view
@@ -35,29 +35,29 @@ ] where verbose =(optInfo [ "verbose", "v" ])- { argDoc = "Give verbose output." }+ { optDoc = "Give verbose output." } silent =(optInfo [ "quiet", "silent", "q", "s" ])- { argDoc = "Provide no output." }+ { optDoc = "Provide no output." } fizz, buzz :: Term String-fizz = opt "Fizz" $ (optInfo [ "Fizz", "fizz", "f" ])- { argDoc = "A string to print in the 'Fizz' case." }+fizz = value $ opt "Fizz" (optInfo [ "Fizz", "fizz", "f" ])+ { optDoc = "A string to print in the 'Fizz' case." } -buzz = opt "Buzz" $ (optInfo [ "Buzz", "buzz", "b" ])- { argDoc = "A string to print in the 'Buzz' case." }+buzz = value $ opt "Buzz" (optInfo [ "Buzz", "buzz", "b" ])+ { optDoc = "A string to print in the 'Buzz' case." } times :: Term Int-times = opt 100 $ (optInfo [ "times", "t" ])- { argName = "TIMES"- , argDoc = "Run $(mname) for the numbers 1 to $(argName)."+times = value $ opt 100 (optInfo [ "times", "t" ])+ { optName = "TIMES"+ , optDoc = "Run $(mname) for the numbers 1 to $(argName)." } term :: Term (IO ()) term = fizzBuzz <$> verbosity <*> fizz <*> buzz <*> times termInfo :: TermInfo-termInfo = def+termInfo = defTI { termName = "FizzBuzz" , version = "v1.0" , termDoc = "An implementation of the world renowned FizzBuzz algorithm."
doc/examples/arith.hs view
@@ -19,19 +19,11 @@ type Parser a = Parsec String () a -data Bin = Pow- | Mul- | Div- | Add- | Sub+data Bin = Pow | Mul | Div | Add | Sub prec :: Bin -> Int prec b = case b of- Pow -> 3- Mul -> 2- Div -> 2- Add -> 1- Sub -> 1+ { Pow -> 3 ; Mul -> 2 ; Div -> 2 ; Add -> 1 ; Sub -> 1 } assoc :: Bin -> Assoc assoc b = case b of@@ -40,35 +32,28 @@ toFunc :: Bin -> (Int -> Int -> Int) toFunc b = case b of- Pow -> (^)- Mul -> (*)- Div -> div- Add -> (+)- Sub -> (-)+ { Pow -> (^) ; Mul -> (*) ; Div -> div ; Add -> (+) ; Sub -> (-) } data Exp = IntExp Int | VarExp String | BinExp Bin Exp Exp instance ArgVal Exp where- parser = fromParsec onErr exp+ converter = ( parser, pretty 0 ) where+ parser = fromParsec onErr exp onErr str = PP.text "invalid expression" PP.<+> PP.quotes (PP.text str) - pp = pretty 0- instance ArgVal (Maybe Exp) where- parser = just- pp = maybePP+ converter = just +instance ArgVal ( String, Exp ) where+ converter = pair '='+ data Assoc = L | R type Env = M.Map String Exp -instance ArgVal ( String, Exp ) where- parser = pair '='- pp = pairPP '='- catParsers :: [Parser String] -> Parser String catParsers = foldl (liftA2 (++)) (return "") @@ -152,31 +137,30 @@ Sub -> PP.char '-' arith :: Bool -> [( String, Exp )] -> Exp -> IO ()-arith pp assoc e = if pp- then maybe badEnv (print . pretty 0) $ beta (M.fromList assoc) e- else maybe badEnv (print . eval) $ beta (M.fromList assoc) e+arith pp assoc = maybe badEnv method . beta (M.fromList assoc) where+ method = if pp then print . pretty 0 else print . eval badEnv = hPutStrLn stderr "arith: bad environment" arithTerm = ( arith <$> pp <*> env <*> e, ti ) where- pp = flag (optInfo [ "pretty", "p" ])- { argName = "PP"- , argDoc = "If present, pretty print instead of evaluating EXP."+ pp = value $ flag (optInfo [ "pretty", "p" ])+ { optName = "PP"+ , optDoc = "If present, pretty print instead of evaluating EXP." } env = nonEmpty $ posRight 0 [] posInfo- { argName = "ENV"- , argDoc = "One or more assignments of the form '<name>=<exp>' to be "+ { posName = "ENV"+ , posDoc = "One or more assignments of the form '<name>=<exp>' to be " ++ "substituted in the input expression." } e = required $ pos 0 Nothing posInfo- { argName = "EXP"- , argDoc = "An arithmetic expression to be evaluated."+ { posName = "EXP"+ , posDoc = "An arithmetic expression to be evaluated." } - ti = def+ ti = defTI { termName = "arith" , version = "0.3" , termDoc = "Evaluate mathematical functions demonstrating precedence "
doc/examples/cipher.hs view
@@ -1,6 +1,5 @@ import System.Console.CmdTheLine import Control.Applicative-import Data.Default import Data.Char ( isUpper, isAlpha, isAlphaNum, isSpace , toLower@@ -136,8 +135,8 @@ comOpts = "COMMON OPTIONS" -- A modified default 'TermInfo' to be shared by commands.-def' :: TermInfo-def' = def+defTI' :: TermInfo+defTI' = defTI { man = [ S comOpts , P "These options are common to all commands."@@ -146,57 +145,57 @@ , S "BUGS" , P "Email bug reports to <snideHighland@example.com>" ]- , stdOptSection = comOpts+ , stdOptSec = comOpts } --- 'input' is a common option. We set its 'argSection' field to 'comOpts' so--- that it is placed under that heading instead of the default '"OPTIONS"'--- heading, which we will reserve for command-specific options.-input = opt Nothing (optInfo [ "input", "i" ])- { argName = "INPUT"- , argDoc = "For specifying input on the command line. If present, "- ++ "input is not read form standard-in."- , argSection = comOpts+-- 'input' is a common option. We set its 'optSec' field to 'comOpts' so+-- that it is placed under that section instead of the default '"OPTIONS"'+-- section, which we will reserve for command-specific options.+input = value $ opt Nothing (optInfo [ "input", "i" ])+ { optName = "INPUT"+ , optDoc = "For specifying input on the command line. If present, "+ ++ "input is not read form standard-in."+ , optSec = comOpts } rotTerm = ( rot <$> back <*> n <*> input, termInfo ) where- back = flag (optInfo [ "back", "b" ])- { argName = "BACK"- , argDoc = "Rotate backwards instead of forwards."+ back = value $ flag (optInfo [ "back", "b" ])+ { optName = "BACK"+ , optDoc = "Rotate backwards instead of forwards." } - n = opt 13 (optInfo [ "n" ])- { argName = "N"- , argDoc = "How many places to rotate by."+ n = value $ opt 13 (optInfo [ "n" ])+ { optName = "N"+ , optDoc = "How many places to rotate by." } - termInfo = def'+ termInfo = defTI' { termName = "rot" , termDoc = "Rotate the input characters by N." , man = [ S "DESCRIPTION" , P $ "Rotate input gathered from INPUT or standard-in N " ++ "places. The input must be composed totally of " ++ "alphabetic characters and spaces."- ] ++ man def'+ ] ++ man defTI' } morseTerm = ( morse <$> from <*> input, termInfo ) where- from = flag (optInfo [ "from", "f" ])- { argName = "FROM"- , argDoc = "Convert from morse-code to the Latin alphabet. "+ from = value $ flag (optInfo [ "from", "f" ])+ { optName = "FROM"+ , optDoc = "Convert from morse-code to the Latin alphabet. " ++ "If absent, convert from Latin alphabet to morse-code." } - termInfo = def'+ termInfo = defTI' { termName = "morse" , termDoc = "Convert to and from morse-code." , man = [ S "DESCRIPTION" , P desc- ] ++ man def'+ ] ++ man defTI' } desc = concat@@ -207,11 +206,11 @@ ] -defaultTerm = ( ret $ const (Left $ HelpFail Pager Nothing) <$> input+defaultTerm = ( ret $ const (helpFail Pager Nothing) <$> input , termInfo ) where- termInfo = def'+ termInfo = defTI' { termName = "cipher" , version = "v1.0" , termDoc = doc
doc/examples/cp.hs view
@@ -2,7 +2,6 @@ import Control.Applicative import System.Directory ( copyFile- , doesFileExist , doesDirectoryExist ) import System.FilePath ( takeFileName@@ -15,82 +14,58 @@ sep = [pathSeparator] -infixr 1 ?--- Like C's ternary operator. 'predicate ? then-clause $ else-clause'.--- Nice for nested, if-elseif style boolean bifurcation.-(?) True = const-(?) False = flip const- cp :: Bool -> [String] -> String -> IO () cp dry sources dest = chooseTactic =<< doesDirectoryExist dest where- chooseTactic isDir = - singleFile ? singleCopy isDir $- not isDir ? notDirErr $- mapM_ copySourcesToDir sources+ chooseTactic isDir+ | singleFile = singleCopy $ head sources+ | not isDir = notDirErr+ | otherwise = mapM_ copyToDir sources+ where+ singleCopy = if isDir then copyToDir else copyToFile singleFile = length sources == 1 - -- Errors notDirErr = do- hPutStrLn stderr $ "cp: target '" ++ dest ++ "' is not a directory"- exitFailure-- notFileErr str = do- hPutStrLn stderr $ "cp: '" ++ str ++ "': no such file"+ hPutStrLn stderr "cp: DEST is not a directory and SOURCES is of length >1." exitFailure - -- Tactics- singleCopy isDir = do- choose =<< doesFileExist filePath- where- choose isFile =- isFile && isDir ? copyToDir filePath $- isFile ? copyToFile filePath $- notFileErr filePath-- filePath = head sources-- copySourcesToDir filePath = do- isFile <- doesFileExist filePath- isFile ? copyToDir filePath- $ notFileErr filePath-- -- File copying copyToDir filePath = if dry then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest' ] else copyFile filePath dest' where dest' = withTrailingSep ++ takeFileName filePath- withTrailingSep = hasTrailingPathSeparator dest ? dest $ dest ++ sep+ withTrailingSep =+ if hasTrailingPathSeparator dest then dest else dest ++ sep copyToFile filePath = if dry then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest ] else copyFile filePath dest --- An example of using the 'rev' and 'Left' variants of 'pos'.-cpTerm = cp <$> dry <*> sources <*> dest+-- An example of using the 'rev' and 'Left' variants of 'pos', as well as+-- validating file paths.+cpTerm = cp <$> dry <*> filesExist sources <*> validPath dest where- dry = flag (optInfo [ "dry", "d" ])- { argName = "DRY"- , argDoc = "Perform a dry run. Print what would be copied, but do not "+ dry = value $ flag (optInfo [ "dry", "d" ])+ { optName = "DRY"+ , optDoc = "Perform a dry run. Print what would be copied, but do not " ++ "copy it." } sources = nonEmpty $ revPosLeft 0 [] posInfo- { argName = "SOURCES"- , argDoc = "Source file(s) to copy."+ { posName = "SOURCES"+ , posDoc = "Source file(s) to copy." } dest = required $ revPos 0 Nothing posInfo- { argName = "DEST"- , argDoc = "Destination of the copy. Must be a directory if there "+ { posName = "DEST"+ , posDoc = "Destination of the copy. Must be a directory if there " ++ "is more than one $(i,SOURCE)." } -termInfo = def+termInfo = defTI { termName = "cp" , version = "v1.0" , termDoc = "Copy files from SOURCES to DEST."
doc/examples/fail.hs view
@@ -13,23 +13,23 @@ cmdNames = [ "msg", "usage", "help", "success" ] failMsg, failUsage, success :: [String] -> Err String-failMsg strs = Left . MsgFail . fsep $ map text strs-failUsage strs = Left . UsageFail . fsep $ map text strs-success strs = Right . concat $ intersperse " " strs+failMsg strs = msgFail . fsep $ map text strs+failUsage strs = usageFail . fsep $ map text strs+success strs = return . concat $ intersperse " " strs help :: String -> Err String help name- | any (== name) cmdNames = Left . HelpFail Pager $ Just name- | name == "" = Left $ HelpFail Pager Nothing+ | any (== name) cmdNames = helpFail Pager $ Just name+ | name == "" = helpFail Pager Nothing | otherwise =- Left . UsageFail $ quotes (text name) <+> text "is not the name of a command"+ usageFail $ quotes (text name) <+> text "is not the name of a command" noCmd :: Err String-noCmd = Left $ HelpFail Pager Nothing+noCmd = helpFail Pager Nothing -def' = def- { stdOptSection = "COMMON OPTIONS"+def' = defTI+ { stdOptSec = "COMMON OPTIONS" , man = [ S "COMMON OPTIONS" , P "These options are common to all commands."@@ -42,8 +42,8 @@ input :: Term [String] input = nonEmpty $ posAny [] posInfo- { argName = "INPUT"- , argDoc = "Some input you would like printed to the screen on failure "+ { posName = "INPUT"+ , posDoc = "Some input you would like printed to the screen on failure " ++ "or success." } @@ -67,7 +67,7 @@ } ) - , ( ret $ help <$> (pos 0 "" posInfo { argName = "TERM" })+ , ( ret $ help <$> value (pos 0 "" posInfo { posName = "TERM" }) , def' { termName = "help" , termDoc = "Display help for a command." }
doc/examples/grep.hs view
@@ -13,9 +13,9 @@ -- An example of using the 'pos' and 'posRight' Terms. grepTerm = ( grep <$> pattern <*> files, termInfo ) where- pattern = required $ pos 0 Nothing posInfo { argName = "PATTERN" }- files = posRight 0 [] posInfo { argName = "FILE" }- termInfo = def+ pattern = required $ pos 0 Nothing posInfo { posName = "PATTERN" }+ files = value $ posRight 0 [] posInfo { posName = "FILE" }+ termInfo = defTI { termName = "grep" , version = "2.5" , termDoc = "Search for PATTERN in FILE(s) or standard in."
doc/examples/hello.hs view
@@ -1,26 +1,25 @@ import System.Console.CmdTheLine import Control.Applicative +import Control.Monad ( when )+ -- Define a flag argument under the names '--silent' and '-s' silent :: Term Bool-silent = flag $ optInfo [ "silent", "s" ]+silent = value . flag $ optInfo [ "silent", "s" ] -- Define the 0th positional argument, defaulting to the value '"world"' in -- absence. greeted :: Term String-greeted = pos 0 "world" posInfo { argName = "GREETED" }+greeted = value $ pos 0 "world" posInfo { posName = "GREETED" } hello :: Bool -> String -> IO ()-hello silent str =- if silent- then return ()- else putStrLn $ "Hello, " ++ str ++ "!"+hello silent str = when (not silent) . putStrLn $ "Hello, " ++ str ++ "!" term :: Term (IO ()) term = hello <$> silent <*> greeted termInfo :: TermInfo-termInfo = def { termName = "Hello", version = "1.0" }+termInfo = defTI { termName = "Hello", version = "1.0" } main :: IO () main = run ( term, termInfo )
src/System/Console/CmdTheLine.hs view
@@ -6,32 +6,36 @@ ( 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 System.Console.CmdTheLine.Err+import System.Console.CmdTheLine.Util +import Text.PrettyPrint ( Doc )+ import Control.Monad ( join )+import Control.Monad.Trans.Error ( throwError ) {-$term @@ -41,26 +45,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 +100,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 +123,7 @@ > > prepedNoCmdTerm :: Term String > prepedNoCmdTerm = ret noCmdTerm--} --- | 'ret' @term@ folds @term@'s 'Err' context into the library to be handled--- internally and as seamlessly as other error messages that are built in.-ret :: Term (Err a) -> Term a-ret (Term ais yield) = Term ais yield'- where- yield' ei cl = join $ yield ei cl+ For other examples of ways to use the 'Err' monad, see the source of the+ *Exists family of functions in "System.Console.CmdTheLine.Util".+-}
src/System/Console/CmdTheLine/Arg.hs view
@@ -3,9 +3,10 @@ - See the file 'LICENSE' for further information. -} module System.Console.CmdTheLine.Arg- (- -- * Creating ArgInfos- optInfo, posInfo+ ( Arg+ -- * Argument Information+ , OptInfo( optName, optDoc, optSec ), PosInfo( posName, posDoc, posSec )+ , optInfo, posInfo -- * Optional arguments -- $opt@@ -20,81 +21,127 @@ -- $pos , pos, revPos, posAny, posLeft, posRight, revPosLeft, revPosRight - -- * Constraining Terms- , required, nonEmpty, lastOf+ -- * Arguments as Terms+ , value, required, nonEmpty, lastOf ) where -import System.Console.CmdTheLine.Common+import System.Console.CmdTheLine.Common hiding ( Arg ) import System.Console.CmdTheLine.CmdLine ( optArg, posArg )-import System.Console.CmdTheLine.ArgVal ( ArgVal(..) )+import System.Console.CmdTheLine.ArgVal ( ArgVal, pp, parser ) import qualified System.Console.CmdTheLine.Err as E import qualified System.Console.CmdTheLine.Trie as T import Control.Applicative+import Control.Arrow ( second )++import Control.Monad.Trans.Error ( throwError )+ import Text.PrettyPrint import Data.List ( sort, sortBy ) import Data.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.+-- [@otpSec@] :: String: defautts 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 [] =+ 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 @@ -383,39 +424,40 @@ absent = map (\ ai -> ai { absence = Absent }) --- | 'required' @term@ converts @term@ so that it fails in the 'Nothing' and--- yields @a@ in the 'Just'.+-- | 'value' @arg@ makes @arg@ into a 'Term'.+value :: Arg a -> Term a+value (Arg term) = term++-- | 'required' @arg@ converts @arg@ into a 'Term' such that it fails in the+-- 'Nothing' and yields @a@ in the 'Just'. -- -- This is used for required positional arguments. There is nothing -- stopping you from using it with optional arguments, except that they -- would no longer be optional and it would be confusing from a user's -- perspective.-required :: Term (Maybe a) -> Term a-required (Term ais yield) = Term ais' yield'+required :: Arg (Maybe a) -> Term a+required (Arg (Term ais yield)) = Term ais' yield' where ais' = absent ais- yield' ei cl = case yield ei cl of- Left e -> Left e- Right mv -> maybe (argFail . E.argMissing $ head ais') Right mv+ yield' ei cl = aux =<< yield ei cl+ aux = maybe (argFail . E.argMissing $ head ais') return --- | 'nonEmpty' @term@ is a term that fails if its result is empty. Intended+-- | 'nonEmpty' @arg@ is a 'Term' that fails if its result is empty. Intended -- for non-empty lists of positional arguments.-nonEmpty :: Term [a] -> Term [a]-nonEmpty (Term ais yield) = Term ais' yield'+nonEmpty :: Arg [a] -> Term [a]+nonEmpty (Arg (Term ais yield)) = Term ais' yield' where ais' = absent ais- yield' ei cl = case yield ei cl of- Left e -> Left e- Right [] -> argFail . E.argMissing $ head ais'- Right xs -> Right xs+ yield' ei cl = aux =<< yield ei cl+ aux [] = argFail . E.argMissing $ head ais'+ aux xs = return xs --- | 'lastOf' @term@ is a term that fails if its result is empty and evaluates+-- | 'lastOf' @arg@ is a 'Term' that fails if its result is empty and evaluates -- to the last element of the resulting list otherwise. Intended for lists -- of flags or options where the last takes precedence.-lastOf :: Term [a] -> Term a-lastOf (Term ais yield) = Term ais yield'+lastOf :: Arg [a] -> Term a+lastOf (Arg (Term ais yield)) = Term ais yield' where- yield' ei cl = case yield ei cl of- Left e -> Left e- Right [] -> argFail . E.argMissing $ head ais- Right xs -> Right $ last xs+ yield' ei cl = aux =<< yield ei cl+ aux [] = argFail . E.argMissing $ head ais+ aux xs = return $ last xs
src/System/Console/CmdTheLine/ArgVal.hs view
@@ -6,23 +6,20 @@ 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 ) import qualified System.Console.CmdTheLine.Err as E import qualified System.Console.CmdTheLine.Trie as T @@ -30,18 +27,34 @@ import Data.Function ( on ) import Data.List ( sort, unfoldr ) 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 = string "." digits = many1 digit concatParsers = foldl (liftA2 (++)) $ return []@@ -59,234 +72,224 @@ 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 = E.invalidVal `on` text --- | The class of values that can be parsed from the command line. Instances--- must provide both 'parser' and 'pp'.-class ArgVal a where- parser :: ArgParser a -- ^ A parser of instance values.- pp :: ArgPrinter a -- ^ A pretty printer for instance values.- instance ArgVal Bool where- parser = fromParsec onErr- $ (True <$ string "true") <|> (False <$ string "false")- where- onErr str = E.invalidVal (text str) $ E.alts [ "true", "false" ]-- pp True = text "true"- pp False = text "false"+ converter = enum [( "true", True ), ( "false", False )] instance ArgVal (Maybe Bool) where- parser = just- pp = maybePP+ converter = just instance ArgVal [Char] where- parser = Right- pp = text+ converter = ( Right, text ) instance ArgVal (Maybe [Char]) where- parser = just- pp = maybePP+ converter = just instance ArgVal Int where- parser = fromParsec onErr pInteger+ converter = ( parser, int ) where- onErr str = invalidVal str "expected an integer"- pp = int+ parser = fromParsec onErr pInteger+ where+ onErr str = invalidVal str "expected an integer" instance ArgVal (Maybe Int) where- parser = just- pp = maybePP+ converter = just instance ArgVal Integer where- parser = fromParsec onErr pInteger+ converter = ( parser, integer ) where- onErr str = invalidVal str "expected an integer"- pp = integer+ parser = fromParsec onErr pInteger+ where+ onErr str = invalidVal str "expected an integer" instance ArgVal (Maybe Integer) where- parser = just- pp = maybePP+ converter = just instance ArgVal Float where- parser = fromParsec onErr pFloating+ converter = ( parser, float ) where- onErr str = invalidVal str "expected a floating point number"- pp = float+ parser = fromParsec onErr pFloating+ where+ onErr str = invalidVal str "expected a floating point number" instance ArgVal (Maybe Float) where- parser = just- pp = maybePP+ converter = just instance ArgVal Double where- parser = fromParsec onErr pFloating+ converter = ( parser, double ) where- onErr str = invalidVal str "expected a floating point number"- pp = double+ parser = fromParsec onErr pFloating+ where+ onErr str = invalidVal str "expected a floating point number" instance ArgVal (Maybe Double) where- parser = just- pp = maybePP+ converter = just instance ArgVal (Ratio Integer) where- parser = fromParsec onErr- $ read <$> concatParsers [ int <* spaces- , string "%"- , spaces >> int- ]+ converter = ( parser, rational ) where- int = concatParsers [ sign, digits ]- onErr str =- invalidVal str "expected a ratio in the form '<numerator> % <denominator>'"-- pp = rational+ parser = fromParsec onErr+ $ read <$> concatParsers [ int <* spaces+ , string "%"+ , spaces >> int+ ]+ where+ int = concatParsers [ sign, digits ]+ onErr str =+ invalidVal str "expected a ratio in the form '<numerator> % <denominator>'" instance ArgVal (Maybe (Ratio Integer)) where- parser = just- pp = maybePP+ converter = just
src/System/Console/CmdTheLine/CmdLine.hs view
@@ -11,6 +11,8 @@ import Control.Applicative import Control.Arrow ( second ) +import Control.Monad.Trans.Error ( throwError )+ import Text.PrettyPrint import Text.Parsec as P @@ -82,7 +84,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 +111,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,10 +125,10 @@ - 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
src/System/Console/CmdTheLine/Common.hs view
@@ -4,12 +4,13 @@ -} module System.Console.CmdTheLine.Common where -import Data.Default import Data.Function ( on )-import Text.PrettyPrint ( Doc )+import Text.PrettyPrint ( Doc, text ) import qualified Data.Map as M +import Control.Monad.Trans.Error+ data Absence = Absent | Present String deriving ( Eq )@@ -25,29 +26,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 +97,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 +107,36 @@ { -- | 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+ { termName = ""+ , version = ""+ , termDoc = ""+ , termSec = "COMMANDS"+ , stdOptSec = "OPTIONS"+ , man = []+ } type Command = ( TermInfo, [ArgInfo] ) @@ -163,35 +146,32 @@ , 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) ++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@@ -205,3 +185,9 @@ where rest' = if rest == [] then rest else tail rest -- Skip the 'sep'. ( left, rest ) = span (/= sep) xs++select :: a -> [( Bool, a )] -> a+select baseCase = foldr (uncurry (?)) baseCase+ where+ (?) True = const+ (?) False = flip const
src/System/Console/CmdTheLine/Err.hs view
@@ -10,13 +10,36 @@ 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 = text "argv array must have at least one element" errNotOpt = "Option argument without name" errNotPos = "Positional argument with a name"@@ -33,7 +56,7 @@ invalidVal = invalid "value" -no kind s = sep [ text "no", quotes $ s, kind ]+no kind s = sep [ text "no such", text kind, quotes $ text s ] notDir s = quotes (s) <+> text "is not a directory"
src/System/Console/CmdTheLine/Help.hs view
@@ -148,7 +148,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 +162,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)@@ -192,7 +192,7 @@ Choice -> [] 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 ++ ")"
src/System/Console/CmdTheLine/Manpage.hs view
src/System/Console/CmdTheLine/Term.hs view
@@ -24,6 +24,8 @@ import Control.Arrow ( second ) import Control.Monad ( join ) +import Control.Monad.Trans.Error+ import Data.List ( find, sort ) import Data.Maybe ( fromJust ) @@ -44,15 +46,18 @@ | Msg Doc | Version -type EvalErr = Either EvalFail+instance Error EvalFail 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 EvalFail IO +fromFail :: Fail -> EvalFail+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 ei fail = case fail of@@ -85,7 +90,7 @@ result = (.) instance Applicative Term where- pure v = Term [] (\ _ _ -> Right v)+ pure v = Term [] (\ _ _ -> return v) (Term args f) <*> (Term args' v) = Term (args ++ args') wrapped where@@ -97,19 +102,13 @@ -- instance ArgVal HelpFormat where- parser = enum [ ( "pager", Pager )- , ( "plain", Plain )- , ( "groff", Groff )- ]-- pp Pager = text "pager"- pp Plain = text "plain"- pp Groff = text "groff"+ converter = enum [ ( "pager", Pager )+ , ( "plain", Plain )+ , ( "groff", Groff )+ ] instance ArgVal (Maybe HelpFormat) where- parser = just-- pp = maybePP+ converter = just addStdOpts :: EvalInfo -> ( Yield (Maybe HelpFormat) , Maybe (Yield Bool)@@ -121,20 +120,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' ++)@@ -149,22 +150,25 @@ -- 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 = do+ eResult <- 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++ either handleErr return eResult where ( helpArg, versionArg, ei' ) = addStdOpts ei @@ -181,14 +185,14 @@ 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@@ -240,8 +244,8 @@ -- 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+ ( chosen, args' ) <- either handleErr return =<<+ (runErrorT . fromErr $ chooseTerm termInfo eiChoices args) let (Term ais yield) = fst . fromJust . find ((== chosen) . snd) $ mainTerm : choices
src/System/Console/CmdTheLine/Trie.hs view
+ src/System/Console/CmdTheLine/Util.hs view
@@ -0,0 +1,82 @@+{- 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 System.Console.CmdTheLine.Term++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."