cli-0.0.3: Application/CLI.hs
-- |
-- 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 _ = [ ]
-- 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
-- * CLI
, CLI(..)
, OptHelp(..)
-- ** Default CLIs
, Help(..)
, printHelp
-- * Commands
, CLIContext
, getHeader
, 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
-- | 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 _ -> 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)
-------------------------------------------------------------------------------
-- 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