diff --git a/Console/Display.hs b/Console/Display.hs --- a/Console/Display.hs +++ b/Console/Display.hs @@ -1,3 +1,12 @@ +-- | +-- Module : Console.Display +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Console/Options.hs b/Console/Options.hs --- a/Console/Options.hs +++ b/Console/Options.hs @@ -1,3 +1,41 @@ +-- | +-- Module : Console.Options +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Console/Options/Flags.hs b/Console/Options/Flags.hs --- a/Console/Options/Flags.hs +++ b/Console/Options/Flags.hs @@ -1,3 +1,12 @@ +-- | +-- Module : Console.Options.Flags +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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]) diff --git a/Console/Options/Monad.hs b/Console/Options/Monad.hs --- a/Console/Options/Monad.hs +++ b/Console/Options/Monad.hs @@ -1,3 +1,10 @@ +-- | +-- Module : Console.Options.Monad +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/Console/Options/Nid.hs b/Console/Options/Nid.hs --- a/Console/Options/Nid.hs +++ b/Console/Options/Nid.hs @@ -1,3 +1,12 @@ +-- | +-- Module : Console.Options.Nid +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- Stability : experimental +-- Portability : Good +-- +-- Somewhat similar in functionality to Data.Unique. +-- create Nids for parameter identification purpose. module Console.Options.Nid ( Nid , NidGenerator diff --git a/Console/Options/Types.hs b/Console/Options/Types.hs --- a/Console/Options/Types.hs +++ b/Console/Options/Types.hs @@ -1,3 +1,10 @@ +-- | +-- Module : Console.Options.Types +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) {- diff --git a/Console/Options/Utils.hs b/Console/Options/Utils.hs --- a/Console/Options/Utils.hs +++ b/Console/Options/Utils.hs @@ -1,10 +1,20 @@ +-- | +-- Module : Console.Options.Utils +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) +``` diff --git a/cli.cabal b/cli.cabal --- a/cli.cabal +++ b/cli.cabal @@ -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