Commands.hs

module Commands 
    ( Command
    , CommandName
    , Help
    , CommandSpec (..)
    , module System.Console.GetOpt
    , defaultMain
    , usage
    )
where
import Text.PrettyPrint(renderStyle,render,nest,vcat,hsep,style
                       ,Mode(..),mode,text,(<>),($$),($+$),(<+>))
import System.Console.GetOpt
import System.Environment (getArgs)
import System.IO (stderr)
import System.IO.UTF8 (hPutStr)
import qualified Data.List as List


type Command opts = (opts -> [String] -> IO ())
type CommandName = String
type Help        = String
data CommandSpec opts =  CommandSpec (Command opts)
                                  Help     
                                  [OptDescr (opts -> opts)]
                                  [String]

defaultMain :: opts -> [(String, CommandSpec opts)] -> String -> IO ()
defaultMain def commands header = do
  args <- getArgs
  let theUsage = usage commands header
  case args of
    []           -> theUsage []
    command:opts -> case List.lookup command commands of
                      Nothing   -> theUsage  ["Invalid command: " ++ command]
                      Just spec -> runCommand theUsage def spec opts

runCommand :: ([String] -> IO ()) 
           -> opts 
           -> CommandSpec opts 
           -> [String] 
           -> IO ()
runCommand theUsage def (CommandSpec command help optDesc argnames) args = 
    case getOpt Permute optDesc args of
      (o,n,[]  ) ->  command (foldr ($) def o) n
      (_,_,errs) -> theUsage errs

usage :: [(String, CommandSpec t)] -> String -> [String] -> IO ()
usage commands header errs = hPutStr stderr . render 
                             $  vcat (List.map text errs)
                             $$ usageMsg commands header

usageMsg commands header = 
        text header
    $+$ (vcat (List.map commandUsage commands))

commandUsage (name , CommandSpec command help optionDesc args) = 
    text name <> text ":"
    $$ (nest 10 (text help))
    $$ (text name <+> text (if null optionDesc then "" else "[OPTION...]")
                  <+> hsep (map text args))
    <+>  (nest 10 (text $ usageInfo "" optionDesc))