cli 0.0.5 → 0.1.0

raw patch · 15 files changed

+1134/−627 lines, 15 filesdep +QuickCheckdep +mtldep +tastydep −containersdep ~basenew-uploaderPVP ok

version bump matches the API change (PVP)

Dependencies added: QuickCheck, mtl, tasty, tasty-quickcheck, terminfo, transformers

Dependencies removed: containers

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• Application/CLI.hs +0/−252
• Application/CLI/Class.hs +0/−53
• Application/CLI/Types.hs +0/−226
• Console/Display.hs +301/−0
• Console/Options.hs +357/−0
• Console/Options/Flags.hs +146/−0
• Console/Options/Monad.hs +66/−0
• Console/Options/Nid.hs +21/−0
• Console/Options/Types.hs +129/−0
• Console/Options/Utils.hs +10/−0
• LICENSE +1/−1
• README.md +4/−1
• cli.cabal +47/−31
• example/Main.hs +0/−63
• tests/Cli.hs +52/−0

@@ -1,252 +0,0 @@--- |--- Module      : Application.CLI--- License     : BSD-Style--- Copyright   : Copyright © 2014 Nicolas DI PRIMA------ Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>--- Stability   : experimental--- Portability : unknown------ This module aimes to provide an easy and low-dependencies Command Line--- configuration options.------ You can create a new command for your program by creating an object--- And creating an instance of CLI of this object------ @---   data MyEchoCommand = MyEchoCommand---   instance CLI MyCommand where---      name _ = "cmd"---      desc _ = "just echo the given arguments"---      options _ = [ OptHelp [] (Just "string") "the message to print" ]---      action _ _ =---          withStr "string" $ \str -> exectute $ putStrLn str--- @------ And to create you application, you need 2 functions (initialize, with and defaultMain).--- * @initialize@: only create the default CLIContext with a default Help command---   and a default Usage function--- * @with@: insert the Command into the CLIContext--- * @defaultMain@: will trigger the right command------ @---   main :: IO ()---   main = defaultMain $ with MyEchoCommand $ initialize "a message header in case the help command is triggered"--- @-----module Application.CLI-    ( -- * Default Main-      defaultMain--      -- * CLI-    , CLI(..)-    , OptHelp(..)-      -- ** Default CLIs-    , Help(..)-    , printHelp--      -- * Commands-    , CLIContext-    , getHeader-    , initialize-    , initializeWithDefault-    , with--      -- * Options-    , Options-    , withStr-    , withOptionalStr-    , withParameterStr-    , withOptionalParameterStr-    , withFlag-    , execute-    ) where--import Application.CLI.Class-import Application.CLI.Types-import Data.List-import System.Environment-import System.Exit---- | Default usage Command Interface-data Usage = Usage-instance CLI Usage where-    name    _ = ""-    desc    _ = ""-    options _ = []-    action  _ ctx opts = do-        progName <- getProgName-        usage (printUsage "    " progName ctx) opts--usage :: String-      -> [String]-      -> IO ()-usage list msgs = do-    mapM_ (\str -> putStrLn str) msgs-    putStrLn list-    exitFailure---- | This is the default help command------ It is triggered by the command "help" and also provides--- an option to print a specific command options-data Help = Help-instance CLI Help where-    name    _  = "help"-    desc    _  = "show help message"-    options _  = [ OptHelp [] (Just "command") "print the help message for a specific command"-                 ]-    action  _ ctx =-        withOptionalStr $ \mcommand ->-        execute $ do-            case mcommand of-                Nothing -> printStdHelp-                Just c  -> printCmdHelp c-      where-        printCmdHelp :: String -> IO ()-        printCmdHelp cmd = do-            case lookupCommand cmd ctx of-                Nothing -> error $ "command '" ++ cmd ++ "' does not exist"-                Just c  -> putStrLn $ printCommandHelp "   " c--        printStdHelp :: IO ()-        printStdHelp = do-            progName <- getProgName-            putStrLn $ progName ++ ": " ++ getHeader ctx-            putStrLn $ printHelp "    " progName ctx------------------------------------------------------------------------------------                               Commands                                    -------------------------------------------------------------------------------------- | Add a new Command into a collection of commands-with :: CLI cli-     => cli      -- ^ A new Command Interface-     -> CLIContext -- ^ The original Collection of commands-     -> CLIContext-with c l = insertCommand (cliToCommand c) l---- | Initialize a collection of commands-initializeWithDefault :: CLI cliDefault-                      => cliDefault -- ^ The command to execute if no option is given-                      -> String     -- ^ CLI Description-                      -> CLIContext-initializeWithDefault defaultCli description =-    insertDefault (cliToCommand defaultCli) cmdMap-  where-    cmdMap = initialize description---- | Initialize a collection of command-initialize :: String     -- ^ CLI Description-           -> CLIContext-initialize description =-    createContext (cliToCommand Usage) description------------------------------------------------------------------------------------                             Options                                       -------------------------------------------------------------------------------------- | This function is to expect an argument at the Head of the @Options@--- if the command is not found at the head, the program fails and the description--- message is printed-withStr :: String  -- ^ a description of what is expected-        -> (String -> Options -> IO a)-        -> Options-        -> IO a-withStr what _ []     = error $ "expecting <" ++ what ++ ">"-withStr _    f (x:xs) = f x xs---- | This function is to expect an optional argument--- of the command is not found at the Head of the @Options@--- the function will be executed with Nothing, otherwise it will be executed--- with (Just @String@)-withOptionalStr :: (Maybe String -> Options -> IO a)-                -> Options-                -> IO a-withOptionalStr f []     = f Nothing  []-withOptionalStr f (x:xs) = f (Just x) xs---- | Look for a parameterized option--- The given list of flags are the potential list of flags that can be use to--- find the position of the options------ This parameter can be found anywhere in the Options list and the argument--- of the function will be the string following one of this Flags--- The parameter and its value are removed from the options before being use--- into the function.-withParameterStr :: [String] -- ^ the reference flag-                 -> (String -> Options -> IO a)-                 -> Options-                 -> IO a-withParameterStr flags f l =-    case break (flip elem flags) l of-        (_  , [])      -> error $ "expecting parameter " ++ intercalate ", " flags ++ " <value>"-        (_  , _:[])    -> error $ "parameter " ++ intercalate ", " flags ++ " is expection an argument"-        (xs1, _:p:xs2) -> f p (xs1 ++ xs2)---- | idem as @withParameterStr@ but it is an optional parameter-withOptionalParameterStr :: [String] -- ^ the reference flag-                         -> (Maybe String -> Options -> IO a)-                         -> Options-                         -> IO a-withOptionalParameterStr flags f l =-    case break (flip elem flags) l of-        (xs1, [])      -> f Nothing xs1-        (_  , _:[])    -> error $ "parameter " ++ intercalate ", " flags ++ " is expecting an argument"-        (xs1, _:p:xs2) -> f (Just p) (xs1 ++ xs2)---- | This function is to expect Flag in the Options--- it will look into all the options and will remove the string--- from the Options-withFlag :: [String]                   -- ^ the flag to lookup-         -> (Bool -> Options -> IO a)  -- ^ the function to execute-         -> Options                    -- ^ the options-         -> IO a-withFlag flags f l =-    case break (flip elem flags) l of-        (xs1, [])    -> f False xs1-        (xs1, _:xs2) -> f True  (xs1 ++ xs2)---- | This function makes the use of the other function easier--- and also provide a verification that there is no "unused function".--- If there is unexpected options remaining, the program will stop and an--- error message will be printed-execute :: IO a-        -> Options-        -> IO a-execute f [] = f-execute _ l  = error $ "this options are not expected: " ++ intercalate " " l------------------------------------------------------------------------------------                             Default Main                                  -------------------------------------------------------------------------------------- | The default Main--- It will analyze the program's parameters and will trigger the--- right command.-defaultMain :: CLIContext -- ^ A collection of commands-            -> IO ()-defaultMain cmdMap = do-    args <- getArgs-    case args of-        []     -> tryDefault-        (x:xs) -> tryCommand x xs-  where-    raiseHelper :: String-                -> IO ()-    raiseHelper what =-        cmdAction (getHelper cmdMap) cmdMap [what]-    tryDefault :: IO ()-    tryDefault = do-        progName <- getProgName-        case getDefault cmdMap of-            Nothing  -> raiseHelper $ progName ++ " does not provide default command"-            Just cmd -> cmdAction cmd cmdMap []-    tryCommand :: String-               -> [String]-               -> IO ()-    tryCommand cmdstr opts =-        case lookupCommand cmdstr cmdMap of-            Nothing  -> raiseHelper $ cmdstr ++ ": command does not exist"-            Just cmd -> cmdAction cmd cmdMap opts

