augur-2008.10.19: src/Setup.hs

-----------------------------------------------------------------------------
-- |
-- Module      :  Setup
-- Copyright   :  (c) David Himmelstrup 2006
-- License     :  BSD-like
--
-- Maintainer  :  lemmih@gmail.com
-- Stability   :  provisional
-- Portability :  portable
--
--
-----------------------------------------------------------------------------
module Setup
    ( parseArguments
    , emptyConfig
    ) where

import Data.List
import Data.Char
import System.Console.GetOpt
import System.Exit
import System.Environment

import Config

emptyConfig :: Config
emptyConfig = Config
              { confVerbose  = 1
              , confWGetPath = "wget"
              , confCurlPath = "curl"
              , confTidyPath = "tidy"
              , confDryRun   = False }


cmd_verbose :: OptDescr Flag
cmd_verbose = Option "v" ["verbose"] (OptArg verboseFlag "n")
              "Control verbosity (n is 0-5, normal verbosity level is 1, -v alone is equivalent to -v3)"
  where
    verboseFlag mb_s = Verbose (maybe 3 read mb_s)

cmd_dryrun :: OptDescr Flag
cmd_dryrun = Option "d" ["dry-run"] (OptArg dryrunFlag "bool")
              "Dry run. Accept values in the line of 'false', '0' and 'no'. Default: false."
  where
    dryrunFlag mb_s = DryRun (maybe True (parse.map toLower) mb_s)
    parse "false" = False
    parse "0" = False
    parse "no" = False
    parse _ = True

cmd_help :: OptDescr Flag
cmd_help = Option "h?" ["help"] (NoArg HelpFlag) "Show this help text"

globalOptions :: [OptDescr Flag]
globalOptions =
    [ cmd_help
    , cmd_verbose
    , cmd_dryrun
    , Option "w" ["wget-path"] (ReqArg WGetPath "path")
                 "Use this command as wget"
    , Option "t" ["tidy-path"] (ReqArg WGetPath "path")
                 "Use this command as tidy"
    ]

data Cmd = Cmd {
        cmdName         :: String,
        cmdHelp         :: String, -- Short description
        cmdDescription  :: String, -- Long description
        cmdOptions      :: [OptDescr Flag ],
        cmdAction       :: Action,
        cmdMerge        :: Flag -> Action -> Action
        }


commandList :: [Cmd]
commandList = [ parseCmd, renameCmd, informCmd, addCmd, removeCmd ]

parseCmd = Cmd
           { cmdName = "parse"
           , cmdHelp = "Test the parser"
           , cmdDescription = ""
           , cmdOptions = [Option "f" ["format"] (ReqArg ParseFormat "format")
                                      ("Output format. Default: "++defaultFormat)
                          ]
           , cmdAction = Parse defaultFormat
           , cmdMerge = \(ParseFormat fn) a -> a{parseFormat = fn}}
renameCmd = Cmd
            { cmdName = "rename"
            , cmdHelp = "Rename TV series"
            , cmdDescription = ""
            , cmdOptions = [Option "f" ["format"] (ReqArg ParseFormat "format")
                                      ("Output format. Default: "++defaultFormat)
                          ]
            , cmdAction = Rename defaultFormat
            , cmdMerge = \(ParseFormat fn) a -> a{parseFormat = fn}}
informCmd = Cmd
            { cmdName = "inform"
            , cmdHelp = "Gather meta information"
            , cmdDescription = ""
            , cmdOptions = [Option "f" ["from-file"] (ReqArg (FromFile . parse) "series@file")
                                       ("Fetch info from file.")]
            , cmdAction = Inform []
            , cmdMerge = \f a -> case f of
                                   FromFile f -> a{fromFiles = f:fromFiles a}}
    where parse str = let (s,f) = break (=='@') str in (s,drop 1 f)

addCmd = Cmd
         { cmdName = "add"
         , cmdHelp = "Add new series. Case matters."
         , cmdDescription = ""
         , cmdOptions = []
         , cmdAction = Add
         , cmdMerge = \_ -> id }
removeCmd = Cmd
         { cmdName = "remove"
         , cmdHelp = "Remove series."
         , cmdDescription = ""
         , cmdOptions = []
         , cmdAction = Remove
         , cmdMerge = \_ -> id }


lookupCommand :: String -> [Cmd] -> Maybe Cmd
lookupCommand name = find ((==name) . cmdName)


mkConfig :: Flag -> Config -> Config
mkConfig (Verbose n) conf = conf { confVerbose = n }
mkConfig (WGetPath wget) conf = conf { confWGetPath = wget }
mkConfig (TidyPath tidy) conf = conf { confTidyPath = tidy }
mkConfig (DryRun d) conf = conf { confDryRun = d }
mkConfig _ _ = error "Setup.mkConfig: Invalid flag"

hasHelpFlag :: [Flag] -> Bool
hasHelpFlag flags = not . null $ [ () | HelpFlag <- flags ]

printUsage :: IO ()
printUsage =
    do pname <- getProgName
       let syntax_line = concat [ "Usage: ", pname
                                , " [GLOBAL FLAGS]\n  or:  COMMAND [FLAGS] "
                                , "\n\nGlobal flags:"]
       putStrLn (usageInfo syntax_line globalOptions)
       putStrLn "Commands:"
       let maxlen = maximum [ length (cmdName cmd) | cmd <- commandList ]
       sequence_ [ do putStr "  "
                      putStr (align maxlen (cmdName cmd))
                      putStr "    "
                      putStrLn (cmdHelp cmd)
                   | cmd <- commandList ]
       putStrLn $ "\nFor more information about a command, try '" ++ pname ++ " COMMAND --help'."
  where align n str = str ++ replicate (n - length str) ' '

printCmdUsage :: Cmd -> IO ()
printCmdUsage cmd
    = do pname <- getProgName
         let syntax_line = "Usage: " ++ pname ++ " " ++ cmdName cmd ++ " [FLAGS]\n\nFlags for " ++ cmdName cmd ++ ":"
         putStrLn (usageInfo syntax_line (cmd_help:cmdOptions cmd))
         putStrLn (cmdDescription cmd)


parseArguments :: [String] -> IO (Action, [String], Config)
parseArguments args
    = case getOpt' RequireOrder globalOptions args of
        (flags, _, _, []) | hasHelpFlag flags ->
            do printUsage
               exitWith ExitSuccess
        (flags, cname:cargs, _, []) ->
            case lookupCommand cname commandList of
              Just cmd -> case getOpt' Permute (cmd_help:cmdOptions cmd) cargs of
                            (flags, _, _, []) | hasHelpFlag flags ->
                                do printCmdUsage cmd
                                   exitWith ExitSuccess
                            (cmdflags, args, _, []) -> 
                                do return ( foldr (cmdMerge cmd) (cmdAction cmd) cmdflags
                                          , args
                                          , foldr mkConfig emptyConfig flags)
              Nothing -> do putStrLn $ "Unrecognised command: " ++ cname
                            exitWith (ExitFailure 1)
        (_, [], _, []) ->
            do putStrLn $ "No command given (try --help)"
               exitWith (ExitFailure 1)
        (_, _, _, errs) ->
            do putStrLn "Errors:"
               mapM_ putStrLn errs
               exitWith (ExitFailure 1)