Types.hs

-- |
-- 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"