cli 0.1.1 → 0.1.2

raw patch · 9 files changed

+239/−46 lines, 9 filesPVP: major bump suggested

API removals or changes: PVP suggests a major version bump

API changes (from Hackage documentation)

Files

• Console/Display.hs +44/−13
• Console/Options.hs +69/−11
• Console/Options/Flags.hs +25/−4
• Console/Options/Monad.hs +16/−7
• Console/Options/Nid.hs +9/−0
• Console/Options/Types.hs +22/−6
• Console/Options/Utils.hs +11/−1
• README.md +41/−2
• cli.cabal +2/−2

@@ -1,3 +1,12 @@+-- |+-- Module      : Console.Display+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+-- Displaying utilities+-- module Console.Display     ( TerminalDisplay     -- * Basic@@ -35,13 +44,7 @@ import           System.IO import           Data.List -{--data LineWidget =-      Text-    | Progress-    | Done--}-+-- | Element to output text and attributes to the display data OutputElem =       Bg Color     | Fg Color@@ -51,14 +54,17 @@     | NA     deriving (Show,Eq) +-- | Terminal display state data TerminalDisplay = TerminalDisplay (MVar Bool) Terminal +-- | Create a new display displayInit :: IO TerminalDisplay displayInit = do     hSetBuffering stdout NoBuffering     cf <- newMVar False     TerminalDisplay cf <$> setupTermFromEnv +-- | Display display :: TerminalDisplay -> [OutputElem] -> IO () display tdisp@(TerminalDisplay clearFirst term) oelems = do     cf <- modifyMVar clearFirst $ \cf -> return (False, cf)@@ -81,17 +87,21 @@         toTermOutput (RightT sz t)  = termText (replicate (sz - length t) ' ' ++ t)         toTermOutput NA     = rD +-- | A simple utility that display a @msg@ in @color@ displayTextColor :: TerminalDisplay -> Color -> String -> IO () displayTextColor term color msg = do     display term [Fg color, T msg] +-- | A simple utility that display a @msg@ in @color@ and newline at the end. displayLn :: TerminalDisplay -> Color -> String -> IO () displayLn disp color msg = displayTextColor disp color (msg ++ "\n") +-- | Progress bar widget data ProgressBar = ProgressBar TerminalDisplay ProgressBackend (MVar ProgressState)  type ProgressBackend = String -> IO () +-- | Summary data Summary = Summary SummaryBackend type SummaryBackend = [OutputElem] -> IO () @@ -110,6 +120,7 @@     , pgCurrent = 0     } +-- | Create a new progress bar context progress :: TerminalDisplay          -> Int          -> (ProgressBar -> IO a)@@ -167,17 +178,20 @@         currentProgress :: Double         currentProgress = fromIntegral maxItems / fromIntegral current +-- | Start displaying the progress bar progressStart :: ProgressBar -> IO () progressStart pbar = do     showBar pbar     return () +-- | Tick an element on the progress bar progressTick :: ProgressBar -> IO () progressTick pbar@(ProgressBar _ _ st) = do     modifyMVar_ st $ \pgs -> return $ pgs { pgCurrent = min (pgMax pgs) (pgCurrent pgs + 1) }     showBar pbar     return () +-- | Create a summary summary :: TerminalDisplay -> IO Summary summary tdisp@(TerminalDisplay cf term) = do     let b = backend (getCapability term cursorDown)@@ -195,12 +209,15 @@     backend _ _ _ = \msg ->         runTermOutput term $ mconcat [renderOutput tdisp msg] +-- | Set the summary summarySet :: Summary -> [OutputElem] -> IO () summarySet (Summary backend) output = do     backend output +-- | Justify position data Justify = JustifyLeft | JustifyRight +-- | box a string to a specific size, choosing the justification justify :: Justify -> Int -> String -> String justify dir sz s     | sz <= szS = s@@ -262,29 +279,43 @@      in mconcat [j,fwc,bgc, [T $ attrText attr,NA]] -} --- column+-- | Column for a table data Column = Column-    { columnSize    :: Int-    , columnName    :: String-    , columnJustify :: Justify-    , columnWrap    :: Bool+    { columnSize    :: Int     -- ^ Size of the column+    , columnName    :: String  -- ^ Name of the column. used in 'tableHeaders'+    , columnJustify :: Justify -- ^ The justification to use for the cell of this column+    , columnWrap    :: Bool    -- ^ if needed to wrap, whether text disappear or use multi lines row (unimplemented)     } +-- | Create a new column setting the right default parameters columnNew :: Int -> String -> Column-columnNew n name = Column n name JustifyLeft False+columnNew n name = Column+    { columnSize    = n+    , columnName    = name+    , columnJustify = JustifyLeft+    , columnWrap    = False+    } +-- | Table widget data Table = Table     { tColumns     :: [Column]     , rowSeparator :: String     } +-- | Create a new table tableCreate :: [Column] -> Table tableCreate cols = Table { tColumns = cols, rowSeparator = "" } +-- | Show the table headers tableHeaders :: TerminalDisplay -> Table -> IO () tableHeaders td t =     tableAppend td t $ map columnName $ tColumns t +-- | Append a row to the table.+--+-- if the number of elements is greater than the amount of+-- column the table has been configured with, the extra+-- elements are dropped. tableAppend :: TerminalDisplay -> Table -> [String] -> IO () tableAppend td (Table cols rowSep) l = do     let disp = case compare (length l) (length cols) of

@@ -1,3 +1,41 @@+-- |+-- Module      : Console.Options+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+-- Options parsing using a simple DSL approach.+--+-- Using this API, your program should have the following shape:+--+-- >defaultMain $ do+-- >    f1 <- flag ..+-- >    f2 <- argument ..+-- >    action $ \toParam ->+-- >        something (toParam f1) (toParam f2) ..+--+-- You can also define subcommand using:+--+-- >defaultMain $ do+-- >    subcommand "foo" $ do+-- >       <..flags & parameters definitions...>+-- >       action $ \toParam -> <..IO-action..>+-- >    subcommand "bar" $ do+-- >       <..flags & parameters definitions...>+-- >       action $ \toParam -> <..IO-action..>+--+-- Example:+--+-- >main = defaultMain $ do+-- >    programName "test-cli"+-- >    programDescription "test CLI program"+-- >    flagA    <- flag $ FlagShort 'a' <> FlagLong "aaa"+-- >    allArgs  <- remainingArguments "FILE"+-- >    action $ \toParam -> do+-- >        putStrLn $ "using flag A : " ++ show (toParam flagA)+-- >        putStrLn $ "args: " ++ show (toParam allArgs)+-- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-}@@ -21,7 +59,7 @@     , flag     , flagParam     , flagMany-    , conflict+    -- , conflict     , argument     , remainingArguments     , action@@ -35,7 +73,8 @@     , FlagMany     , Arg     , ArgRemaining-    , Params(..)+    , Params+    , paramsFlags     , getParams     ) where @@ -86,21 +125,30 @@         CommandTree {} -> hier -- ignore argument in a hierarchy. ---------------------------------------------------------------------- +-- | A parser for a flag's value, either optional or required. data FlagParser a =-      FlagRequired (ValueParser a)-    | FlagOptional a (ValueParser a)+      FlagRequired (ValueParser a)   -- ^ flag value parser with a required parameter.+    | FlagOptional a (ValueParser a) -- ^ Optional flag value parser: Default value if not present to a +-- | A parser for a value. In case parsing failed Left should be returned. type ValueParser a = String -> Either String a +-- | return value of the option parser. only needed when using 'parseOptions' directly data OptionRes r =       OptionSuccess Params (Action r)     | OptionHelp     | OptionError String -- user cmdline error in the arguments     | OptionInvalid String -- API has been misused +-- | run parse options description on the action+--+-- to be able to specify the arguments manually (e.g. pre-handling),+-- you can use 'defaultMainWith'.+-- >defaultMain dsl = getArgs >>= defaultMainWith dsl defaultMain :: OptionDesc (IO ()) () -> IO () defaultMain dsl = getArgs >>= defaultMainWith dsl +-- | same as 'defaultMain', but with the argument defaultMainWith :: OptionDesc (IO ()) () -> [String] -> IO () defaultMainWith dsl args = do     let (programDesc, res) = parseOptions dsl args@@ -110,10 +158,14 @@         OptionSuccess params r -> r (getParams params)         OptionInvalid s        -> putStrLn s >> exitFailure +-- | This is only useful when you want to handle all the description parsing+-- manually and need to not automatically execute any action or help/error handling.+--+-- Used for testing the parser. parseOptions :: OptionDesc r () -> [String] -> (ProgramDesc r, OptionRes r) parseOptions dsl args =     let descState = gatherDesc dsl-     in (descState, runOptions (stMeta descState) (stCT descState) args)+     in (descState, runOptions (stCT descState) args)  --helpSubcommand :: [String] -> IO () @@ -154,11 +206,10 @@       where         ff = flagFragments fd -runOptions :: ProgramMeta-           -> Command r -- commands+runOptions :: Command r -- commands            -> [String] -- arguments            -> OptionRes r-runOptions pmeta ct allArgs+runOptions ct allArgs     | "--help" `elem` allArgs = OptionHelp     | "-h" `elem` allArgs     = OptionHelp     | otherwise               = go [] ct allArgs@@ -300,6 +351,9 @@      isValid f = either FlagArgInvalid (const FlagArgValid) . f +-- | Apply on a 'flagParam' to turn into a flag that can+-- be invoked multiples, creating a list of values+-- in the action. flagMany :: OptionDesc r (FlagParam a) -> OptionDesc r (FlagMany a) flagMany fp = do     f <- fp@@ -329,7 +383,7 @@     modify $ \st -> st { stCT = addOption opt (stCT st) }     return (Flag nid) --- | An unnamed argument+-- | An unnamed positional argument -- -- For now, argument in a point of tree that contains sub trees will be ignored. -- TODO: record a warning or add a strict mode (for developping the CLI) and error.@@ -343,6 +397,10 @@     modifyCT $ addArg a     return (Arg idx (either (error "internal error") id . fp)) +-- | All the remaining position arguments+--+-- This is useful for example for a program that takes an unbounded list of files+-- as parameters. remainingArguments :: String -> OptionDesc r (ArgRemaining [String]) remainingArguments name = do     let a = ArgumentCatchAll { argumentName        = name@@ -353,5 +411,5 @@  -- | give the ability to set options that are conflicting with each other -- if option a is given with option b then an conflicting error happens-conflict :: Flag a -> Flag b -> OptionDesc r ()-conflict = undefined+-- conflict :: Flag a -> Flag b -> OptionDesc r ()+-- conflict = undefined

