cmdtheline 0.2.0.0 → 0.2.1
raw patch · 4 files changed
+208/−38 lines, 4 filesdep +HUnitdep +test-frameworkdep +test-framework-hunitdep ~basedep ~containers
Dependencies added: HUnit, test-framework, test-framework-hunit
Dependency ranges changed: base, containers
Files
- README.md +6/−5
- cmdtheline.cabal +26/−4
- src/System/Console/CmdTheLine/Term.hs +63/−29
- test/Main.hs +113/−0
README.md view
@@ -1,6 +1,8 @@-CmdTheLine v0.2+CmdTheLine v0.2.1 =============== +[](http://travis-ci.org/eli-frey/cmdtheline)+ Command line option parsing with applicative functors. Installation@@ -12,8 +14,7 @@ Depends ------- All dependencies are provided by the [Haskell-Platform](http://hackage.haskell.org/platform). See cmdtheline.cabal for library-dependencies.+Platform](http://hackage.haskell.org/platform). Docs ----@@ -31,12 +32,12 @@ -------- ###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. LICENSE
cmdtheline.cabal view
@@ -1,9 +1,9 @@ Name: cmdtheline-Version: 0.2.0.0+Version: 0.2.1 Synopsis: Declarative command-line option parsing and documentation library. Description: CmdTheLine aims to remove tedium from the definition of command-line- programs, producing usage, help and man pages with little effort.+ programs, producing usage and help with little effort. . The inspiration was found in Daniel Bunzli's <http://erratique.ch/software/cmdliner> library.@@ -12,6 +12,9 @@ mechanism for defining command-line programs by lifting regular Haskell functions over argument parsers. .+ A tutorial can be found at+ <http://elifrey.com/2012/07/23/CmdTheLine-Tutorial/>.+ . Suggestions, comments, and bug reports are appreciated. Please see the bug and issue tracker at <http://github.com/eli-frey/cmdtheline>. .@@ -31,7 +34,13 @@ * 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. Homepage: http://github.com/eli-frey/cmdtheline License: MIT@@ -40,7 +49,7 @@ Maintainer: Eli Frey <eli.lee.frey gmail com> Stability: Experimental Category: Console-Cabal-version: >=1.6+Cabal-version: >=1.8 Build-type: Simple Extra-source-files: doc/examples/*.hs, README.md@@ -69,3 +78,16 @@ 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.7,+ test-framework-hunit >= 0.2 && < 0.3,+ containers >= 0.4 && < 0.6,+ parsec >= 3.1 && < 3.2, pretty >= 1.1 && < 1.2,+ process >= 1.1, directory >= 1.1,+ transformers >= 0.3 && < 0.4, filepath >= 1.3 && < 1.4+ ghc-options: -Wall -rtsopts+ hs-source-dirs: src, test+ main-is: Main.hs
src/System/Console/CmdTheLine/Term.hs view
@@ -2,14 +2,18 @@ - 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@@ -22,7 +26,7 @@ import Control.Applicative hiding ( (<|>), empty ) import Control.Arrow ( second )-import Control.Monad ( join )+import Control.Monad ( join, (<=<) ) import Control.Monad.Trans.Error @@ -30,7 +34,7 @@ import Data.Maybe ( fromJust ) import System.Environment ( getArgs )-import System.Exit ( exitFailure )+import System.Exit ( exitFailure, exitSuccess ) import System.IO import Text.PrettyPrint@@ -41,17 +45,21 @@ -- 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 -instance Error EvalFail where+instance Error EvalExit where strMsg = Msg . text -type EvalErr = ErrorT EvalFail IO+type EvalErr = ErrorT EvalExit IO -fromFail :: Fail -> EvalFail+fromFail :: Fail -> EvalExit fromFail (MsgFail d) = Msg d fromFail (UsageFail d) = Usage d fromFail (HelpFail fmt mName) = Help fmt mName@@ -59,16 +67,18 @@ fromErr :: Err a -> EvalErr a 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.@@ -149,9 +159,14 @@ -- 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 = do- eResult <- runErrorT $ do+evalTerm ei yield args = either handleErr return <=< runErrorT $ do ( cl, mResult ) <- fromErr $ do cl <- create (snd $ term ei') args mResult <- helpArg ei' cl@@ -168,7 +183,6 @@ else success _ -> success - either handleErr return eResult where ( helpArg, versionArg, ei' ) = addStdOpts ei @@ -179,8 +193,7 @@ 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]@@ -215,16 +228,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@@ -240,10 +259,16 @@ 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+-- | '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@( term, termInfo ) choices = do ( chosen, args' ) <- either handleErr return =<< (runErrorT . fromErr $ chooseTerm termInfo eiChoices args) @@ -252,15 +277,19 @@ 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@@ -270,3 +299,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
+ test/Main.hs view
@@ -0,0 +1,113 @@+{-# 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 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 = mute $ unwrap args ( FB.term, FB.termInfo )+unwrapAr args = mute $ unwrap args ( Ar.arithTerm, Ar.termInfo )+unwrapCP args = mute $ unwrap args ( CP.term, CP.termInfo )+unwrapCi args = mute $+ 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" ]+ ]+ ]++main :: IO ()+main = defaultMain tests