@@ -1,53 +0,0 @@--- |--- Module      : Application.CLI.Class--- License     : BSD-Style--- Copyright   : Copyright © 2014 Nicolas DI PRIMA------ Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>--- Stability   : experimental--- Portability : unknown----module Application.CLI.Class-    ( CLI (..)-    , cliToCommand-    ) where--import Application.CLI.Types---- | This is the CLI Class--- All command you want to add into the CLIContext must be an instance of this--- class.-class CLI cli where-    -- | This is the name of the command. It is also the command line option-    -- the action will be triggered every time this string is found to be the-    -- first argument of the program-    name    :: cli-            -> String-    -- | A description of this command-    -- Will be use in the default Usage and the Help function-    desc    :: cli-            -> String-    -- | The list of Options-    -- It is only for printing, the parser won't use this to parse the command-    -- parameters.-    options :: cli-            -> [OptHelp]-    -- | The action to perfom every time the @name@ is found to be the first-    -- string of the program parameters-    action  :: cli-            -> CLIContext -- ^ This could be use in order to know all the different available commands etc...-            -> Options    -- ^ The Command Parameters-            -> IO ()---- | Make the transformation of a CLI instance to a Command--- object-cliToCommand :: CLI cli-             => cli-             -> Command-cliToCommand cli =-    Command-        { cmdName    = name cli-        , cmdDesc    = desc cli-        , cmdOptions = options cli-        , cmdAction  = action cli-        }

@@ -1,226 +0,0 @@--- |--- Module      : Application.CLI.Types--- License     : BSD-Style--- Copyright   : Copyright © 2014 Nicolas DI PRIMA------ Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>--- Stability   : experimental--- Portability : unknown----module Application.CLI.Types-    ( -- * Types-      CLIContext-    , Command(..)-    , OptHelp(..)-    , Options-    -      -- * Commands-      -- ** Getter/Setter-    , createContext-    , getHeader-    , getHelper-    , insertDefault-    , getDefault-    , insertCommand-      -- ** Lookup-    , lookupCommand--      -- * pretty printer-    , printUsage-    , printHelp-    , printOptHelp-    , printCommandHelp-    ) where--import           Data.Map.Strict (Map)-import qualified Data.Map.Strict as M------------------------------------------------------------------------------------                               Commands                                    -------------------------------------------------------------------------------------- | This is the Command Line Context--- This object embeds:--- * the commands to trigger--- * a default command in case no command is given--- * a program description--- * a Helper Command: the command to trigger in case of a wrong command (example: Usage)-data CLIContext = CLIContext-    { getCommands :: Map String Command-    , getDefault  :: Maybe Command -- ^ get the default command (if any)-    , getHeader   :: String  -- ^ Program's description-    , getHelper   :: Command -- ^ get the program's help function (usage)-    } deriving (Show, Eq)---- | Create a CLIContext-createContext :: Command -- ^ the command helper (example: the Usage)-              -> String  -- ^ a description about the program-              -> CLIContext-createContext helper header =-    CLIContext-        { getCommands = M.empty-        , getDefault  = Nothing-        , getHelper   = helper-        , getHeader   = header-        }---- | Insert a command into the CLIContext------ If the command with the same name is already present, the old one will be--- removed and the new one will take place-insertCommand :: Command    -- ^ the command to insert-              -> CLIContext -- ^ the CLIContext to update-              -> CLIContext-insertCommand cmd cmdMap = cmdMap { getCommands = M.insert (cmdName cmd) cmd (getCommands cmdMap) }---- | Insert a default Command into the CLI------ This command won't be added into the command to trigger--- If there was already a Default Command this command will replace the old one-insertDefault :: Command    -- ^ The Default Command-              -> CLIContext-              -> CLIContext-insertDefault cmd cmdMap =-    insertCommand cmd $cmdMap { getDefault  = Just cmd }---- | Lookup a command by its command's name-lookupCommand :: String     -- ^ the command's name-              -> CLIContext -- ^ the commands to look up into-              -> Maybe (Command)-lookupCommand k cmdMap = M.lookup k (getCommands cmdMap)------------------------------------------------------------------------------------                                  Options                                  -------------------------------------------------------------------------------------- | The Command Options parameter-type Options = [String]------------------------------------------------------------------------------------                                  Command                                  -------------------------------------------------------------------------------------- | A command-data Command =-      Command-        { cmdName :: String-        , cmdDesc :: String-        , cmdOptions :: [OptHelp]-        , cmdAction  :: CLIContext -> Options -> IO ()-        }--instance Eq Command where-    (==) a b = eqname && eqdesc && eqopts-      where-        eqname = cmdName a == cmdName b-        eqdesc = cmdDesc a == cmdDesc b-        eqopts = cmdOptions a == cmdOptions b--instance Show Command where-    show c =-        "Command { " ++ "name: " ++ (cmdName c) ++ ", "-                     ++ "desc: " ++ (cmdDesc c) ++ ", "-                     ++ "opts: " ++ (show $ cmdOptions c) ++ " }"---- | Pretty print a command-printCommandHelp :: String  -- ^ indentation-                 -> Command -- ^ the command to pretty print-                 -> String-printCommandHelp prefix cmd =-    prefix ++ cmdName cmd ++ ": " ++ cmdDesc cmd ++ "\n"-    ++ (foldr (\c acc -> prefix ++ prefix ++ (printOptHelp c) ++ "\n" ++ acc) "" (cmdOptions cmd))------------------------------------------------------------------------------------                         Option helps                                      -------------------------------------------------------------------------------------- | Option help------ It describes the Command parameters-data OptHelp = OptHelp-    { -- | an option can have multiple symbols, mainly a short option and a long option-      -- for example [ "-h", "--help" ]-      optSymbols     :: [String]-    , -- | an option can have an argument, or not-      optArgument    :: Maybe String-    , optDescription :: String -- ^ option description-    } deriving (Eq, Show)---- | This function is a helper to print an OptHelp-printOptHelp :: OptHelp-             -> String-printOptHelp opthelp =-    (printSymbols $ optSymbols opthelp)-    ++ (printArgument $ optArgument opthelp)-    ++ (optDescription opthelp)-  where-    printSymbols :: [String] -> String-    printSymbols []     = ""-    printSymbols [x]    = x ++ " "-    printSymbols (x:xs) = x ++ ", " ++ printSymbols xs--    printArgument :: Maybe String -> String-    printArgument Nothing  = ""-    printArgument (Just x) = "<" ++ x ++ "> "------------------------------------------------------------------------------------                          Pretty printers                                  -------------------------------------------------------------------------------------- | Print all the Command's Option help-printHelp :: String   -- ^ indentation-          -> String   -- ^ program name-          -> CLIContext -- ^ command list-          -> String-printHelp prefix name cmdMap =-    (defaultUsage prefix name $ getDefault cmdMap)-    ++ "\n"-    ++ (listCommands prefix cmdMap)---- | Print the all the commands helps-listCommands :: String-             -> CLIContext-             -> String-listCommands prefix cmdMap =-    "Available commands:\n"-    ++ (foldr (\c acc -> "\n" ++ (printCommandHelp listPrefix c) ++ acc) "" (M.elems $ getCommands cmdMap))-  where-    listPrefix :: String-    listPrefix = prefix---- | Pretty printer: list the available commands-printUsage :: String   -- ^ indentation-           -> String   -- ^ program name-           -> CLIContext -- ^ the command to print-           -> String-printUsage prefix name cmdMap =-    (defaultUsage prefix name $ getDefault cmdMap)-    ++ "\n"-    ++ (listDescriptions prefix cmdMap)---- | Print the defaul usage (if any)-defaultUsage :: String -- ^ prefix-             -> String -- ^ program name-             -> Maybe (Command)-             -> String-defaultUsage _      _    Nothing    = ""-defaultUsage prefix name (Just cmd) =-    prefix ++ "Usage: " ++ name ++ " [" ++ (cmdName cmd) ++ "]\n"---- | will list all the description's commands present in the CLI Context-listDescriptions :: String     -- ^ prefix-                 -> CLIContext -- ^ the context-                 -> String-listDescriptions prefix cmdMap =-    "Available commands:\n"-    ++ (foldr (\c acc -> "\n" ++ (commandDescription listPrefix c) ++ acc) "" (M.elems $ getCommands cmdMap))-  where-    listPrefix :: String-    listPrefix = prefix---- | print a command's description-commandDescription :: String-                   -> Command-                   -> String-commandDescription prefix cmd =-    prefix ++ cmdName cmd ++ ": " ++ cmdDesc cmd ++ "\n"