@@ -1,3 +1,12 @@+-- |+-- Module      : Console.Options.Flags+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+-- Simple flag parsers+-- module Console.Options.Flags     ( parseFlags     , FlagDesc(..)@@ -17,7 +26,9 @@ import Data.List import Data.Monoid -data FlagArgValidation = FlagArgValid | FlagArgInvalid String+-- | Result of validation of flag value.+data FlagArgValidation = FlagArgValid          -- ^ Validation success+                       | FlagArgInvalid String -- ^ Validation failed with reason  -- | How to parse a specific flag data FlagDesc = FlagDesc@@ -28,14 +39,20 @@     , flagArity         :: Int     } +-- | Fragment of flag definition.+--+-- Use the monoid approach to concat flags together+-- e.g.+-- > FlagShort 'o' <> FlagLong "option" data FlagFrag =-      FlagShort       Char-    | FlagLong        String-    | FlagDescription String+      FlagShort       Char   -- ^ short option e.g. '-a'+    | FlagLong        String -- ^ long option e.g. "--aaaa"+    | FlagDescription String -- ^ description of this flag.     -- | FlagDefault     String     | FlagMany        [FlagFrag]     deriving (Show,Eq) +-- | Flatten fragments list into a final product to consume data FlagFragments = FlagFragments     { flagShort         :: Maybe Char             -- ^ short flag parser 'o'     , flagLong          :: Maybe String           -- ^ long flag "flag"@@ -43,6 +60,7 @@     --, flagDefault       :: Maybe String           -- ^ Has a default     } +-- | Produce the result structure after processing all the fragment list. flattenFragments :: FlagFrag -> FlagFragments flattenFragments frags =     foldl' flat startVal $ case frags of@@ -76,10 +94,13 @@                                [String]    -- Unparsed: in reverse order                                [FlagError] -- errors: in reverse order +-- | Flag return value after parsing made of a unique number and an optional value type Flag = (Nid, Maybe String) +-- | Flag error with the description of the flag, the index of the element causing the error, and the error itself. data FlagError = FlagError FlagDesc Int String +-- | Parse flags parseFlags :: [FlagDesc]            -> [String]            -> ([Flag], [String], [FlagError])

