cli 0.1.2 → 0.2.0

raw patch · 9 files changed

+361/−221 lines, 9 filesdep +basementdep +foundationdep −QuickCheckdep −directorydep −mtldep ~basenew-component:exe:examplePVP ok

version bump matches the API change (PVP)

Dependencies added: basement, foundation

Dependencies removed: QuickCheck, directory, mtl, tasty, tasty-quickcheck, terminfo, transformers

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Console/Display.hs +222/−86
• Console/Options.hs +23/−14
• Console/Options/Flags.hs +7/−0
• Console/Options/Monad.hs +14/−6
• Console/Options/Types.hs +2/−1
• README.md +5/−0
• cli.cabal +53/−59
• examples/Simple.hs +35/−0
• tests/Cli.hs +0/−55

@@ -7,6 +7,9 @@ -- -- Displaying utilities --++{-# LANGUAGE NoImplicitPrelude #-}+ module Console.Display     ( TerminalDisplay     -- * Basic@@ -23,7 +26,7 @@     , summary     , summarySet     -- * Attributes-    , Color(..)+    , ColorComponent     , OutputElem(..)     , termText     , justify@@ -37,66 +40,90 @@     , tableAppend     ) where +import Basement.Terminal+import Basement.Terminal.ANSI+import Basement.Types.OffsetSize++import Foundation+import Foundation.Numerical+import Foundation.IO+import Foundation.IO.Terminal+import Foundation.String+import Foundation.Collection++import           System.IO (Handle, hSetBuffering, BufferMode(NoBuffering))+ import           Control.Applicative-import           Control.Monad+import           Control.Monad (when) import           Control.Concurrent.MVar-import           System.Console.Terminfo-import           System.IO-import           Data.List  -- | Element to output text and attributes to the display data OutputElem =-      Bg Color-    | Fg Color+      Bg ColorComponent+    | Fg ColorComponent     | T  String-    | LeftT Int String-    | RightT Int String+    | LeftT (CountOf Char) String      -- ^ Left-aligned text+    | RightT (CountOf Char) String     -- ^ Right-aligned text+    | CenterT (CountOf Char) String    -- ^ Centered text+    | JustifiedT (CountOf Char) String -- ^ Justified text     | NA     deriving (Show,Eq)  -- | Terminal display state-data TerminalDisplay = TerminalDisplay (MVar Bool) Terminal+data TerminalDisplay = TerminalDisplay (MVar Bool) Handle +hPutStr :: Handle -> String -> IO ()+hPutStr h = hPut h . toBytes UTF8++termText :: String -> String+termText = id+ -- | Create a new display displayInit :: IO TerminalDisplay displayInit = do+    initialize     hSetBuffering stdout NoBuffering     cf <- newMVar False-    TerminalDisplay cf <$> setupTermFromEnv+    pure $ TerminalDisplay cf stdout  -- | Display display :: TerminalDisplay -> [OutputElem] -> IO () display tdisp@(TerminalDisplay clearFirst term) oelems = do     cf <- modifyMVar clearFirst $ \cf -> return (False, cf)-    when cf $ runTermOutput term (maybe mempty id clearLineFirst)-    runTermOutput term $ renderOutput tdisp oelems+    when cf $ hPutStr term eraseLineFromCursor+    hPutStr term $ renderOutput tdisp oelems   where-        clearLineFirst = getCapability term clearEOL+        clearLineFirst = eraseLineFromCursor -renderOutput :: TerminalDisplay -> [OutputElem] -> TermOutput-renderOutput (TerminalDisplay _ term) to = mconcat $ map toTermOutput to+renderOutput :: TerminalDisplay -> [OutputElem] -> String+renderOutput (TerminalDisplay _ term) to = mconcat $ fmap toString to   where-        wF = maybe (const mempty) id $ getCapability term setForegroundColor-        wB = maybe (const mempty) id $ getCapability term setBackgroundColor-        rD = maybe mempty         id $ getCapability term restoreDefaultColors+        wF = flip sgrForeground False+        wB = flip sgrBackground False+        rD = sgrReset -        toTermOutput (Fg c) = wF c-        toTermOutput (Bg c) = wB c-        toTermOutput (T t)  = termText t-        toTermOutput (LeftT sz t)  = termText (t ++ replicate (sz - length t) ' ')-        toTermOutput (RightT sz t)  = termText (replicate (sz - length t) ' ' ++ t)-        toTermOutput NA     = rD+        toString (Fg c) = wF c+        toString (Bg c) = wB c+        toString (T t)  = t+        toString (LeftT size t)      = justify JustifyLeft      size t+        toString (RightT size t)     = justify JustifyRight     size t+        toString (CenterT size t)    = justify JustifyCenter    size t+        toString (JustifiedT size t) = justify JustifyJustified size t+        toString NA     = rD  -- | A simple utility that display a @msg@ in @color@-displayTextColor :: TerminalDisplay -> Color -> String -> IO ()-displayTextColor term color msg = do+displayTextColor :: TerminalDisplay -> ColorComponent -> String -> IO ()+displayTextColor term color msg =     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")+displayLn :: TerminalDisplay -> ColorComponent -> String -> IO ()+displayLn disp color msg = displayTextColor disp color (msg <> "\n") --- | Progress bar widget+white :: ColorComponent+white = 7++-- | A progress bar widget created and used within the `progress` function. data ProgressBar = ProgressBar TerminalDisplay ProgressBackend (MVar ProgressState)  type ProgressBackend = String -> IO ()@@ -120,31 +147,61 @@     , pgCurrent = 0     } --- | Create a new progress bar context-progress :: TerminalDisplay-         -> Int-         -> (ProgressBar -> IO a)-         -> IO a+-- | Create a new progress bar context from a terminal display, a number of+-- items, and a progress update function.+--+-- The progress bar update function should perform the desired actions on each+-- of the items, and call `progressTick` whenever an item is fully processed.+--+-- Each time the given update function calls progressTick the progress bar+-- fills by one item until the given number of items is matched. Once the bar+-- is filled it will not fill any further even if progressTick is called+-- again.+--+-- The progress bar will disappear when the given update function completes+-- running, even if the progress bar is not yet entirely filled.+--+-- For example, the following function will create a progress bar of 100+-- items, and complete one of the items every tenth of a second. Once all of+-- the items are completed the progress bar is removed and a completion String+-- is returned.+--+-- @+-- runProgressBar :: IO String+-- runProgressBar = do+--     terminalDisplay <- displayInit+--     progress terminalDisplay 100 (progressFunction 100)+--   where+--     progressFunction :: Int -> ProgressBar -> IO String+--     progressFunction 0 _   = return "Completed!"+--     progressFunction n bar = do+--       threadDelay 100000+--       progressTick bar+--       progressFunction (n - 1) bar+-- @+progress :: TerminalDisplay       -- ^ The terminal display to display the progress bar on.+         -> Int                   -- ^ The number of items the progress bar represents.+         -> (ProgressBar -> IO a) -- ^ The progression bar update function.+         -> IO a                  -- ^ The results of the progress bar update function. progress tdisp@(TerminalDisplay cf term) numberItems f = do-    let b = backend (getCapability term cursorDown)-                    (getCapability term carriageReturn)-                    (getCapability term clearEOL)+    let b = backend (Just cursorDown)+                    (Just "\r")+                    (Just eraseLineFromCursor)     pbar <- ProgressBar tdisp b <$> newMVar (initProgressState numberItems)      progressStart pbar     a <- f pbar-    displayLn tdisp White ""+    displayLn tdisp white ""     return a   where-    backend :: Maybe (Int -> TermOutput)-            -> Maybe TermOutput-            -> Maybe TermOutput+    backend :: Maybe (Word64 -> String)+            -> Maybe String+            -> Maybe String             -> ProgressBackend     backend _ (Just goHome) (Just clearEol) = \msg -> do-        runTermOutput term $ mconcat [clearEol, termText msg, goHome]+        hPutStr term $ mconcat [clearEol, msg, goHome]         modifyMVar_ cf $ return . const True-    backend _ _ _ = \msg ->-        displayLn tdisp White msg+    backend _ _ _ = displayLn tdisp white  showBar :: ProgressBar -> IO () showBar (ProgressBar _ backend pgsVar) = do@@ -154,26 +211,26 @@   where     getBar (ProgressState lhs rhs maxItems current) =             lhs `sep` bar `sep`-            (show current ++ "/" ++ show maxItems) `sep`+            (show current <> "/" <> show maxItems) `sep`             rhs       where         sep s1 s2             | null s1   = s2             | null s2   = s1-            | otherwise = s1 ++ " " ++ s2+            | otherwise = s1 <> " " <> s2          bar-            | maxItems == current = "[" ++ replicate szMax fillingChar ++ "]"-            | otherwise           = "[" ++ replicate filled fillingChar ++ ">" ++ replicate (unfilled-1) ' ' ++ "]"+            | maxItems == current = "[" <> replicate (CountOf szMax) fillingChar <> "]"+            | otherwise           = "[" <> replicate (CountOf filled) fillingChar <> ">" <> replicate unfilled' ' ' <> "]"          fillingChar = '=' -        unfilled, filled :: Int-        unfilled   = szMax - filled-        filled     = floor numberChar+        unfilled   = CountOf $ szMax - filled+        unfilled'  = CountOf $ szMax - filled - 1+        filled     = roundDown numberChar          numberChar = fromIntegral szMax / currentProgress-        szMax      = 40+        szMax      = 40 :: Int          currentProgress :: Double         currentProgress = fromIntegral maxItems / fromIntegral current@@ -184,7 +241,18 @@     showBar pbar     return () --- | Tick an element on the progress bar+-- | Ticks an element on the given progress bar. Should be used within a+-- progress bar update function that is passed into `progress`.+--+-- @+-- progressFunction :: ProgressBar -> IO String+-- progressFunction bar = do+--   threadDelay 100000+--   progressTick bar+--   threadDelay 200000+--   progressTick bar+--   return "Completed!"+-- @ progressTick :: ProgressBar -> IO () progressTick pbar@(ProgressBar _ _ st) = do     modifyMVar_ st $ \pgs -> return $ pgs { pgCurrent = min (pgMax pgs) (pgCurrent pgs + 1) }@@ -194,40 +262,104 @@ -- | Create a summary summary :: TerminalDisplay -> IO Summary summary tdisp@(TerminalDisplay cf term) = do-    let b = backend (getCapability term cursorDown)-                    (getCapability term carriageReturn)-                    (getCapability term clearEOL)+    let b = backend (Just cursorDown)+                    (Just "\r")+                    (Just eraseLineFromCursor)     return $ Summary b   where-    backend :: Maybe (Int -> TermOutput)-            -> Maybe TermOutput-            -> Maybe TermOutput+    backend :: Maybe (Word64 -> String)+            -> Maybe String+            -> Maybe String             -> SummaryBackend     backend _ (Just goHome) (Just clearEol) = \msg -> do-        runTermOutput term $ mconcat [clearEol, renderOutput tdisp msg, goHome]+        hPutStr term $ mconcat [clearEol, renderOutput tdisp msg, goHome]         modifyMVar_ cf $ return . const True     backend _ _ _ = \msg ->-        runTermOutput term $ mconcat [renderOutput tdisp msg]+        hPutStr term $ mconcat [renderOutput tdisp msg]  -- | Set the summary summarySet :: Summary -> [OutputElem] -> IO ()-summarySet (Summary backend) output = do-    backend output+summarySet (Summary backend) = backend --- | Justify position-data Justify = JustifyLeft | JustifyRight+-- | A justification of text.+data Justify = JustifyLeft       -- ^ Left align text+             | JustifyRight      -- ^ Right align text+             | JustifyCenter     -- ^ Center text+             | JustifyJustified  -- ^ Text fills the whole line width --- | box a string to a specific size, choosing the justification-justify :: Justify -> Int -> String -> String-justify dir sz s-    | sz <= szS = s-    | otherwise =-        let pad = replicate (sz - szS) ' '-         in case dir of-                JustifyLeft  -> pad ++ s-                JustifyRight -> s ++ pad+-- | Boxes a string to a given size using the given justification.+--+-- If the size of the given string is greater than or equal to the given boxing+-- size, then the original string is returned.+--+-- ==== __Examples__+--+-- Basic usage:+--+-- >>> justify JustifyRight 35 "Lorem ipsum dolor sit amet"+-- "Lorem ipsum dolor sit amet         "+--+-- >>> justify JustifyLeft 35 "Lorem ipsum dolor sit amet"+-- "         Lorem ipsum dolor sit amet"+--+-- >>> justify JustifyCenter 35 "Lorem ipsum dolor sit amet"+-- "    Lorem ipsum dolor sit amet     "+--+-- >>> justify JustifyJustified 35 "Lorem ipsum dolor sit amet"+-- "Lorem    ipsum   dolor   sit   amet"+--+-- Apply a justified justification to a one word string, resulting in a string+-- of the given length with the word at the left followed by the remaining+-- space.+--+-- >>> justify JustifyJustified 10 "Hello."+-- "Hello.    "+--+-- Attempt to box a string that is larger than the given box, yielding the+-- original string.+--+-- >>> justify JustifyRight 5 "Hello, World!"+-- "Hello, World!"+justify :: Justify -> CountOf Char -> String -> String+justify justification size string+    | size <= stringSize = string+    | otherwise = case justification of+        JustifyLeft      -> padding <> string+        JustifyRight     -> string <> padding+        JustifyCenter    -> if even sizeDifference+          then halfPadding <> string <>       halfPadding+          else halfPadding <> string <> ' ' `cons` halfPadding+        JustifyJustified -> justifyJustified size string   where-    szS = length s+    padding        = replicate sizeDifference ' '+    halfPadding    = replicate (toCount $ fromCount sizeDifference `div` 2) ' '+    sizeDifference = fromMaybe 0 $ size - stringSize+    stringSize     = length string+    even (CountOf n) = (n `mod` 2) == 0++-- | Justifies the given string so that it takes up the space of the entire+-- given box size.+justifyJustified :: CountOf Char -> String -> String+justifyJustified size string+    | numberOfWords == 1 = string <> replicate (toCount lengthDifference) ' '+    | otherwise          = justifiedString+  where+    justifiedString  = intercalate spaces $ insertExcessSpaces (toCount excessChars) stringWords+    spaces           = replicate (toCount spacing) ' '+    excessChars      = lengthDifference `mod` (numberOfWords - 1)+    spacing          = lengthDifference `div` (numberOfWords - 1)+    lengthDifference = fromCount size - wordsLength+    wordsLength      = foldl' (+) 0 $ fmap (fromCount . length) stringWords+    numberOfWords    = fromCount (length stringWords)+    stringWords      = words string++-- | Inserts excess spaces between words for the process of justifying a+-- string.+insertExcessSpaces :: CountOf Char -> [String] -> [String]+insertExcessSpaces _ []     = []+insertExcessSpaces 0 w      = w+insertExcessSpaces n (x:xs) = (x <> " ") : insertExcessSpaces (fromMaybe 0 $ n - 1) xs+ {- data Attr = Attr     { attrHasSize    :: Maybe Int@@ -281,14 +413,14 @@  -- | Column for a table data Column = Column-    { columnSize    :: Int     -- ^ Size of the column+    { columnSize    :: CountOf Char     -- ^ 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 :: CountOf Char -> String -> Column columnNew n name = Column     { columnSize    = n     , columnName    = name@@ -309,7 +441,7 @@ -- | Show the table headers tableHeaders :: TerminalDisplay -> Table -> IO () tableHeaders td t =-    tableAppend td t $ map columnName $ tColumns t+    tableAppend td t $ columnName <$> tColumns t  -- | Append a row to the table. --@@ -318,15 +450,19 @@ -- elements are dropped. tableAppend :: TerminalDisplay -> Table -> [String] -> IO () tableAppend td (Table cols rowSep) l = do-    let disp = case compare (length l) (length cols) of-                        LT -> zip cols (l ++ replicate (length cols - length l) "")-                        _  -> zip cols l-    mapM_ printColRow $ intersperse Nothing $ map Just disp+    let disp = case compare numelems numcols of+                        LT -> zip cols (l <> replicate (fromMaybe 0 $ numcols - numelems) "")+                        _  -> zip cols l :: [(Column, String)]+    mapM_ printColRow $ intersperse Nothing $ fmap Just disp   where+    numelems = length l+    numcols  = sizeCast Proxy (length cols) :: CountOf String     printColRow Nothing =-        display td [T $ rowSep]+        display td [T rowSep]     printColRow (Just (c, fieldElement)) = do         let oe = case columnJustify c of-                   JustifyLeft  -> RightT (columnSize c) fieldElement-                   JustifyRight -> LeftT (columnSize c) fieldElement+                   JustifyLeft      -> RightT     (columnSize c) fieldElement+                   JustifyRight     -> LeftT      (columnSize c) fieldElement+                   JustifyCenter    -> CenterT    (columnSize c) fieldElement+                   JustifyJustified -> JustifiedT (columnSize c) fieldElement         display td [oe,T "\n"]

@@ -36,7 +36,6 @@ -- >        putStrLn $ "using flag A : " ++ show (toParam flagA) -- >        putStrLn $ "args: " ++ show (toParam allArgs) ---{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE Rank2Types #-}@@ -66,6 +65,7 @@     , description     , Action     -- * Arguments+    , ValueParser     , FlagParser(..)     , Flag     , FlagLevel@@ -78,7 +78,9 @@     , getParams     ) where -import           Console.Options.Flags hiding (Flag, flagArg)+import Foundation (toList, toCount, fromList)++import           Console.Options.Flags hiding (Flag) import qualified Console.Options.Flags as F import           Console.Options.Nid import           Console.Options.Utils@@ -89,10 +91,9 @@ import           Control.Applicative import           Control.Monad import           Control.Monad.IO.Class-import           Control.Monad.State-import           Control.Monad.Writer  import           Data.List+import           Data.Maybe (fromMaybe) import           Data.Version import           Data.Functor.Identity @@ -151,7 +152,8 @@ -- | same as 'defaultMain', but with the argument defaultMainWith :: OptionDesc (IO ()) () -> [String] -> IO () defaultMainWith dsl args = do-    let (programDesc, res) = parseOptions dsl args+    progrName <- getProgName+    let (programDesc, res) = parseOptions (programName progrName >> dsl) args      in case res of         OptionError s          -> putStrLn s >> exitFailure         OptionHelp             -> help (stMeta programDesc) (stCT programDesc) >> exitSuccess@@ -170,8 +172,8 @@ --helpSubcommand :: [String] -> IO ()  help :: ProgramMeta -> Command (IO ()) -> IO ()-help pmeta (Command hier _ commandOpts _) = mapM_ putStrLn . lines $ snd $ runWriter $ do-    tell (maybe "<program>" id (programMetaName pmeta) ++ " version " ++ maybe "<undefined>" id (programMetaVersion pmeta) ++ "\n")+help pmeta (Command hier _ commandOpts _) = do+    tell (fromMaybe "<program>" (programMetaName pmeta) ++ " version " ++ fromMaybe "<undefined>" (programMetaVersion pmeta) ++ "\n")     tell "\n"     maybe (return ()) (\d -> tell d >> tell "\n\n") (programMetaDescription pmeta)     tell "Options:\n"@@ -182,20 +184,25 @@             tell "\n"             tell "Commands:\n"             let cmdLength = maximum (map (length . fst) subs) + 2-            mapM_ (\(n, c) -> tell $ indent 2 (justify JustifyRight cmdLength n ++ getCommandDescription c ++ "\n")) subs+            forM_ subs $ \(n, c) -> tell $ indent 2 (toList (justify JustifyRight (toCount cmdLength) (fromList n)) ++ getCommandDescription c ++ "\n")             tell "\n"-            mapM_ (printSub 0) subs+            mapM_ (printSub 2) subs         CommandLeaf _    ->             return ()   where+    tell = putStr     printSub iLevel (name, cmdOpt) = do-        tell ("\n" ++ name ++ " options:\n\n")+        tell $ "\nCommand `" ++ name ++ "':\n\n"+        tell $ indent iLevel "Options:\n\n"         mapM_ (tell . printOpt iLevel) (getCommandOptions cmdOpt)         case getCommandHier cmdOpt of-            CommandTree _ -> do-                return ()-            CommandLeaf _ -> do-                return ()+            CommandTree subs -> do+                tell $ indent iLevel "Commands:\n"+                let cmdLength = maximum (map (length . fst) subs) + 2 + iLevel+                forM_ subs $ \(n, c) -> tell $ indent (iLevel + 2) (toList (justify JustifyRight (toCount cmdLength) (fromList n)) ++ getCommandDescription c ++ "\n")+                tell "\n"+                mapM_ (printSub (iLevel + 2)) subs+            CommandLeaf _ -> pure ()         --tell . indent 2 ""      printOpt iLevel fd =@@ -283,6 +290,8 @@ indent n s = replicate n ' ' ++ s  -- | Set the program name+--+-- default is the result of base's `getProgName` programName :: String -> OptionDesc r () programName s = modify $ \st -> st { stMeta = (stMeta st) { programMetaName = Just s } } 

@@ -26,6 +26,8 @@ import Data.List import Data.Monoid +import Basement.Compat.Semigroup+ -- | Result of validation of flag value. data FlagArgValidation = FlagArgValid          -- ^ Validation success                        | FlagArgInvalid String -- ^ Validation failed with reason@@ -73,6 +75,11 @@     flat ff  (FlagDescription f) = ff { flagDescription = Just f }     flat acc (FlagMany l)        = foldl' flat acc l +instance Semigroup FlagFrag where+    (<>) (FlagMany l1) (FlagMany l2) = FlagMany (l1 ++ l2)+    (<>) (FlagMany l1) o             = FlagMany (l1 ++ [o])+    (<>) o             (FlagMany l2) = FlagMany (o : l2)+    (<>) o1            o2            = FlagMany [o1,o2] instance Monoid FlagFrag where     mempty                              = FlagMany []     mappend (FlagMany l1) (FlagMany l2) = FlagMany (l1 ++ l2)

@@ -14,16 +14,18 @@     , gatherDesc     , getNextID     , getNextIndex+    , modify     ) where  import           Control.Applicative import           Console.Options.Nid import           Console.Options.Types import           Console.Options.Utils-import           Control.Monad.State-import           Control.Monad.Identity import           System.Exit +import Foundation.Monad+import Foundation.Monad.State+ -- | Ongoing State of the program description, as filled by monadic action data ProgramDesc r = ProgramDesc     { stMeta        :: ProgramMeta@@ -45,11 +47,14 @@  -- | Option description Monad newtype OptionDesc r a = OptionDesc { runOptionDesc :: StateT (ProgramDesc r) Identity a }-    deriving (Functor,Applicative,Monad,MonadState (ProgramDesc r))+    deriving (Functor,Applicative,Monad)+instance MonadState (OptionDesc r) where+    type State (OptionDesc r) = ProgramDesc r+    withState f = OptionDesc $ withState f  -- | Run option description gatherDesc :: OptionDesc r a -> ProgramDesc r-gatherDesc dsl = runIdentity $ execStateT (runOptionDesc dsl) initialProgramDesc+gatherDesc dsl = snd $ runIdentity $ runStateT (runOptionDesc dsl) initialProgramDesc  initialProgramDesc :: ProgramDesc r initialProgramDesc = ProgramDesc { stMeta        = programMetaDefault@@ -65,12 +70,15 @@ getNextID :: OptionDesc r Nid getNextID = do     (nid, nidGen) <- nidNext . stNextID <$> get-    modify $ \st -> st { stNextID = nidGen }+    withState $ \st -> ((), st { stNextID = nidGen })     return nid +modify :: (ProgramDesc r -> ProgramDesc r) -> OptionDesc r ()+modify f = withState $ \st -> ((), f st)+ -- | Return the next unique position argument ID getNextIndex :: OptionDesc r UnnamedIndex getNextIndex = do     idx <- stNextIndex <$> get-    modify $ \st -> st { stNextIndex = idx + 1 }+    withState $ \st -> ((), st { stNextIndex = idx + 1 })     return idx

@@ -29,6 +29,7 @@  import           Console.Options.Flags (FlagDesc) import           Console.Options.Nid+import           Data.Maybe  -- | A unnamed argument data Argument =@@ -116,7 +117,7 @@ instance Param Flag where     type Ret Flag a = Bool     getParams (Params flagArgs _ _) (Flag nid) =-        maybe False (const True) $ lookup nid flagArgs+        isJust $ lookup nid flagArgs instance Param FlagLevel where     type Ret FlagLevel a = Int     getParams (Params flagArgs _ _) (FlagLevel nid) =

@@ -46,3 +46,8 @@         putStrLn $ "using flag A : " ++ show (toParam flagA)         putStrLn $ "args: " ++ show (toParam allArgs) ```++License+-------++The source code of cli is available under the [BSD 3-Clause license](https://opensource.org/licenses/BSD-3-Clause), see `LICENSE` for more information.

@@ -1,63 +1,57 @@-Name:                cli-Version:             0.1.2-Synopsis:            Command Line Interface-Description: -    All you need for interacting with users at the Console level-    .-    * Display routines, formatting, progress bars-    .-    * Options parsing-    .-License:             BSD3-License-file:        LICENSE-Copyright:           Vincent Hanquez <vincent@snarc.org>, Nicolas Di Prima <nicolas@di-prima.fr>-Author:              Vincent Hanquez <vincent@snarc.org>, Nicolas Di Prima <nicolas@di-prima.fr>-Maintainer:          vincent@snarc.org-Category:            cli-Stability:           experimental-Build-Type:          Simple-Homepage:            https://github.com/vincenthz/hs-cli-Bug-Reports:         https://github.com/vincenthz/hs-cli/issues-Cabal-Version:       >=1.10-extra-source-files:  README.md--source-repository head-  type: git-  location: https://github.com/vincenthz/hs-cli+cabal-version: 1.12 -Library-  Exposed-modules:   Console.Display-                   , Console.Options-  Other-modules:     Console.Options.Nid-                   , Console.Options.Flags-                   , Console.Options.Monad-                   , Console.Options.Types-                   , Console.Options.Utils-  Build-depends:     base >= 4 && < 5-                   , transformers-                   , mtl-                   , terminfo-  ghc-options:       -Wall -fwarn-tabs -fno-warn-unused-imports-  default-language:  Haskell2010+-- This file has been generated from package.yaml by hpack version 0.31.1.+--+-- see: https://github.com/sol/hpack+--+-- hash: bf0a618f8bd90a826dbcb6f5911cf0add6644863cb2148d8ecc6ae2e07938567 +name:           cli+version:        0.2.0+synopsis:       CLI+description:    please see README.md+category:       cli+homepage:       https://github.com/vincenthz/hs-cli#readme+author:         Vincent Hanquez <vincent@snarc.org>, Nicolas Di Prima <nicolas@di-prima.fr>+maintainer:     vincent@snarc.org+copyright:      Vincent Hanquez <vincent@snarc.org>, Nicolas Di Prima <nicolas@di-prima.fr>+license:        BSD3+license-file:   LICENSE+build-type:     Simple+extra-source-files:+    README.md+    LICENSE ---Executable           cli---  Main-Is:           cli.hs--- mtl ghc-options:       -Wall -fno-warn-missing-signatures---  Hs-Source-Dirs:    .---  Build-depends:     base >= 4 && < 5---  default-language:  Haskell2010+library+  exposed-modules:+      Console.Display+      Console.Options+  other-modules:+      Console.Options.Nid+      Console.Options.Flags+      Console.Options.Monad+      Console.Options.Types+      Console.Options.Utils+  hs-source-dirs:+      ./.+  default-extensions: TypeFamilies DataKinds OverloadedStrings+  build-depends:+      base >0 && <10+    , basement+    , foundation+  default-language: Haskell2010 -Test-Suite test-cli-  type:              exitcode-stdio-1.0-  hs-source-dirs:    tests-  Main-is:           Cli.hs-  default-language:  Haskell2010-  Build-Depends:     base >= 3 && < 5-                   , directory-                   , transformers-                   , tasty-                   , tasty-quickcheck-                   , QuickCheck-                   , cli-  ghc-options:       -Wall -fno-warn-orphans -fno-warn-missing-signatures -fwarn-tabs -fno-warn-unused-imports+executable example+  main-is: Simple.hs+  other-modules:+      Paths_cli+  hs-source-dirs:+      examples/+  default-extensions: TypeFamilies DataKinds OverloadedStrings+  ghc-options: -threaded -rtsopts -with-rtsopts=-N+  build-depends:+      base >0 && <10+    , basement+    , cli+    , foundation+  default-language: Haskell2010

@@ -0,0 +1,35 @@+module Main where++import Console.Options+import Data.Char (isDigit)+import Data.Monoid++data MyADT = A | B | C+    deriving (Show,Eq)++main = defaultMain $ do++    programName "my-simple-program"+    programDescription "an optional description of your program that can be found in the help"++    -- a simple boolean flag -v or --verbose+    showFlag <- flag (FlagShort 'v' <> FlagLong "verbose" <> FlagDescription "activate verbose mode")++    -- a flag '-n' or '--name' requiring a string as parameter+    nameFlag <- flagParam (FlagShort 'n' <> FlagLong "name" <> FlagDescription "name of something")+                          (FlagRequired $ \s -> Right s)++    -- a flag 'i' or '--int' requiring an integer as parameter+    valueFlag <- flagParam (FlagShort 'i' <> FlagLong "int" <> FlagDescription "an integer value")+                           (FlagRequired $ \s -> if all isDigit s then Right (read s :: Int) else Left "invalid integer")++    -- a flag with an optional parameter, defaulting to some value+    xyzFlag <- flagParam (FlagShort 'x' <> FlagLong "xyz" <> FlagDescription "some ADT option")+                         (FlagOptional B (\s -> if s == "A" then Right A else if s == "B" then Right B else if s == "C" then Right C else Left "invalid value"))++    +    action $ \toParam -> do+        putStrLn $ show $ toParam showFlag+        putStrLn $ show $ toParam nameFlag+        putStrLn $ show $ toParam valueFlag+        putStrLn $ show $ toParam xyzFlag

@@ -1,55 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-module Main (main) where--import           Control.Applicative-import           Control.Monad--import           Test.Tasty-import           Test.Tasty.QuickCheck-import           Test.QuickCheck.Monadic--import           System.Directory-import           Data.List-import           Data.Monoid-import           Data.Functor.Identity--import           Console.Options hiding (defaultMain)--flagA = flagParam (FlagShort 'a' <> FlagLong "aaa") (FlagRequired Right)-flagB = flagParam (FlagShort 'b' <> FlagLong "bbb") (FlagRequired Right)--commandFoo = command "foo" $ do-    action $ \toParam -> return True----commandBar :: Monad m => OptionDesc (m Bool) ()-commandBar :: OptionDesc (Identity Bool) ()-commandBar = command "bar" $ do-    a  <- flagA-    a2 <- argument "arg1" Right-    action $ \toParam -> do-        return True--testParseHelp name f = testProperty name $ runIdentity $ do-    case snd f of-        OptionHelp -> return True-        _          -> return False--testParseSuccess name values f =-    testProperty name $-        let (_,r) = f-         in case r of-                OptionSuccess p act -> runIdentity $ return (sort values == sort (paramsFlags p))-                OptionHelp          -> error $ "got help expected success"-                OptionError s       -> error $ "got error " ++ show s ++ " expected success"-                OptionInvalid s     -> error $ "got invalid " ++ show s ++ " expected success"--main = defaultMain $ testGroup "options"-    [ testGroup "help"-        [ testParseHelp "1" $ parseOptions (commandBar) ["options", "argument", "--help", "a"]-        , testParseHelp "2" $ parseOptions (commandBar) ["options", "argument", "-h", "a"]-        ]-    , testGroup "success"-        [ testParseSuccess "1" [] $ parseOptions (commandBar >> commandFoo) ["bar", "arg1"]-        , testParseSuccess "2" [] $ parseOptions (commandBar >> commandFoo) ["foo", "a"]-        ]-    ]