cmdtheline 0.2.2 → 0.2.3
raw patch · 10 files changed
+700/−2 lines, 10 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
Files
- cmdtheline.cabal +8/−1
- src/System/Console/CmdTheLine/Manpage.hs +1/−1
- test/Arith.hs +177/−0
- test/CP.hs +79/−0
- test/Cipher.hs +227/−0
- test/Fail.hs +83/−0
- test/FizzBuzz.hs +68/−0
- test/Grep.hs +28/−0
- test/Hello.hs +23/−0
- test/Main.hs +6/−0
cmdtheline.cabal view
@@ -1,5 +1,5 @@ Name: cmdtheline-Version: 0.2.2+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@@ -97,3 +97,10 @@ 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
src/System/Console/CmdTheLine/Manpage.hs view
@@ -56,7 +56,7 @@ where content = try escape <|> choice replacers <|> safeChars - escape = esc <$> (anyChar <* char ',') <*> try replace <|> safeChars+ escape = esc <$> (anyChar <* char ',') <*> (try replace <|> safeChars) safeChars = many1 $ satisfy (/= ')')
+ test/Arith.hs view
@@ -0,0 +1,177 @@+-- We need 'FlexibleInstances to instance 'ArgVal' for 'Maybe Exp' and+-- '( String, Exp )'.+{-# LANGUAGE FlexibleInstances #-}+module Arith where++import Prelude hiding ( exp )+import System.Console.CmdTheLine hiding ( eval )+import Control.Applicative hiding ( (<|>) )++import Control.Monad ( guard )+import Data.Char ( isAlpha )+import Data.Function ( on )++import Text.Parsec+import qualified Text.PrettyPrint as PP++import qualified Data.Map as M++import System.IO++type Parser a = Parsec String () a++data Bin = Pow | Mul | Div | Add | Sub++prec :: Bin -> Int+prec b = case b of+ { Pow -> 3 ; Mul -> 2 ; Div -> 2 ; Add -> 1 ; Sub -> 1 }++assoc :: Bin -> Assoc+assoc b = case b of+ Pow -> R+ _ -> L++toFunc :: Bin -> (Int -> Int -> Int)+toFunc b = case b of+ { Pow -> (^) ; Mul -> (*) ; Div -> div ; Add -> (+) ; Sub -> (-) }++data Exp = IntExp Int+ | VarExp String+ | BinExp Bin Exp Exp++instance ArgVal Exp where+ converter = ( parser, pretty 0 )+ where+ parser = fromParsec onErr exp+ onErr str = PP.text "invalid expression" PP.<+> PP.quotes (PP.text str)++instance ArgVal (Maybe Exp) where+ converter = just++instance ArgVal ( String, Exp ) where+ converter = pair '='++data Assoc = L | R++type Env = M.Map String Exp++catParsers :: [Parser String] -> Parser String+catParsers = foldl (liftA2 (++)) (return "")++integer :: Parser Int+integer = read <$> catParsers [ option "" $ string "-", many1 digit ]++tok :: Parser a -> Parser a+tok p = p <* spaces++parens :: Parser a -> Parser a+parens = between op cp+ where+ op = tok $ char '('+ cp = tok $ char ')'++-- Parse a terminal expression.+term :: Parser Exp+term = parens exp <|> int <|> var+ where+ int = tok $ IntExp <$> try integer -- Try so '-<not-digits>' won't fail.+ var = tok $ VarExp <$> many1 (satisfy isAlpha)++-- Parse a binary operator.+bin :: Parser Bin+bin = choice [ pow, mul, div, add, sub ]+ where+ pow = tok $ Pow <$ char '^'+ mul = tok $ Mul <$ char '*'+ div = tok $ Div <$ char '/'+ add = tok $ Add <$ char '+'+ sub = tok $ Sub <$ char '-'++exp :: Parser Exp+exp = e 0++-- Precedence climbing expressions. See+-- <www.engr.mun.ca/~theo/Misc/exp_parsing.htm> for further information.+e :: Int -> Parser Exp+e p = do+ t <- term+ try (go t) <|> return t+ where+ go e1 = do+ b <- bin+ guard $ prec b >= p++ let q = case assoc b of+ R -> prec b+ L -> prec b + 1+ e2 <- e q++ let expr = BinExp b e1 e2+ try (go expr) <|> return expr++-- Beta reduce by replacing variables in 'e' with values in 'env'.+beta :: Env -> Exp -> Maybe Exp+beta env e = case e of+ VarExp str -> M.lookup str env+ int@(IntExp _) -> return int+ BinExp b e1 e2 -> (liftA2 (BinExp b) `on` beta env) e1 e2++eval :: Exp -> Int+eval e = case e of+ VarExp str -> error $ "saw VarExp " ++ str ++ " while evaluating"+ IntExp i -> i+ BinExp b e1 e2 -> (toFunc b `on` eval) e1 e2++pretty :: Int -> Exp -> PP.Doc+pretty p e = case e of+ VarExp str -> PP.text str+ IntExp i -> PP.int i+ BinExp b e1 e2 -> let q = prec b+ in parensOrNot q $ PP.cat [ pretty q e1, ppBin b, pretty q e2 ]+ where+ parensOrNot q = if q < p then PP.parens else id++ppBin :: Bin -> PP.Doc+ppBin b = case b of+ Pow -> PP.char '^'+ Mul -> PP.char '*'+ Div -> PP.char '/'+ Add -> PP.char '+'+ Sub -> PP.char '-'++arith :: Bool -> [( String, Exp )] -> Exp -> IO ()+arith pp assoc = maybe badEnv method . beta (M.fromList assoc)+ where+ method = if pp then print . pretty 0 else print . eval+ badEnv = hPutStrLn stderr "arith: bad environment"++arithTerm :: Term (IO ())+arithTerm = arith <$> pp <*> env <*> e+ where+ pp = value $ flag (optInfo [ "pretty", "p" ])+ { optName = "PP"+ , optDoc = "If present, pretty print instead of evaluating EXP."+ }++ env = nonEmpty $ posRight 0 [] posInfo+ { posName = "ENV"+ , posDoc = "One or more assignments of the form '<name>=<exp>' to be "+ ++ "substituted in the input expression."+ }++ e = required $ pos 0 Nothing posInfo+ { posName = "EXP"+ , posDoc = "An arithmetic expression to be evaluated."+ }++termInfo :: TermInfo+termInfo = defTI+ { termName = "arith"+ , version = "0.3"+ , termDoc = "Evaluate mathematical functions demonstrating precedence "+ ++ "climbing and instantiating 'ArgVal' for tuples and Parsec "+ ++ "parsers."+ , man = [ S "BUGS"+ , P "Email bug reports to <fitsCarolDo@example.com>"+ ]+ }
+ test/CP.hs view
@@ -0,0 +1,79 @@+module CP where+import System.Console.CmdTheLine+import Control.Applicative++import System.Directory ( copyFile+ , doesDirectoryExist+ )+import System.FilePath ( takeFileName+ , pathSeparator+ , hasTrailingPathSeparator+ )++import System.IO+import System.Exit ( exitFailure )++sep :: String+sep = [pathSeparator]++cp :: Bool -> [String] -> String -> IO ()+cp dry sources dest =+ chooseTactic =<< doesDirectoryExist dest+ where+ chooseTactic isDir+ | singleFile = singleCopy $ head sources+ | not isDir = notDirErr+ | otherwise = mapM_ copyToDir sources+ where+ singleCopy = if isDir then copyToDir else copyToFile++ singleFile = length sources == 1++ notDirErr = do+ hPutStrLn stderr "cp: DEST is not a directory and SOURCES is of length >1."+ exitFailure++ copyToDir filePath = if dry+ then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest' ]+ else copyFile filePath dest'+ where+ dest' = withTrailingSep ++ takeFileName filePath+ withTrailingSep =+ if hasTrailingPathSeparator dest then dest else dest ++ sep++ copyToFile filePath = if dry+ then putStrLn $ concat [ "cp: copying ", filePath, " to ", dest ]+ else copyFile filePath dest+++-- An example of using the 'rev' and 'Left' variants of 'pos', as well as+-- validating file paths.+term :: Term (IO ())+term = cp <$> dry <*> filesExist sources <*> validPath dest+ where+ dry = value $ flag (optInfo [ "dry", "d" ])+ { optName = "DRY"+ , optDoc = "Perform a dry run. Print what would be copied, but do not "+ ++ "copy it."+ }++ sources = nonEmpty $ revPosLeft 0 [] posInfo+ { posName = "SOURCES"+ , posDoc = "Source file(s) to copy."+ }++ dest = required $ revPos 0 Nothing posInfo+ { posName = "DEST"+ , posDoc = "Destination of the copy. Must be a directory if there "+ ++ "is more than one $(i,SOURCE)."+ }++termInfo :: TermInfo+termInfo = defTI+ { termName = "cp"+ , version = "v1.0"+ , termDoc = "Copy files from SOURCES to DEST."+ , man = [ S "BUGS"+ , P "Email bug reports to <portManTwo@example.com>"+ ]+ }
+ test/Cipher.hs view
@@ -0,0 +1,227 @@+module Cipher where+import System.Console.CmdTheLine+import Control.Applicative++import Data.Char ( isUpper, isAlpha, isAlphaNum, isSpace+ , toLower+ )+import Data.List ( intersperse )++import System.IO+import System.Exit++infixr 2 <||>+-- Split a value between predicates and 'or' the results together+(<||>) :: (a -> Bool) -> (a -> Bool) -> (a -> Bool)+p <||> p' = (||) <$> p <*> p'+++--+-- Rot+--++data Cycle a = Cycle+ { backward :: (Cycle a)+ , at :: a+ , forward :: (Cycle a)+ }++fromList :: [a] -> Cycle a+fromList [] = error "Cycle must have at least one element"+fromList xs = first+ where+ ( first, last ) = go last xs first++ go :: Cycle a -> [a] -> Cycle a -> ( Cycle a, Cycle a )+ go prev [] next = ( next, prev )+ go prev (x : xs) next = ( this, last )+ where+ this = Cycle prev x rest+ (rest,last) = go this xs next++-- Return a Cycle centered on x.+seekTo :: Eq a => a -> Cycle a -> Cycle a+seekTo x xs+ | x == at xs = xs+ | otherwise = seekTo x $ forward xs+ +-- Seek n places forwards or backwards.+seek :: Bool -> Int -> Cycle a -> Cycle a+seek _ 0 xs = xs+seek back n xs = seek back (n - 1) (dir xs)+ where+ dir = if back then backward else forward++lowers, uppers :: Cycle Char+lowers = fromList ['a'..'z']+uppers = fromList ['A'..'Z']++rot :: Bool -> Int -> Maybe String -> IO ()+rot back n mStr = do+ input <- case mStr of+ Nothing -> getContents+ Just str -> return str++ putStrLn $ map rotChar input+ where+ rotChar c = if isAlpha c then c' else c+ where+ c' = at . seek back n $ seekTo c cycle+ cycle = if isUpper c then uppers else lowers+++--+-- Morse+--++switch :: ( a, b ) -> ( b, a )+switch ( x, y ) = ( y, x )++fromCode :: [( String, Char )]+fromCode = map switch toCode++toCode :: [( Char, String )]+toCode =+ [ ( 'a', ".-" ), ( 'b', "-..." ), ( 'c', "-.-." ), ( 'd', "-.." )+ , ( 'e', "." ), ( 'f', "..-." ), ( 'g', "--." ), ( 'h', "...." )+ , ( 'i', ".." ), ( 'j', ".---" ), ( 'k', "-.-" ), ( 'l', ".-.." )+ , ( 'm', "--" ), ( 'n', "-." ), ( 'o', "---" ), ( 'p', ".--." )+ , ( 'q', "--.-" ), ( 'r', ".-." ), ( 's', "..." ), ( 't', "-" )+ , ( 'u', "..-" ), ( 'v', "...-" ), ( 'w', ".--" ), ( 'x', "-..-" )+ , ( 'y', "-.--" ), ( 'z', "--.." ), ( '1', ".----" ), ( '2', "..---" )+ , ( '3', "...--" ), ( '4', "....-" ), ( '5', "....." ), ( '6', "-...." )+ , ( '7', "--..." ), ( '8', "---.." ), ( '9', "----." ), ( '0', "-----" )+ , ( ' ', "/" )+ ]++fromMorse, toMorse :: [String] -> Maybe String+fromMorse = mapM (`lookup` fromCode)+toMorse strs = sepCat " / " <$> mapM convertLetters strs+ where+ convertLetters chars = sepCat " " <$> mapM (`lookup` toCode) chars++ sepCat sep = concat . intersperse sep++morse :: Bool -> Maybe String -> IO ()+morse from mStr = do+ input <- case mStr of+ Nothing -> getContents+ Just str -> return str++ if all pred input+ then return ()+ else do hPutStrLn stderr err+ exitFailure++ convert input+ where+ pred = if from then (== '/') <||> (== '-') <||> (== '.') <||> isSpace+ else isAlphaNum <||> isSpace++ err = if from+ then "cipher: morse input must be all spaces, '/'s, '-'s, and '.'s."+ else "cipher: morse input must be alphanumeric and/or spaces"++ convert str = maybe badConvert putStrLn . convert' . words $ map toLower str+ where+ badConvert = hPutStrLn stderr err >> exitFailure+ where+ err = if from then "cipher: could not convert from morse"+ else "cipher: could not convert to morse"++ convert' = if from then fromMorse else toMorse+++--+-- Terms+--++-- The heading under which to place common options.+comOpts :: String+comOpts = "COMMON OPTIONS"++-- A modified default 'TermInfo' to be shared by commands.+defTI' :: TermInfo+defTI' = defTI+ { man =+ [ S comOpts+ , P "These options are common to all commands."+ , S "MORE HELP"+ , P "Use '$(mname) $(i,COMMAND) --help' for help on a single command."+ , S "BUGS"+ , P "Email bug reports to <snideHighland@example.com>"+ ]+ , stdOptSec = comOpts+ }++-- 'input' is a common option. We set its 'optSec' field to 'comOpts' so+-- that it is placed under that section instead of the default '"OPTIONS"'+-- section, which we will reserve for command-specific options.+input :: Term (Maybe String)+input = value $ opt Nothing (optInfo [ "input", "i" ])+ { optName = "INPUT"+ , optDoc = "For specifying input on the command line. If present, "+ ++ "input is not read form standard-in."+ , optSec = comOpts+ }++rotTerm :: ( Term (IO ()), TermInfo )+rotTerm = ( rot <$> back <*> n <*> input, termInfo )+ where+ back = value $ flag (optInfo [ "back", "b" ])+ { optName = "BACK"+ , optDoc = "Rotate backwards instead of forwards."+ }++ n = value $ opt 13 (optInfo [ "n" ])+ { optName = "N"+ , optDoc = "How many places to rotate by."+ }++ termInfo = defTI'+ { termName = "rot"+ , termDoc = "Rotate the input characters by N."+ , man = [ S "DESCRIPTION"+ , P $ "Rotate input gathered from INPUT or standard-in N "+ ++ "places. The input must be composed totally of "+ ++ "alphabetic characters and spaces."+ ] ++ man defTI'+ }++morseTerm :: ( Term (IO ()), TermInfo )+morseTerm = ( morse <$> from <*> input, termInfo )+ where+ from = value $ flag (optInfo [ "from", "f" ])+ { optName = "FROM"+ , optDoc = "Convert from morse-code to the Latin alphabet. "+ ++ "If absent, convert from Latin alphabet to morse-code."+ }++ termInfo = defTI'+ { termName = "morse"+ , termDoc = "Convert to and from morse-code."+ , man = [ S "DESCRIPTION"+ , P desc+ ] ++ man defTI'+ }++ desc = concat+ [ "Converts input gathered from INPUT or standard in to and from morse "+ , "code. 'dah' is represented by '-', 'dit' by '.'. Each morse character "+ , "is separated from the next by one or more ' '. Morse words are "+ , "separated by a '/'."+ ]+++defaultTerm :: ( Term a, TermInfo )+defaultTerm = ( ret $ const (helpFail Pager Nothing) <$> input+ , termInfo+ )+ where+ termInfo = defTI'+ { termName = "cipher"+ , version = "v1.0"+ , termDoc = doc+ }++ doc = "An implementation of the morse-code and rotational(Caesar) ciphers."
+ test/Fail.hs view
@@ -0,0 +1,83 @@+module Fail where+import System.Console.CmdTheLine+import Control.Applicative++import Text.PrettyPrint ( fsep -- Paragraph fill a list of 'Doc'.+ , text -- Make a 'String' into a 'Doc'.+ , quotes -- Quote a 'Doc'.+ , (<+>) -- Glue two 'Doc' together with a space.+ )++import Data.List ( intersperse )+++cmdNames = [ "msg", "usage", "help", "success" ]++failMsg, failUsage, success :: [String] -> Err String+failMsg strs = msgFail . fsep $ map text strs+failUsage strs = usageFail . fsep $ map text strs+success strs = return . concat $ intersperse " " strs++help :: String -> Err String+help name+ | any (== name) cmdNames = helpFail Pager $ Just name+ | name == "" = helpFail Pager Nothing+ | otherwise =+ usageFail $ quotes (text name) <+> text "is not the name of a command"++noCmd :: Err String+noCmd = helpFail Pager Nothing+++def' = defTI+ { stdOptSec = "COMMON OPTIONS"+ , man =+ [ S "COMMON OPTIONS"+ , P "These options are common to all commands."+ , S "MORE HELP"+ , P "Use '$(mname) $(i,COMMAND) --help' for help on a single command."+ , S "BUGS"+ , P "Email bug reports to <dogWalter@example.com>"+ ]+ }++input :: Term [String]+input = nonEmpty $ posAny [] posInfo+ { posName = "INPUT"+ , posDoc = "Some input you would like printed to the screen on failure "+ ++ "or success."+ }++cmds :: [( Term String, TermInfo )]+cmds =+ [ ( ret $ failMsg <$> input+ , def' { termName = "msg"+ , termDoc = "Print a failure message."+ }+ )++ , ( ret $ failUsage <$> input+ , def' { termName = "usage"+ , termDoc = "Print a usage message."+ }+ )++ , ( ret $ success <$> input+ , def' { termName = "success"+ , termDoc = "Print a message to the screen"+ }+ )++ , ( ret $ help <$> value (pos 0 "" posInfo { posName = "TERM" })+ , def' { termName = "help"+ , termDoc = "Display help for a command."+ }+ )+ ]++noCmdTerm = ( ret $ pure noCmd+ , def' { termName = "fail"+ , termDoc = "A program demoing CmdTheLine's user "+ ++ "error functionality."+ }+ )
+ test/FizzBuzz.hs view
@@ -0,0 +1,68 @@+module FizzBuzz where+import System.Console.CmdTheLine+import Control.Applicative++import System.Exit ( exitSuccess )++data Verbosity = Verbose | Normal | Silent++fizzBuzz :: Verbosity -> String -> String -> Int -> IO ()+fizzBuzz verb fizz buzz n = do+ case verb of+ Verbose -> putStrLn $ concat+ [ "FizzBuzz: Printing the result of FizzBuzz over the numbers 1 to ", show n+ , "\nFizz = ", fizz, "\nBuzz = ", buzz+ ]+ Silent -> exitSuccess+ _ -> return ()++ mapM_ fizzAndBuzzOr [1..n]+ where+ fizzAndBuzzOr n = putStrLn output+ where+ output = case fizz' ++ buzz' of+ "" -> show n+ str -> str++ fizz' = if (n `mod` 3) == 0 then fizz else ""+ buzz' = if (n `mod` 5) == 0 then buzz else ""+++-- A flag that can appear many times on the command line, only the last of+-- which will be counted.+verbosity :: Term Verbosity+verbosity = lastOf $ vFlagAll [Normal] [ ( Verbose, verbose )+ , ( Silent, silent )+ ]+ where+ verbose =(optInfo [ "verbose", "v" ])+ { optDoc = "Give verbose output." }++ silent =(optInfo [ "quiet", "silent", "q", "s" ])+ { optDoc = "Provide no output." }++fizz, buzz :: Term String+fizz = value $ opt "Fizz" (optInfo [ "Fizz", "fizz", "f" ])+ { optDoc = "A string to print in the 'Fizz' case." }++buzz = value $ opt "Buzz" (optInfo [ "Buzz", "buzz", "b" ])+ { optDoc = "A string to print in the 'Buzz' case." }++times :: Term Int+times = value $ opt 100 (optInfo [ "times", "t" ])+ { optName = "TIMES"+ , optDoc = "Run $(mname) for the numbers 1 to $(argName)."+ }++term :: Term (IO ())+term = fizzBuzz <$> verbosity <*> fizz <*> buzz <*> times++termInfo :: TermInfo+termInfo = defTI+ { termName = "FizzBuzz"+ , version = "v1.0"+ , termDoc = "An implementation of the world renowned FizzBuzz algorithm."+ , man = [ S "BUGS"+ , P "Email bug reports to <sirFrancisDrank@example.com>"+ ]+ }
+ test/Grep.hs view
@@ -0,0 +1,28 @@+module Grep where+import System.Console.CmdTheLine+import Control.Applicative++import Data.List ( intersperse )++import System.Cmd ( system )+import System.Exit ( exitWith )++grep :: String -> [String] -> IO ()+grep pattern dests = do+ exitWith =<< system (concat . intersperse " " $ [ "grep", pattern ] ++ dests)++-- An example of using the 'pos' and 'posRight' Terms.+term = grep <$> pattern <*> files+ where+ pattern = required $ pos 0 Nothing posInfo { posName = "PATTERN" }+ files = value $ posRight 0 [] posInfo { posName = "FILE" }++termInfo = defTI+ { termName = "grep"+ , version = "2.5"+ , termDoc = "Search for PATTERN in FILE(s) or standard in."+ , man =+ [ S "BUGS"+ , P "Please send bug reports to <throatWobblerMangrove@example.com>"+ ]+ }
+ test/Hello.hs view
@@ -0,0 +1,23 @@+module Hello where+import System.Console.CmdTheLine+import Control.Applicative++import Control.Monad ( when )++-- Define a flag argument under the names '--silent' and '-s'+silent :: Term Bool+silent = value . flag $ optInfo [ "silent", "s" ]++-- Define the 0th positional argument, defaulting to the value '"world"' in+-- absence.+greeted :: Term String+greeted = value $ pos 0 "world" posInfo { posName = "GREETED" }++hello :: Bool -> String -> IO ()+hello silent str = when (not silent) . putStrLn $ "Hello, " ++ str ++ "!"++term :: Term (IO ())+term = hello <$> silent <*> greeted++termInfo :: TermInfo+termInfo = defTI { termName = "Hello", version = "1.0" }
test/Main.hs view
@@ -16,6 +16,7 @@ import System.FilePath ( (</>) ) import System.Console.CmdTheLine ( unwrap, unwrapChoice, EvalExit )+import System.Console.CmdTheLine.Manpage ( substitute, plainEsc ) import Control.Applicative ( (<$>) ) @@ -104,6 +105,11 @@ 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" ] ]