@@ -1,3 +1,10 @@+-- |+-- Module      : Console.Options.Monad+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+-- {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE Rank2Types #-} module Console.Options.Monad@@ -17,8 +24,7 @@ import           Control.Monad.Identity import           System.Exit --- the current state of the program description--- as the monad unfold ..+-- | Ongoing State of the program description, as filled by monadic action data ProgramDesc r = ProgramDesc     { stMeta        :: ProgramMeta     , stCT          :: Command r     -- the command with the return type of actions@@ -26,20 +32,22 @@     , stNextIndex   :: !UnnamedIndex -- next index for unnamed argument     } +-- | Program meta information data ProgramMeta = ProgramMeta-    { programMetaName        :: Maybe String-    , programMetaDescription :: Maybe String-    , programMetaVersion     :: Maybe String-    , programMetaHelp        :: [String]+    { programMetaName        :: Maybe String -- ^ Program name (usually name of the executable)+    , programMetaDescription :: Maybe String -- ^ Program long description+    , programMetaVersion     :: Maybe String -- ^ Program version+    , programMetaHelp        :: [String]     -- ^ Flag that triggers Help.     }  programMetaDefault :: ProgramMeta programMetaDefault = ProgramMeta Nothing Nothing Nothing ["-h", "--help"] --- OptionDesc (return value of action) a+-- | Option description Monad newtype OptionDesc r a = OptionDesc { runOptionDesc :: StateT (ProgramDesc r) Identity a }     deriving (Functor,Applicative,Monad,MonadState (ProgramDesc r)) +-- | Run option description gatherDesc :: OptionDesc r a -> ProgramDesc r gatherDesc dsl = runIdentity $ execStateT (runOptionDesc dsl) initialProgramDesc @@ -60,6 +68,7 @@     modify $ \st -> st { stNextID = nidGen }     return nid +-- | Return the next unique position argument ID getNextIndex :: OptionDesc r UnnamedIndex getNextIndex = do     idx <- stNextIndex <$> get

@@ -1,3 +1,12 @@+-- |+-- Module      : Console.Options.Nid+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+-- Somewhat similar in functionality to Data.Unique.+-- create Nids for parameter identification purpose. module Console.Options.Nid     ( Nid     , NidGenerator

@@ -1,3 +1,10 @@+-- |+-- Module      : Console.Options.Types+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+-- {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE Rank2Types #-} {-# LANGUAGE GADTs #-}@@ -17,8 +24,7 @@     , Arg(..)     , ArgRemaining(..)     , Params(..)-    , Param-    , getParams+    , Param(..)     ) where  import           Console.Options.Flags (FlagDesc)@@ -36,28 +42,34 @@         , argumentDescription :: String         } +-- | Represent a boolean flag (present / not present) data Flag a where     Flag       :: Nid -> Flag Bool +-- | Represent a Flag that can be called multiples times and will increase a counter. data FlagLevel a where     FlagLevel  :: Nid -> FlagLevel Int +-- | Represent a Flag with an optional or required value associated data FlagParam a where     FlagParamOpt     :: Nid -> a -> (String -> a) -> FlagParam a     FlagParam        :: Nid -> (String -> a) -> FlagParam a +-- | Represent a Flag with optional or required value that can be added multiple times newtype FlagMany a = FlagMany (FlagParam a) +-- | A positional argument data Arg a where     Arg           :: UnnamedIndex -> (String -> a) -> Arg a +-- | All the remaining positional arguments data ArgRemaining a where     ArgsRemaining :: ArgRemaining [String] +-- | Positional argument index type UnnamedIndex = Int --- A command that is composed of a hierarchy---+-- | A command that is composed of a hierarchy data Command r = Command     { getCommandHier        :: CommandHier r     , getCommandDescription :: String@@ -70,9 +82,9 @@       CommandTree [(String, Command r)]     | CommandLeaf [Argument] -+-- | A dictionary of parsed flags and arguments data Params = Params-    { paramsFlags         :: [(Nid, Maybe String)]+    { paramsFlags         :: [(Nid, Maybe String)] -- ^ return all the flags and their unique identifier. internal only     , paramsPinnedArgs    :: [String]     , paramsRemainingArgs :: [String]     }@@ -80,12 +92,16 @@ -- | Represent a program to run type Action r = (forall a p . Param p => p a -> Ret p a) -> r +-- | Wrapper for Action or no Action. data ActionWrapper r =        ActionWrapped (Action r)     | NoActionWrapped +-- | Transform a binded argument or flag into a haskell value class Param p where+    -- | Return value data type associated with a specific Param shape.     type Ret p a :: *+    -- | get the value associated with a specific Param (either a Flag, FlagParam, or an Arg)     getParams :: Params -> (forall a . p a -> Ret p a)  {-

@@ -1,10 +1,20 @@+-- |+-- Module      : Console.Options.Utils+-- License     : BSD-style+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>+-- Stability   : experimental+-- Portability : Good+--+-- utiliity. don't expose to users. module Console.Options.Utils     ( hPutErrLn     ) where  import           System.IO (hPutStrLn, stderr) --- add implementation for windows+-- | print to stderr and newline.+--+-- TODO add implementation for windows hPutErrLn :: String -> IO () hPutErrLn = hPutStrLn stderr 

@@ -1,9 +1,48 @@ cli-=======+===  [![Build Status](https://travis-ci.org/vincenthz/hs-cli.png?branch=master)](https://travis-ci.org/vincenthz/hs-cli) [![BSD](http://b.repl.ca/v1/license-BSD-blue.png)](http://en.wikipedia.org/wiki/BSD_licenses) [![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) - Documentation: [cli on hackage](http://hackage.haskell.org/package/cli)++Option parser in DSL form, and display utilities for command line interfaces.++Option Parsing+--------------++Basic program looks like:++```haskell+defaultMain $ do+    f1 <- flag ..+    f2 <- argument ..+    action $ \toParam ->+        something (toParam f1) (toParam f2) ..+```++with subcommands:++```haskell+defaultMain $ do+    subcommand "foo" $ do+       <..flags & parameters definitions...>+       action $ \toParam -> <..IO-action..>+    subcommand "bar" $ do+       <..flags & parameters definitions...>+       action $ \toParam -> <..IO-action..>+```++A Real Example:++```haskell+main = defaultMain $ do+    programName "test-cli"+    programDescription "test CLI program"+    flagA    <- flag $ FlagShort 'a' <> FlagLong "aaa"+    allArgs  <- remainingArguments "FILE"+    action $ \toParam -> do+        putStrLn $ "using flag A : " ++ show (toParam flagA)+        putStrLn $ "args: " ++ show (toParam allArgs)+```

@@ -1,5 +1,5 @@ Name:                cli-Version:             0.1.1+Version:             0.1.2 Synopsis:            Command Line Interface Description:      All you need for interacting with users at the Console level@@ -37,7 +37,7 @@                    , transformers                    , mtl                    , terminfo-  ghc-options:       -Wall -fwarn-tabs+  ghc-options:       -Wall -fwarn-tabs -fno-warn-unused-imports   default-language:  Haskell2010