@@ -0,0 +1,301 @@+module Console.Display+    ( TerminalDisplay+    -- * Basic+    , displayInit+    , display+    , displayTextColor+    , displayLn+    -- * Progress Bar+    , ProgressBar+    , progress+    , progressTick+    -- * Summary line+    , Summary+    , summary+    , summarySet+    -- * Attributes+    , Color(..)+    , OutputElem(..)+    , termText+    , justify+    -- * Table+    , Justify(..)+    , Table+    , Column+    , columnNew+    , tableCreate+    , tableHeaders+    , tableAppend+    ) where++import           Control.Applicative+import           Control.Monad+import           Control.Concurrent.MVar+import           System.Console.Terminfo+import           System.IO+import           Data.List++{-+data LineWidget =+      Text+    | Progress+    | Done+-}++data OutputElem =+      Bg Color+    | Fg Color+    | T  String+    | LeftT Int String+    | RightT Int String+    | NA+    deriving (Show,Eq)++data TerminalDisplay = TerminalDisplay (MVar Bool) Terminal++displayInit :: IO TerminalDisplay+displayInit = do+    hSetBuffering stdout NoBuffering+    cf <- newMVar False+    TerminalDisplay cf <$> setupTermFromEnv++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+  where+        clearLineFirst = getCapability term clearEOL++renderOutput :: TerminalDisplay -> [OutputElem] -> TermOutput+renderOutput (TerminalDisplay _ term) to = mconcat $ map toTermOutput 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++        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++displayTextColor :: TerminalDisplay -> Color -> String -> IO ()+displayTextColor term color msg = do+    display term [Fg color, T msg]++displayLn :: TerminalDisplay -> Color -> String -> IO ()+displayLn disp color msg = displayTextColor disp color (msg ++ "\n")++data ProgressBar = ProgressBar TerminalDisplay ProgressBackend (MVar ProgressState)++type ProgressBackend = String -> IO ()++data Summary = Summary SummaryBackend+type SummaryBackend = [OutputElem] -> IO ()++data ProgressState = ProgressState+    { pgLhs     :: String+    , pgRhs     :: String+    , pgMax     :: Int+    , pgCurrent :: Int+    }++initProgressState :: Int -> ProgressState+initProgressState maxItems = ProgressState+    { pgLhs     = ""+    , pgRhs     = ""+    , pgMax     = maxItems+    , pgCurrent = 0+    }++progress :: TerminalDisplay+         -> Int+         -> (ProgressBar -> IO a)+         -> IO a+progress tdisp@(TerminalDisplay cf term) numberItems f = do+    let b = backend (getCapability term cursorDown)+                    (getCapability term carriageReturn)+                    (getCapability term clearEOL)+    pbar <- ProgressBar tdisp b <$> newMVar (initProgressState numberItems)++    progressStart pbar+    a <- f pbar+    displayLn tdisp White ""+    return a+  where+    backend :: Maybe (Int -> TermOutput)+            -> Maybe TermOutput+            -> Maybe TermOutput+            -> ProgressBackend+    backend _ (Just goHome) (Just clearEol) = \msg -> do+        runTermOutput term $ mconcat [clearEol, termText msg, goHome]+        modifyMVar_ cf $ return . const True+    backend _ _ _ = \msg ->+        displayLn tdisp White msg++showBar :: ProgressBar -> IO ()+showBar (ProgressBar _ backend pgsVar) = do+    pgs <- readMVar pgsVar+    let bar = getBar pgs+    backend bar+  where+    getBar (ProgressState lhs rhs maxItems current) =+            lhs `sep` bar `sep`+            (show current ++ "/" ++ show maxItems) `sep`+            rhs+      where+        sep s1 s2+            | null s1   = s2+            | null s2   = s1+            | otherwise = s1 ++ " " ++ s2++        bar+            | maxItems == current = "[" ++ replicate szMax fillingChar ++ "]"+            | otherwise           = "[" ++ replicate filled fillingChar ++ ">" ++ replicate (unfilled-1) ' ' ++ "]"++        fillingChar = '='++        unfilled, filled :: Int+        unfilled   = szMax - filled+        filled     = floor numberChar++        numberChar = fromIntegral szMax / currentProgress+        szMax      = 40++        currentProgress :: Double+        currentProgress = fromIntegral maxItems / fromIntegral current++progressStart :: ProgressBar -> IO ()+progressStart pbar = do+    showBar pbar+    return ()++progressTick :: ProgressBar -> IO ()+progressTick pbar@(ProgressBar _ _ st) = do+    modifyMVar_ st $ \pgs -> return $ pgs { pgCurrent = min (pgMax pgs) (pgCurrent pgs + 1) }+    showBar pbar+    return ()++summary :: TerminalDisplay -> IO Summary+summary tdisp@(TerminalDisplay cf term) = do+    let b = backend (getCapability term cursorDown)+                    (getCapability term carriageReturn)+                    (getCapability term clearEOL)+    return $ Summary b+  where+    backend :: Maybe (Int -> TermOutput)+            -> Maybe TermOutput+            -> Maybe TermOutput+            -> SummaryBackend+    backend _ (Just goHome) (Just clearEol) = \msg -> do+        runTermOutput term $ mconcat [clearEol, renderOutput tdisp msg, goHome]+        modifyMVar_ cf $ return . const True+    backend _ _ _ = \msg ->+        runTermOutput term $ mconcat [renderOutput tdisp msg]++summarySet :: Summary -> [OutputElem] -> IO ()+summarySet (Summary backend) output = do+    backend output++data Justify = JustifyLeft | JustifyRight++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+  where+    szS = length s+{-+data Attr = Attr+    { attrHasSize    :: Maybe Int+    , attrHasJustify :: Maybe Justify+    , attrHasColor   :: Maybe Color+    , attrHasBgColor :: Maybe Color+    , attrText       :: String+    }++instance Monoid Attr where+    mempty = Attr Nothing Nothing Nothing Nothing ""+    mappend a1 a2 =+        Attr { attrHasSize    = attrHasSize a2+             , attrHasJustify = attrHasJustify a2+             , attrHasColor   = attrHasColor a2+             , attrHasBgColor = attrHasBgColor a2+             , attrText       = attrText a1 ++ attrText a2+             }++attrColor :: Color -> Attr -> Attr+attrColor c a = a { attrHasColor = Just c }++attrSize :: Int -> Attr -> Attr+attrSize 0 a = a { attrHasSize = Nothing }+attrSize n a = a { attrHasSize = Just n }++attrJustify :: Justify -> Attr -> Attr+attrJustify j a = a { attrHasJustify = Just j }++text :: String -> Attr+text s = mempty { attrText = s }++toElem :: Attr -> [OutputElem]+toElem attr =+    let j = case attrHasSize attr of+            Just n ->+                case attrHasJustify attr of+                    Nothing           -> [LeftT n " "]+                    Just JustifyLeft  -> [LeftT n " "]+                    Just JustifyRight -> [RightT n " "]+            Nothing ->+                []+        fwc = case attrHasColor attr of+                    Nothing -> []+                    Just c  -> [Fg c]+        bgc = case attrHasBgColor attr of+                    Nothing -> []+                    Just c  -> [Bg c]+     in mconcat [j,fwc,bgc, [T $ attrText attr,NA]]+-}++-- column+data Column = Column+    { columnSize    :: Int+    , columnName    :: String+    , columnJustify :: Justify+    , columnWrap    :: Bool+    }++columnNew :: Int -> String -> Column+columnNew n name = Column n name JustifyLeft False++data Table = Table+    { tColumns     :: [Column]+    , rowSeparator :: String+    }++tableCreate :: [Column] -> Table+tableCreate cols = Table { tColumns = cols, rowSeparator = "" }++tableHeaders :: TerminalDisplay -> Table -> IO ()+tableHeaders td t =+    tableAppend td t $ map columnName $ tColumns t++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+  where+    printColRow Nothing =+        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+        display td [oe,T "\n"]

