cli-0.0.1: 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
--
module Application.CLI
    ( -- * Default Main
      defaultMain

      -- * CLI
    , CLI(..)
    , OptHelp(..)
      -- ** Default CLIs
    , Usage
    , printUsage

    , Help(..)
    , printHelp

      -- * Commands
    , CLIContext
    , getHeader
    , getDefault
    , initialize
    , with
    ) where

import Application.CLI.Class
import Application.CLI.Types
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

data Help = Help
instance CLI Help where
    name    _  = "help"
    desc    _  = "show help message"
    options _  = []
    action  _ ctx _ = do
        progName <- getProgName
        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
initialize :: CLI cliDefault
           => Maybe cliDefault -- ^ The command to execute if no option is given
           -> String           -- ^ CLI Description
           -> CLIContext
initialize defaultCli description =
    case defaultCli of
        Nothing  -> cmdMap
        Just cmd -> insertDefault (cliToCommand cmd) cmdMap
  where
    cmdMap :: CLIContext
    cmdMap = createContext (cliToCommand Usage) description

-------------------------------------------------------------------------------
--                             Default Main                                  --
-------------------------------------------------------------------------------

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