module Application.CLI.Types
(
CLIContext
, Command(..)
, OptHelp(..)
, Options
, createContext
, getHeader
, getHelper
, insertDefault
, getDefault
, insertCommand
, lookupCommand
, printUsage
, printHelp
, printOptHelp
, printCommandHelp
) where
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as M
data CLIContext = CLIContext
{ getCommands :: Map String Command
, getDefault :: Maybe Command
, getHeader :: String
, getHelper :: Command
} deriving (Show, Eq)
createContext :: Command
-> String
-> CLIContext
createContext helper header =
CLIContext
{ getCommands = M.empty
, getDefault = Nothing
, getHelper = helper
, getHeader = header
}
insertCommand :: Command
-> CLIContext
-> CLIContext
insertCommand cmd cmdMap = cmdMap { getCommands = M.insert (cmdName cmd) cmd (getCommands cmdMap) }
insertDefault :: Command
-> CLIContext
-> CLIContext
insertDefault cmd cmdMap =
insertCommand cmd $cmdMap { getDefault = Just cmd }
lookupCommand :: String
-> CLIContext
-> Maybe (Command)
lookupCommand k cmdMap = M.lookup k (getCommands cmdMap)
type Options = [String]
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) ++ " }"
printCommandHelp :: String
-> Command
-> String
printCommandHelp prefix cmd =
prefix ++ cmdName cmd ++ ": " ++ cmdDesc cmd ++ "\n"
++ (foldr (\c acc -> prefix ++ prefix ++ (printOptHelp c) ++ "\n" ++ acc) "" (cmdOptions cmd))
data OptHelp = OptHelp
{
optSymbols :: [String]
,
optArgument :: Maybe String
, optDescription :: String
} deriving (Eq, Show)
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 ++ "> "
printHelp :: String
-> String
-> CLIContext
-> String
printHelp prefix name cmdMap =
(defaultUsage prefix name $ getDefault cmdMap)
++ "\n"
++ (listCommands prefix cmdMap)
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
printUsage :: String
-> String
-> CLIContext
-> String
printUsage prefix name cmdMap =
(defaultUsage prefix name $ getDefault cmdMap)
++ "\n"
++ (listDescriptions prefix cmdMap)
defaultUsage :: String
-> String
-> Maybe (Command)
-> String
defaultUsage _ _ Nothing = ""
defaultUsage prefix name (Just cmd) =
prefix ++ "Usage: " ++ name ++ " [" ++ (cmdName cmd) ++ "]\n"
listDescriptions :: String
-> CLIContext
-> String
listDescriptions prefix cmdMap =
"Available commands:\n"
++ (foldr (\c acc -> "\n" ++ (commandDescription listPrefix c) ++ acc) "" (M.elems $ getCommands cmdMap))
where
listPrefix :: String
listPrefix = prefix
commandDescription :: String
-> Command
-> String
commandDescription prefix cmd =
prefix ++ cmdName cmd ++ ": " ++ cmdDesc cmd ++ "\n"