@@ -0,0 +1,357 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+module Console.Options+    (+    -- * Running+      defaultMain+    , defaultMainWith+    , parseOptions+    , OptionRes(..)+    , OptionDesc+    -- * Description+    , programName+    , programVersion+    , programDescription+    , command+    , FlagFrag(..)+    , flag+    , flagParam+    , flagMany+    , conflict+    , argument+    , remainingArguments+    , action+    , description+    , Action+    -- * Arguments+    , FlagParser(..)+    , Flag+    , FlagLevel+    , FlagParam+    , FlagMany+    , Arg+    , ArgRemaining+    , Params(..)+    , getParams+    ) where++import           Console.Options.Flags hiding (Flag, flagArg)+import qualified Console.Options.Flags as F+import           Console.Options.Nid+import           Console.Options.Utils+import           Console.Options.Monad+import           Console.Options.Types+import           Console.Display (justify, Justify(..))++import           Control.Applicative+import           Control.Monad+import           Control.Monad.IO.Class+import           Control.Monad.State+import           Control.Monad.Writer++import           Data.List+import           Data.Version+import           Data.Functor.Identity++import           System.Environment (getArgs, getProgName)+import           System.Exit++----------------------------------------------------------------------+setDescription :: String -> Command r -> Command r+setDescription desc  (Command hier _ opts act)    = Command hier desc opts act++setAction :: Action r -> Command r -> Command r+setAction act (Command hier desc opts _)   = Command hier desc opts (Just act)++addOption :: FlagDesc -> Command r -> Command r+addOption opt   (Command hier desc opts act) = Command hier desc (opt : opts) act++tweakOption :: Nid -> (FlagDesc -> FlagDesc) -> Command r -> Command r+tweakOption nid mapFlagDesc (Command hier desc opts act) =+    Command hier desc (modifyNid opts) act+  where+    modifyNid []           = []+    modifyNid (f:fs)+        | flagNid f == nid = mapFlagDesc f : fs+        | otherwise        = f : modifyNid fs++addArg :: Argument -> Command r -> Command r+addArg arg = modifyHier $ \hier ->+    case hier of+        CommandLeaf l  -> CommandLeaf (arg:l)+        CommandTree {} -> hier -- ignore argument in a hierarchy.+----------------------------------------------------------------------++data FlagParser a =+      FlagRequired (ValueParser a)+    | FlagOptional a (ValueParser a)++type ValueParser a = String -> Either String a++data OptionRes r =+      OptionSuccess Params (Action r)+    | OptionHelp+    | OptionError String -- user cmdline error in the arguments+    | OptionInvalid String -- API has been misused++defaultMain :: OptionDesc (IO ()) () -> IO ()+defaultMain dsl = getArgs >>= defaultMainWith dsl++defaultMainWith :: OptionDesc (IO ()) () -> [String] -> IO ()+defaultMainWith dsl args = do+    let (programDesc, res) = parseOptions dsl args+     in case res of+        OptionError s          -> putStrLn s >> exitFailure+        OptionHelp             -> help (stMeta programDesc) (stCT programDesc) >> exitSuccess+        OptionSuccess params r -> r (getParams params)+        OptionInvalid s        -> putStrLn s >> exitFailure++parseOptions :: OptionDesc r () -> [String] -> (ProgramDesc r, OptionRes r)+parseOptions dsl args =+    let descState = gatherDesc dsl+     in (descState, runOptions (stMeta descState) (stCT descState) args)++--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")+    tell "\n"+    maybe (return ()) (\d -> tell d >> tell "\n\n") (programMetaDescription pmeta)+    tell "Options:\n"+    tell "\n"+    mapM_ (tell . printOpt 0) commandOpts+    case hier of+        CommandTree subs -> do+            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+            tell "\n"+            mapM_ (printSub 0) subs+        CommandLeaf _    ->+            return ()+  where+    printSub iLevel (name, cmdOpt) = do+        tell ("\n" ++ name ++ " options:\n\n")+        mapM_ (tell . printOpt iLevel) (getCommandOptions cmdOpt)+        case getCommandHier cmdOpt of+            CommandTree _ -> do+                return ()+            CommandLeaf _ -> do+                return ()+        --tell . indent 2 ""++    printOpt iLevel fd =+        let optShort = maybe (replicate 2 ' ') (\c -> "-" ++ [c]) $ flagShort ff+            optLong  = maybe (replicate 8 ' ') (\s -> "--" ++ s) $ flagLong ff+            optDesc  = maybe "" ("  " ++) $ flagDescription ff+         in indent (iLevel + 2) $ intercalate " " [optShort, optLong, optDesc] ++ "\n"+      where+        ff = flagFragments fd++runOptions :: ProgramMeta+           -> Command r -- commands+           -> [String] -- arguments+           -> OptionRes r+runOptions pmeta ct allArgs+    | "--help" `elem` allArgs = OptionHelp+    | "-h" `elem` allArgs     = OptionHelp+    | otherwise               = go [] ct allArgs+  where+        -- parse recursively using a Command structure+        go :: [[F.Flag]] -> Command r -> [String] -> OptionRes r+        go parsedOpts (Command hier _ commandOpts act) unparsedArgs =+            case parseFlags commandOpts unparsedArgs of+                (opts, unparsed, [])  -> do+                    case hier of+                        -- if we have sub commands, then we pass the unparsed options+                        -- to their parsers+                        CommandTree subs -> do+                            case unparsed of+                                []     -> errorExpectingMode subs+                                (x:xs) -> case lookup x subs of+                                                Nothing      -> errorInvalidMode x subs+                                                Just subTree -> go (opts:parsedOpts) subTree xs+                        -- no more subcommand (or none to start with)+                        CommandLeaf unnamedArgs ->+                            case validateUnnamedArgs (reverse unnamedArgs) unparsed of+                                Left err   -> errorUnnamedArgument err+                                Right (pinnedArgs, remainingArgs) -> do+                                    let flags = concat (opts:parsedOpts)+                                    case act of+                                        Nothing -> OptionInvalid "no action defined"+                                        Just a  ->+                                            let params = Params flags+                                                                pinnedArgs+                                                                remainingArgs+                                             in OptionSuccess params a+                (_, _, ers) -> do+                    OptionError $ mconcat $ map showOptionError ers++        validateUnnamedArgs :: [Argument] -> [String] -> Either String ([String], [String])+        validateUnnamedArgs argOpts l =+            v [] argOpts >>= \(opts, _hasCatchall) -> do+                let unnamedRequired = length opts+                if length l < unnamedRequired+                    then Left "missing arguments"+                    else Right $ splitAt unnamedRequired l+          where+            v :: [Argument] -> [Argument] -> Either String ([Argument], Bool)+            v acc []                    = Right (reverse acc, False)+            v acc (a@(Argument {}):as)  = v (a:acc) as+            v acc ((ArgumentCatchAll {}):[]) = Right (reverse acc, True)+            v _   ((ArgumentCatchAll {}):_ ) = Left "arguments expected after remainingArguments"++        showOptionError (FlagError opt i s) = do+            let optName = (maybe "" (:[]) $ flagShort $ flagFragments opt) ++ " " ++ (maybe "" id $ flagLong $ flagFragments opt)+             in ("error: " ++ show i ++ " option " ++ optName ++ " : " ++ s ++ "\n")++        errorUnnamedArgument err =+            OptionError $ mconcat+                [ "error: " ++ err+                , ""+                ]++        errorExpectingMode subs =+            OptionError $ mconcat (+                [ "error: expecting one of the following mode:\n"+                , "\n"+                ] ++ map (indent 4 . (++ "\n") . fst) subs)+        errorInvalidMode got subs =+            OptionError $ mconcat (+                [ "error: invalid mode '" ++ got ++ "', expecting one of the following mode:\n"+                , ""+                ] ++ map (indent 4 . (++ "\n") . fst) subs)++indent :: Int -> String -> String+indent n s = replicate n ' ' ++ s++-- | Set the program name+programName :: String -> OptionDesc r ()+programName s = modify $ \st -> st { stMeta = (stMeta st) { programMetaName = Just s } }++-- | Set the program version+programVersion :: Version -> OptionDesc r ()+programVersion s = modify $ \st -> st { stMeta = (stMeta st) { programMetaVersion = Just $ showVersion s } }++-- | Set the program description+programDescription :: String -> OptionDesc r ()+programDescription s = modify $ \st -> st { stMeta = (stMeta st) { programMetaDescription = Just s } }++-- | Set the description for a command+description :: String -> OptionDesc r ()+description doc = modify $ \st -> st { stCT = setDescription doc (stCT st) }++modifyHier :: (CommandHier r -> CommandHier r) -> Command r -> Command r+modifyHier f (Command hier desc opts act) = Command (f hier) desc opts act++modifyCT :: (Command r -> Command r) -> OptionDesc r ()+modifyCT f = modify $ \st -> st { stCT = f (stCT st) }++-- | Create a new sub command+command :: String -> OptionDesc r () -> OptionDesc r ()+command name sub = do+    let subSt = gatherDesc sub+    modifyCT (addCommand (stCT subSt))+    --modify $ \st -> st { stCT = addCommand (stCT subSt) $ stCT st }+  where addCommand subTree = modifyHier $ \hier ->+            case hier of+                CommandLeaf _ -> CommandTree [(name,subTree)]+                CommandTree t -> CommandTree ((name, subTree) : t)++-- | Set the action to run in this command+action :: Action r -> OptionDesc r ()+action ioAct = modify $ \st -> st { stCT = setAction ioAct (stCT st) }++-- | Flag option either of the form -short or --long+--+-- for flag that doesn't have parameter, use 'flag'+flagParam :: FlagFrag -> FlagParser a -> OptionDesc r (FlagParam a)+flagParam frag fp = do+    nid <- getNextID++    let fragmentFlatten = flattenFragments frag++    let opt = FlagDesc+                { flagFragments   = fragmentFlatten+                , flagNid         = nid+                , F.flagArg       = argp+                , flagArgValidate = validator+                , flagArity       = 1+                }++    modify $ \st -> st { stCT = addOption opt (stCT st) }++    case mopt of+        Just a  -> return (FlagParamOpt nid a parser)+        Nothing -> return (FlagParam nid parser)+  where+    (argp, parser, mopt, validator) = case fp of+        FlagRequired p   -> (FlagArgHave, toArg p, Nothing, isValid p)+        FlagOptional a p -> (FlagArgMaybe, toArg p, Just a, isValid p)++    toArg :: (String -> Either String a) -> String -> a+    toArg p = either (error "internal error toArg") id . p++    isValid f = either FlagArgInvalid (const FlagArgValid) . f++flagMany :: OptionDesc r (FlagParam a) -> OptionDesc r (FlagMany a)+flagMany fp = do+    f <- fp+    let nid = case f of+                FlagParamOpt n _ _ -> n+                FlagParam n _      -> n+    modify $ \st -> st { stCT = tweakOption nid (\fd -> fd { flagArity = maxBound }) (stCT st) }+    return $ FlagMany f++-- | Flag option either of the form -short or --long+--+-- for flag that expect a value (optional or mandatory), uses 'flagArg'+flag :: FlagFrag -> OptionDesc r (Flag Bool)+flag frag = do+    nid <- getNextID++    let fragmentFlatten = flattenFragments frag++    let opt = FlagDesc+                { flagFragments   = fragmentFlatten+                , flagNid         = nid+                , F.flagArg       = FlagArgNone+                , flagArgValidate = error ""+                , flagArity       = 0+                }++    modify $ \st -> st { stCT = addOption opt (stCT st) }+    return (Flag nid)++-- | An unnamed 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.+argument :: String -> ValueParser a -> OptionDesc r (Arg a)+argument name fp = do+    idx <- getNextIndex+    let a = Argument { argumentName        = name+                     , argumentDescription = ""+                     , argumentValidate    = either Just (const Nothing) . fp+                     }+    modifyCT $ addArg a+    return (Arg idx (either (error "internal error") id . fp))++remainingArguments :: String -> OptionDesc r (ArgRemaining [String])+remainingArguments name = do+    let a = ArgumentCatchAll { argumentName        = name+                             , argumentDescription = ""+                             }+    modifyCT $ addArg a+    return ArgsRemaining++-- | 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

