diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,8 @@ -CmdTheLine v0.2 +CmdTheLine v0.2.1 =============== +[![Build Status](https://secure.travis-ci.org/eli-frey/cmdtheline.png)](http://travis-ci.org/eli-frey/cmdtheline) + Command line option parsing with applicative functors. Installation @@ -12,8 +14,7 @@ Depends ------- All dependencies are provided by the [Haskell -Platform](http://hackage.haskell.org/platform). See cmdtheline.cabal for library -dependencies. +Platform](http://hackage.haskell.org/platform). Docs ---- @@ -31,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 diff --git a/cmdtheline.cabal b/cmdtheline.cabal --- a/cmdtheline.cabal +++ b/cmdtheline.cabal @@ -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 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 + . + . Suggestions, comments, and bug reports are appreciated. Please see the bug and issue tracker at . . @@ -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 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 diff --git a/src/System/Console/CmdTheLine/Term.hs b/src/System/Console/CmdTheLine/Term.hs --- a/src/System/Console/CmdTheLine/Term.hs +++ b/src/System/Console/CmdTheLine/Term.hs @@ -2,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 diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -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