diff --git a/Application/CLI.hs b/Application/CLI.hs deleted file mode 100644 --- a/Application/CLI.hs +++ /dev/null @@ -1,252 +0,0 @@ --- | --- Module : Application.CLI --- License : BSD-Style --- Copyright : Copyright © 2014 Nicolas DI PRIMA --- --- Maintainer : Nicolas DI PRIMA --- 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 ++ " " - (_ , _:[]) -> 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 diff --git a/Application/CLI/Class.hs b/Application/CLI/Class.hs deleted file mode 100644 --- a/Application/CLI/Class.hs +++ /dev/null @@ -1,53 +0,0 @@ --- | --- Module : Application.CLI.Class --- License : BSD-Style --- Copyright : Copyright © 2014 Nicolas DI PRIMA --- --- Maintainer : Nicolas DI PRIMA --- 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 - } diff --git a/Application/CLI/Types.hs b/Application/CLI/Types.hs deleted file mode 100644 --- a/Application/CLI/Types.hs +++ /dev/null @@ -1,226 +0,0 @@ --- | --- Module : Application.CLI.Types --- License : BSD-Style --- Copyright : Copyright © 2014 Nicolas DI PRIMA --- --- Maintainer : Nicolas DI PRIMA --- 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" diff --git a/Console/Display.hs b/Console/Display.hs new file mode 100644 --- /dev/null +++ b/Console/Display.hs @@ -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"] diff --git a/Console/Options.hs b/Console/Options.hs new file mode 100644 --- /dev/null +++ b/Console/Options.hs @@ -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 "" id (programMetaName pmeta) ++ " version " ++ maybe "" 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 diff --git a/Console/Options/Flags.hs b/Console/Options/Flags.hs new file mode 100644 --- /dev/null +++ b/Console/Options/Flags.hs @@ -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 diff --git a/Console/Options/Monad.hs b/Console/Options/Monad.hs new file mode 100644 --- /dev/null +++ b/Console/Options/Monad.hs @@ -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 diff --git a/Console/Options/Nid.hs b/Console/Options/Nid.hs new file mode 100644 --- /dev/null +++ b/Console/Options/Nid.hs @@ -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)) diff --git a/Console/Options/Types.hs b/Console/Options/Types.hs new file mode 100644 --- /dev/null +++ b/Console/Options/Types.hs @@ -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 diff --git a/Console/Options/Utils.hs b/Console/Options/Utils.hs new file mode 100644 --- /dev/null +++ b/Console/Options/Utils.hs @@ -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 + diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2014 Nicolas DI PRIMA +Copyright (c) 2015-2016 Vincent Hanquez All rights reserved. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -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) diff --git a/cli.cabal b/cli.cabal --- a/cli.cabal +++ b/cli.cabal @@ -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 -Author: Nicolas DI PRIMA -Maintainer: Nicolas DI PRIMA - Vincent Hanquez -Category: Application +Copyright: Vincent Hanquez , Nicolas Di Prima +Author: Vincent Hanquez , Nicolas Di Prima +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 diff --git a/example/Main.hs b/example/Main.hs deleted file mode 100644 --- a/example/Main.hs +++ /dev/null @@ -1,63 +0,0 @@ --- | --- Module : Main --- License : BSD-Style --- Copyright : Copyright © 2014 Nicolas DI PRIMA --- --- Maintainer : Nicolas DI PRIMA --- 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" diff --git a/tests/Cli.hs b/tests/Cli.hs new file mode 100644 --- /dev/null +++ b/tests/Cli.hs @@ -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"] + ] + ]