@@ -0,0 +1,146 @@+module Console.Options.Flags+    ( parseFlags+    , FlagDesc(..)+    , FlagFragments(..)+    , Flag+    , FlagArgValidation(..)+    , FlagArgDesc(..)+    , FlagError(..)+    -- * fragments+    , FlagFrag(FlagShort, FlagLong, FlagDescription)+    , flattenFragments+    ) where++import Control.Applicative+import Control.Monad+import Console.Options.Nid+import Data.List+import Data.Monoid++data FlagArgValidation = FlagArgValid | FlagArgInvalid String++-- | How to parse a specific flag+data FlagDesc = FlagDesc+    { flagFragments     :: FlagFragments+    , flagNid           :: Nid                    -- ^ flag number. internal value+    , flagArg           :: FlagArgDesc            -- ^ parser for the argument to an flag+    , flagArgValidate   :: String -> FlagArgValidation -- ^ if the argument doesn't validate, return the error message associated, otherwise Nothing+    , flagArity         :: Int+    }++data FlagFrag =+      FlagShort       Char+    | FlagLong        String+    | FlagDescription String+    -- | FlagDefault     String+    | FlagMany        [FlagFrag]+    deriving (Show,Eq)++data FlagFragments = FlagFragments+    { flagShort         :: Maybe Char             -- ^ short flag parser 'o'+    , flagLong          :: Maybe String           -- ^ long flag "flag"+    , flagDescription   :: Maybe String           -- ^ Description of this "flag"+    --, flagDefault       :: Maybe String           -- ^ Has a default+    }++flattenFragments :: FlagFrag -> FlagFragments+flattenFragments frags =+    foldl' flat startVal $ case frags of+                                FlagMany l -> l+                                _          -> [frags]+  where+    startVal = FlagFragments Nothing Nothing Nothing+    flat ff  (FlagShort f)       = ff { flagShort = Just f }+    flat ff  (FlagLong f)        = ff { flagLong = Just f }+    flat ff  (FlagDescription f) = ff { flagDescription = Just f }+    flat acc (FlagMany l)        = foldl' flat acc l++instance Monoid FlagFrag where+    mempty                              = FlagMany []+    mappend (FlagMany l1) (FlagMany l2) = FlagMany (l1 ++ l2)+    mappend (FlagMany l1) o             = FlagMany (l1 ++ [o])+    mappend o             (FlagMany l2) = FlagMany (o : l2)+    mappend o1            o2            = FlagMany [o1,o2]++-- | Whether a flag has an argument, an optional one or always an argument+data FlagArgDesc =+      FlagArgNone+    | FlagArgMaybe+    | FlagArgHave+    deriving (Show,Eq)++data Matching a = NoMatching | Matching a | MatchingWithArg a String++-- | the state of parsing the command line arguments+data ParseState a = ParseState [Flag]      -- Args : in reverse order+                               [String]    -- Unparsed: in reverse order+                               [FlagError] -- errors: in reverse order++type Flag = (Nid, Maybe String)++data FlagError = FlagError FlagDesc Int String++parseFlags :: [FlagDesc]+           -> [String]+           -> ([Flag], [String], [FlagError])+parseFlags flagParsers = loop (ParseState [] [] []) [1..]+  where+        loop :: ParseState a -> [Int] -> [String] -> ([Flag], [String], [FlagError])+        loop _                      []     _      = error "impossible case"+        loop (ParseState os us ers) _      []     = (reverse os, reverse us, reverse ers)+        loop (ParseState os us ers) (i:is) (a:as) =+            case a of+                '-':'-':[]   -> (reverse os, reverse us ++ as, reverse ers)+                '-':'-':long -> loop (processFlag (findLong long)) is as+                '-':short:[] -> loop (processFlag (findShort short)) is as+                _            -> loop (ParseState os (a:us) ers) is as+          where processFlag NoMatching     = ParseState os (a:us) ers+                processFlag (Matching opt) =+                    case flagArg opt of+                        FlagArgNone  -> ParseState ((flagNid opt, Nothing) : os) us ers+                        FlagArgMaybe -> ParseState ((flagNid opt, Nothing) : os) us ers+                        FlagArgHave  ->+                            case as of+                                []     -> let e = mkFlagError opt "required argument missing"+                                           in ParseState os (a:us) (e:ers)+                                (x:_) ->+                                    case (flagArgValidate opt) x of+                                        FlagArgValid          -> ParseState ((flagNid opt, Just x):os) us ers+                                        FlagArgInvalid optErr ->+                                            let e = mkFlagError opt ("invalid argument: " ++ optErr)+                                             in ParseState os us (e:ers)+                processFlag (MatchingWithArg opt arg) =+                    case flagArg opt of+                        FlagArgNone  -> let e = mkFlagError opt "invalid argument, expecting no argument" -- fixme: tell which flag+                                         in ParseState os (a:us) (e:ers)+                        FlagArgMaybe ->+                            case (flagArgValidate opt) arg of+                                FlagArgValid   -> ParseState ((flagNid opt, Just arg):os) us ers+                                FlagArgInvalid optErr ->+                                    let e = mkFlagError opt ("invalid argument: " ++ optErr)+                                     in ParseState os us (e:ers)+                        FlagArgHave  ->+                            case (flagArgValidate opt) arg of+                                FlagArgValid          -> ParseState ((flagNid opt, Just arg):os) us ers+                                FlagArgInvalid optErr ->+                                    let e = mkFlagError opt ("invalid argument: " ++ optErr)+                                     in ParseState os us (e:ers)++                mkFlagError opt s = FlagError opt i s++        findShort short = findRetArg (flagShortMatch short) flagParsers+        findLong long = findRetArg (flagLongMatch long) flagParsers++        flagShortMatch toMatch opt = maybe NoMatching (\x -> if x == toMatch then Matching opt else NoMatching) $ flagShort $ flagFragments opt+        flagLongMatch toMatch opt = maybe NoMatching match $ flagLong $ flagFragments opt+          where match optLong+                    | leftPart == optLong && null rightPart           = Matching opt+                    | leftPart == optLong && isPrefixOf "=" rightPart = MatchingWithArg opt (drop 1 rightPart)+                    | otherwise                                       = NoMatching+                  where (leftPart,rightPart) = splitAt (length optLong) toMatch++        findRetArg _ []         = NoMatching+        findRetArg f (opt:opts) =+            case f opt of+                NoMatching -> findRetArg f opts+                r          -> r

@@ -0,0 +1,66 @@+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE Rank2Types #-}+module Console.Options.Monad+    ( ProgramDesc(..)+    , ProgramMeta(..)+    , OptionDesc+    , gatherDesc+    , getNextID+    , getNextIndex+    ) where++import           Console.Options.Nid+import           Console.Options.Types+import           Console.Options.Utils+import           Control.Monad.State+import           Control.Monad.Identity+import           System.Exit++-- the current state of the program description+-- as the monad unfold ..+data ProgramDesc r = ProgramDesc+    { stMeta        :: ProgramMeta+    , stCT          :: Command r     -- the command with the return type of actions+    , stNextID      :: !NidGenerator -- next id for flag+    , stNextIndex   :: !UnnamedIndex -- next index for unnamed argument+    }++data ProgramMeta = ProgramMeta+    { programMetaName        :: Maybe String+    , programMetaDescription :: Maybe String+    , programMetaVersion     :: Maybe String+    , programMetaHelp        :: [String]+    }++programMetaDefault :: ProgramMeta+programMetaDefault = ProgramMeta Nothing Nothing Nothing ["-h", "--help"]++-- OptionDesc (return value of action) a+newtype OptionDesc r a = OptionDesc { runOptionDesc :: StateT (ProgramDesc r) Identity a }+    deriving (Functor,Applicative,Monad,MonadState (ProgramDesc r))++gatherDesc :: OptionDesc r a -> ProgramDesc r+gatherDesc dsl = runIdentity $ execStateT (runOptionDesc dsl) initialProgramDesc++initialProgramDesc :: ProgramDesc r+initialProgramDesc = ProgramDesc { stMeta        = programMetaDefault+                                 , stCT          = iniCommand+                                 , stNextID      = nidGenerator+                                 , stNextIndex   = 0+                                 }+  where+    iniCommand :: Command r+    iniCommand = Command (CommandLeaf []) "..." [] Nothing++-- | Return the next unique argument ID+getNextID :: OptionDesc r Nid+getNextID = do+    (nid, nidGen) <- nidNext . stNextID <$> get+    modify $ \st -> st { stNextID = nidGen }+    return nid++getNextIndex :: OptionDesc r UnnamedIndex+getNextIndex = do+    idx <- stNextIndex <$> get+    modify $ \st -> st { stNextIndex = idx + 1 }+    return idx

@@ -0,0 +1,21 @@+module Console.Options.Nid+    ( Nid+    , NidGenerator+    , nidGenerator+    , nidNext+    ) where++-- | A unique ID+newtype Nid = Nid Int+    deriving (Show,Eq,Ord)++-- | A unique ID generator+newtype NidGenerator = NidGenerator Int++-- | Create a new unique generator+nidGenerator :: NidGenerator+nidGenerator = NidGenerator 0++-- | get the next unique id and return a new generator+nidNext :: NidGenerator -> (Nid, NidGenerator)+nidNext (NidGenerator next) = (Nid next, NidGenerator (next+1))

@@ -0,0 +1,129 @@+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE Rank2Types #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE TypeFamilies #-}+module Console.Options.Types+    ( Argument(..)+    , Command(..)+    , CommandHier(..)+    , Action+    , UnnamedIndex+    -- * User Binders to retrieve their options+    , Flag(..)+    , FlagLevel(..)+    , FlagParam(..)+    , FlagMany(..)+    , Arg(..)+    , ArgRemaining(..)+    , Params(..)+    , Param+    , getParams+    ) where++import           Console.Options.Flags (FlagDesc)+import           Console.Options.Nid++-- | A unnamed argument+data Argument =+      Argument+        { argumentName        :: String+        , argumentDescription :: String+        , argumentValidate    :: String -> Maybe String+        }+    | ArgumentCatchAll+        { argumentName        :: String+        , argumentDescription :: String+        }++data Flag a where+    Flag       :: Nid -> Flag Bool++data FlagLevel a where+    FlagLevel  :: Nid -> FlagLevel Int++data FlagParam a where+    FlagParamOpt     :: Nid -> a -> (String -> a) -> FlagParam a+    FlagParam        :: Nid -> (String -> a) -> FlagParam a++newtype FlagMany a = FlagMany (FlagParam a)++data Arg a where+    Arg           :: UnnamedIndex -> (String -> a) -> Arg a++data ArgRemaining a where+    ArgsRemaining :: ArgRemaining [String]++type UnnamedIndex = Int++-- A command that is composed of a hierarchy+--+data Command r = Command+    { getCommandHier        :: CommandHier r+    , getCommandDescription :: String+    , getCommandOptions     :: [FlagDesc]+    , getCommandAction      :: Maybe (Action r)+    }++-- | Recursive command tree+data CommandHier r =+      CommandTree [(String, Command r)]+    | CommandLeaf [Argument]+++data Params = Params+    { paramsFlags         :: [(Nid, Maybe String)]+    , paramsPinnedArgs    :: [String]+    , paramsRemainingArgs :: [String]+    }++-- | Represent a program to run+type Action r = (forall a p . Param p => p a -> Ret p a) -> r -- flags++class Param p where+    type Ret p a :: *+    getParams :: Params -> (forall a . p a -> Ret p a)++{-+flag :: optional on command line+    | no value       -> Bool+param :: optional on command line but with a value+    | optional value -> Maybe a+    | required value -> Maybe a+arg :: required on command line+    | required value (itself) -> a+-}+instance Param Flag where+    type Ret Flag a = Bool+    getParams (Params flagArgs _ _) (Flag nid) =+        maybe False (const True) $ lookup nid flagArgs+instance Param FlagLevel where+    type Ret FlagLevel a = Int+    getParams (Params flagArgs _ _) (FlagLevel nid) =+        length $ filter ((== nid) . fst) flagArgs+instance Param FlagParam where+    type Ret FlagParam a = Maybe a+    getParams (Params flagArgs _ _) (FlagParamOpt nid a p) =+        case lookup nid flagArgs of+            Just (Just param) -> Just (p param)+            Just Nothing      -> Just a+            Nothing           -> Nothing+    getParams (Params flagArgs _ _) (FlagParam nid p) =+        case lookup nid flagArgs of+            Just Nothing      -> error "internal error: parameter is missing" -- something is wrong with the flag parser+            Just (Just param) -> Just (p param)+            Nothing           -> Nothing+instance Param FlagMany where+    type Ret FlagMany a = [a]+    getParams (Params flagArgs _ _) (FlagMany (FlagParamOpt nid a p)) =+        let margs = map snd $ filter ((== nid) . fst) flagArgs+         in map (maybe a p) margs+    getParams (Params flagArgs _ _) (FlagMany (FlagParam nid p)) =+        let margs = map snd $ filter ((== nid) . fst) flagArgs+         in map (maybe (error "") p) margs+instance Param Arg where+    type Ret Arg a = a+    getParams (Params _ unnamedArgs _) (Arg index p) =+        p (unnamedArgs !! index)+instance Param ArgRemaining where+    type Ret ArgRemaining a = [String]+    getParams (Params _ _ otherArgs) _ = otherArgs

@@ -0,0 +1,10 @@+module Console.Options.Utils+    ( hPutErrLn+    ) where++import           System.IO (hPutStrLn, stderr)++-- add implementation for windows+hPutErrLn :: String -> IO ()+hPutErrLn = hPutStrLn stderr+

@@ -1,4 +1,4 @@-Copyright (c) 2014 Nicolas DI PRIMA <nicolas@di-prima.fr>+Copyright (c) 2015-2016 Vincent Hanquez <vincent@snarc.org>  All rights reserved. 

@@ -1,6 +1,9 @@-# CLI+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)

@@ -1,46 +1,62 @@ Name:                cli-Version:             0.0.5-Synopsis:            Simple Command Line Interface Library-Description:-    This package provides a simple Command Line Library+Version:             0.1.0+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:           Nicolas DI PRIMA <nicolas@di-prima.fr>-Author:              Nicolas DI PRIMA <nicolas@di-prima.fr>-Maintainer:          Nicolas DI PRIMA <nicolas@di-prima.fr>-                     Vincent Hanquez <vincent@snarc.org>-Category:            Application+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/NicolasDP/hs-cli+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+ Library-  Exposed-modules:   Application.CLI-  Other-modules:     Application.CLI.Types-                   , Application.CLI.Class+  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-                   , containers+                   , transformers+                   , mtl+                   , terminfo   ghc-options:       -Wall -fwarn-tabs-  Default-Language:  Haskell2010+  default-language:  Haskell2010 -source-repository head-  type: git-  location: https://github.com/NicolasDP/hs-cli -Flag executable-    default: False+--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 -Executable Example-  Main-Is:           Main.hs-  hs-source-dirs:    example-  ghc-options:       -Wall -fno-warn-orphans -fno-warn-missing-signatures-  Default-Language:  Haskell2010-  if flag(executable)-    Build-depends:   base >= 4 && < 5-                   , cli+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-    buildable: True-  else-    buildable: False+                   , tasty+                   , tasty-quickcheck+                   , QuickCheck+                   , cli+  ghc-options:       -Wall -fno-warn-orphans -fno-warn-missing-signatures -fwarn-tabs -fno-warn-unused-imports

@@ -1,63 +0,0 @@--- |--- Module      : Main--- License     : BSD-Style--- Copyright   : Copyright © 2014 Nicolas DI PRIMA------ Maintainer  : Nicolas DI PRIMA <nicolas@di-prima.fr>--- Stability   : experimental--- Portability : unknown----module Main-    ( main-    ) where--import Application.CLI-import Control.Applicative-import Data.List-import System.Directory--data CLIls = CLIls FilePath-instance CLI CLIls where-    name _ = "ls"-    desc _ = "list file in the current directory"-    options _ = [ OptHelp ["-a", "--all"] Nothing "include hidden files"-                , OptHelp ["-s", "--separator"] (Just "string") "a separator to put between the found files (default is \" \")"-                , OptHelp [] (Just "directory") "specify a directory to list the content from"-                ]-    action (CLIls dir) _ =-        withOptionalParameterStr ["-s", "--separator"] $ \mseparator ->-        withFlag ["-a", "--all"] $ \withHidden ->-        withOptionalStr $ \mdir _ -> do-            let separator = maybe " " id mseparator-            list <- getDirectoryContents $ maybe dir id $ mdir-            if withHidden-                then putStrLn $ intercalate separator list-                else putStrLn $ intercalate separator $ filter (not . isHiddenFile) list-      where-        isHiddenFile :: FilePath -> Bool-        isHiddenFile [] = True-        isHiddenFile ('.':_) = True-        isHiddenFile _ = False--data CLIla = CLIla-instance CLI CLIla where-    name _ = "la"-    desc _ = "list file in the current directory -- plus hidden one"-    options _ = [ OptHelp [] (Just "directory") "the directory to list the content from (mandatory)"-                , OptHelp ["-p", "--prefix"] (Just "string") "a prefix to the output"-                ]-    action _ _ =-        withOptionalParameterStr ["-p", "--prefix"] $ \mprefix ->-        withStr "directory" $ \dir _ -> do-            let prefix = maybe "" id mprefix-            list <- filter (not . flip elem [ ".", ".." ]) <$> getDirectoryContents dir-            mapM_ putStrLn $ map ((++) prefix) list--main :: IO ()-main = do-    dir <- getCurrentDirectory-    defaultMain-        $ with Help-        $ with CLIla-        $ with (CLIls dir)-        $ initialize "Example of use of CLI Library"

@@ -0,0 +1,52 @@+module Main (main) where++import           Control.Applicative+import           Control.Monad++import           Test.Tasty+import           Test.Tasty.QuickCheck+import           Test.QuickCheck.Monadic++import           Storage.HashFS.Meta+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+    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 $ runIdentity $ do+        let (_,r) = f+         in case r of+                OptionSuccess p act -> return (sort values == sort (paramsFlags p)) --act (getParams p)+                _                   -> return False++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) ["bar", "-a", "option-a"]+        , testParseSuccess "2" [] $ parseOptions (commandBar >> commandFoo) ["foo", "a"]+        ]+    ]