diff --git a/Application/CLI.hs b/Application/CLI.hs --- a/Application/CLI.hs +++ b/Application/CLI.hs @@ -7,6 +7,33 @@ -- 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 _ = [ ] +-- action _ _ opts = mapM_ putStrLn opts +-- @ +-- +-- 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 @@ -21,14 +48,22 @@ -- * Commands , CLIContext , getHeader - , getDefault , initialize , initializeWithDefault , with + + -- * Options + , Options + , withStr + , withOptionalStr + , withParameterStr + , withOptionalParameterStr + , withFlag ) where import Application.CLI.Class import Application.CLI.Types +import Data.List import System.Environment import System.Exit @@ -50,16 +85,34 @@ 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 _ = [] - action _ ctx _ = do - progName <- getProgName - putStrLn $ progName ++ ": " ++ getHeader ctx - putStrLn $ printHelp " " progName ctx + options _ = [ OptHelp [] (Just "command") "print the help message for a specific command" + ] + action _ ctx = + withOptionalStr $ \mcommand _ -> 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 -- ------------------------------------------------------------------------------- @@ -79,8 +132,7 @@ initializeWithDefault defaultCli description = insertDefault (cliToCommand defaultCli) cmdMap where - cmdMap :: CLIContext - cmdMap = createContext (cliToCommand Usage) description + cmdMap = initialize description -- | Initialize a collection of command initialize :: String -- ^ CLI Description @@ -89,9 +141,77 @@ 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) + +------------------------------------------------------------------------------- -- 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 diff --git a/Application/CLI/Class.hs b/Application/CLI/Class.hs --- a/Application/CLI/Class.hs +++ b/Application/CLI/Class.hs @@ -14,18 +14,33 @@ 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 - -> [String] + -> 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 diff --git a/Application/CLI/Types.hs b/Application/CLI/Types.hs --- a/Application/CLI/Types.hs +++ b/Application/CLI/Types.hs @@ -12,6 +12,7 @@ CLIContext , Command(..) , OptHelp(..) + , Options -- * Commands -- ** Getter/Setter @@ -28,6 +29,7 @@ , printUsage , printHelp , printOptHelp + , printCommandHelp ) where import Data.Map.Strict (Map) @@ -37,15 +39,21 @@ -- 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 - , getHeader :: String - , getHelper :: 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 helper command +createContext :: Command -- ^ the command helper (example: the Usage) -> String -- ^ a description about the program -> CLIContext createContext helper header = @@ -56,26 +64,49 @@ , getHeader = header } -insertCommand :: Command -> CLIContext -> CLIContext +-- | 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) } -insertDefault :: Command -> CLIContext -> CLIContext +-- | 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 } -lookupCommand :: String -> CLIContext -> Maybe Command +-- | 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 -> [String] -> IO () + , cmdAction :: CLIContext -> Options -> IO () } instance Eq Command where @@ -91,24 +122,33 @@ ++ "desc: " ++ (cmdDesc c) ++ ", " ++ "opts: " ++ (show $ cmdOptions c) ++ " }" +-- | Pretty print a command printCommandHelp :: String -- ^ indentation - -> Command + -> Command -- ^ the command to pretty print -> String printCommandHelp prefix cmd = prefix ++ cmdName cmd ++ ": " ++ cmdDesc cmd ++ "\n" - ++ (foldr (\c acc -> "\n" ++ prefix ++ prefix ++ (printOptHelp c) ++ acc) "" (cmdOptions cmd)) + ++ (foldr (\c acc -> prefix ++ prefix ++ (printOptHelp c) ++ "\n" ++ acc) "" (cmdOptions cmd)) ------------------------------------------------------------------------------- -- Option helps -- ------------------------------------------------------------------------------- +-- | Option help +-- +-- It describes the Command parameters data OptHelp = OptHelp - { optSymbols :: [String] - , optArgument :: Maybe String - , optDescription :: String + { -- | 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) -printOptHelp :: OptHelp -> String +-- | This function is a helper to print an OptHelp +printOptHelp :: OptHelp + -> String printOptHelp opthelp = (printSymbols $ optSymbols opthelp) ++ (printArgument $ optArgument opthelp) @@ -117,16 +157,17 @@ printSymbols :: [String] -> String printSymbols [] = "" printSymbols [x] = x ++ " " - printSymbols (x:xs) = x ++ printSymbols xs + printSymbols (x:xs) = x ++ ", " ++ printSymbols xs printArgument :: Maybe String -> String printArgument Nothing = "" - printArgument (Just a) = "<" ++ a ++ ">" + printArgument (Just x) = "<" ++ x ++ "> " ------------------------------------------------------------------------------- -- Pretty printers -- ------------------------------------------------------------------------------- +-- | Print all the Command's Option help printHelp :: String -- ^ indentation -> String -- ^ program name -> CLIContext -- ^ command list @@ -136,6 +177,7 @@ ++ "\n" ++ (listCommands prefix cmdMap) +-- | Print the all the commands helps listCommands :: String -> CLIContext -> String @@ -156,16 +198,18 @@ ++ "\n" ++ (listDescriptions prefix cmdMap) +-- | Print the defaul usage (if any) defaultUsage :: String -- ^ prefix -> String -- ^ program name - -> Maybe Command + -> Maybe (Command) -> String defaultUsage _ _ Nothing = "" defaultUsage prefix name (Just cmd) = prefix ++ "Usage: " ++ name ++ " [" ++ (cmdName cmd) ++ "]\n" -listDescriptions :: String -- ^ prefix - -> CLIContext +-- | 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" @@ -174,6 +218,7 @@ listPrefix :: String listPrefix = prefix +-- | print a command's description commandDescription :: String -> Command -> String diff --git a/cli.cabal b/cli.cabal --- a/cli.cabal +++ b/cli.cabal @@ -1,5 +1,5 @@ Name: cli -Version: 0.0.2 +Version: 0.0.3 Synopsis: Simple Command Line Interface Library Description: This package provides a simple Command Line Library @@ -29,6 +29,7 @@ location: https://github.com/NicolasDP/hs-cli Flag executable + default: False Executable Example Main-Is: Main.hs @@ -38,3 +39,7 @@ if flag(executable) Build-depends: base >= 4 && < 5 , cli + , directory + buildable: True + else + buildable: False diff --git a/example/Main.hs b/example/Main.hs --- a/example/Main.hs +++ b/example/Main.hs @@ -12,9 +12,52 @@ ) 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 = +main = do + dir <- getCurrentDirectory defaultMain $ with Help + $ with CLIla + $ with (CLIls dir) $ initialize "Example of use of CLI Library"