Command.hs

{-# LANGUAGE ScopedTypeVariables, GADTs, MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, UndecidableInstances, OverlappingInstances, DeriveDataTypeable,
             FlexibleContexts, TupleSections, Rank2Types, CPP #-}
module System.Console.CmdLib.Command where

import System.Console.CmdLib.Attribute
import System.Console.CmdLib.Flag
import System.Console.GetOpt
import Data.Typeable
import Data.Either ( partitionEithers )
import Data.List( sort, intercalate, isPrefixOf )
import Data.Char( toLower )
import Data.Maybe( fromJust, isNothing )
import Control.Monad( when, forM_ )
import Control.Exception ( evaluate, catch, SomeException )
import System.IO( hPutStrLn, stderr )
import System.Exit
import Prelude hiding ( catch )

-- | How to process options for a command. See "optionStyle" for details.
data OptionStyle = Permuted | NonPermuted | NoOptions deriving Eq

-- | A class that describes a single (sub)command. The @cmd@ type parameter is
-- just for dispatch (and the default command name is derived from this type's
-- name, but this can be overriden). It could be an empty data decl as far as
-- this library is concerned, although you may choose to store information in
-- it.
--
-- To parse the commandline for a given command, see "execute". The basic usage
-- can look something like this:
--
-- > data Flag = Summary | Unified Bool | LookForAdds Bool
-- > instance ADTFlag Flag
-- >
-- > [...]
-- >
-- > data Whatsnew = Whatsnew deriving Typeable
-- >
-- > instance Command Whatsnew (ADT Flag) where
-- >  options _ =  enable <% Summary +% Unified +% LookForAdds
-- >  summary _ = "Create a patch from unrecorded changes."
-- >
-- >  run _ f opts = do putStrLn $ "Record."
-- >                    putStrLn $ "Options: " ++ show f
-- >                    putStrLn $ "Non-options: " ++ show opts

class (Typeable cmd, FlagType flag) => Command cmd flag | cmd -> flag where
  -- | An "Attribute" mapping for flags provided by the @flag@ type parameter.
  options :: cmd -> AttributeMap Key
  options _ = EmptyMap

  -- | Set this to True if the command is a supercommand (i.e. expects another
  -- subcommand). Defaults to False. Supercommands can come with their own
  -- options, which need to appear between the supercommand and its
  -- subcommand. Any later options go to the subcommand. The "run" (and
  -- "description") method of a supercommand should use "dispatch" and
  -- "helpCommands" respectively (on its list of subcommands) itself.
  supercommand :: cmd -> Bool
  supercommand _ = False

  -- | How to process options for this command. "NoOptions" disables option
  -- processing completely and all arguments are passed in the [String]
  -- parameter to "run". "Permuted" collects everything that looks like an
  -- option (starts with a dash) and processes it. The non-option arguments are
  -- filtered and passed to run like above. Finally, "NonPermuted" only
  -- processes options until a first non-option argument is encountered. The
  -- remaining arguments are passed unchanged to run.
  optionStyle :: cmd -> OptionStyle
  optionStyle _ = Permuted

  -- | The handler that actually runs the command. Gets the @setup@ value as
  -- folded from the processed options (see "Combine") and a list of non-option
  -- arguments.
  run :: cmd -> Folded flag -> [String] -> IO ()
  run cmd _ _ = die $ "BUG: Command " ++ cmdname cmd ++ " not implemented."

  -- | Provides the commands' short synopsis.
  synopsis :: cmd -> String
  synopsis c = unwords $ cmdname c : opts where
    opts = usageDescr $ attrFun (cmdattrs c %% flag_attrs)

  -- | Provides a short (one-line) description of the command. Used in help
  -- output.
  summary :: cmd -> String
  summary _ = ""

  help :: cmd -> String
  help _ = ""

  -- | The name of the command. Normally derived automatically from @cmd@, but
  -- may be overriden.
  cmdname :: cmd -> String
  cmdname c = map toLower $ reverse . takeWhile (/= '.') . reverse . show $ typeOf c

  -- | A convenience "undefined" of the command, for use with "Commands".
  cmd :: cmd
  cmd = undefined

  cmd_flag_empty :: cmd -> Folded flag
  cmd_flag_empty _ = flag_empty (undefined :: flag)

cmdoptions :: (Command cmd flag) => cmd -> Key -> [Attribute]
cmdoptions = attrFun . options

cmdattrs :: forall cmd f . Command cmd f => cmd -> f -> [Attribute]
cmdattrs cmd = cmdoptions cmd . flag_attrkey

helpOptions :: forall cmd f. Command cmd f => cmd -> String
helpOptions cmd = unlines $ [ x | x <- [summary cmd, syn cmd, help cmd], not $ null x ] ++ opts
    where syn c | null (synopsis c) = ""
                | otherwise = "Usage: " ++ synopsis c
          opts | null opts' = []
               | otherwise = "" : map (uncurry usageInfo) opts'
          opts' = [ (grp ++ ":", getopt) |
                    (grp, getopt@(_:_)) <- helpDescr MergeSuffix $ attrFun (cmdattrs cmd %% flag_attrs) ]

helpCommands x = concatMap one x
  where one (CommandWrap c) = "    " ++ pad (cmdname c) ++ "  " ++ summary c ++ "\n"
        one (CommandGroup name l) = "\n" ++ name ++ ":\n" ++ helpCommands l
        pad str = take 15 (str ++ replicate 15 ' ') ++ " "

-- | This could be used to implement a disambiguation function
--
-- Note that there isn't presently a notion of hidden commands,
-- but we're taking them into account now for future API stability
commandNames :: Bool -- ^ show hidden commands too
             -> [CommandWrap] -> [String]
commandNames _ x = concatMap one x
  where one (CommandWrap c) = [cmdname c]
        one (CommandGroup _ cs) = concatMap one cs

execute' :: forall cmd f. (Command cmd f) => cmd -> [String] -> IO (Maybe (Folded f, [String]))
execute' cmd opts
  | "--help" `elem` opts && not (supercommand cmd) = printHelp cmd >> return Nothing
  | ("--help":_) <- opts = printHelp cmd >> return Nothing
  | NoOptions <- optionStyle cmd = return $ Just (foldr ($) (cmd_flag_empty cmd) defaults, opts)
  | otherwise = case errs' of
                     [] -> do checkFlags (flags ++ defaults)
                                [f | f <- flag_list,
                                     enabled $ attrs f,
                                     not $ nonoption attrs f]
                              sequence_ [ setglobal (attrs f) (flag_value f flags') | f <- flag_list ]
                              evaluate $ Just (flags', opts'filtered)
                     _ -> die (concat errs') >> return Nothing
  where getopts = optDescr attrs
        checkFlags providedFlags allFlags =
          forM_ allFlags $ \f -> checkFlag f fs
         where
            fs = foldr ($) (cmd_flag_empty cmd) providedFlags
            checkFlag f fs =
              (flag_eval f fs
              `catch`
              \(_ :: RequiredArgException) ->
                die $ "Missing required flag: " ++ flagDescr f)
              `catch`
              \(e :: SomeException) -> die $ "Malformed flag: " ++ show e

        order = if supercommand cmd || (optionStyle cmd == NonPermuted) then RequireOrder else Permute
        (flags, opts', errs) = getOpt order getopts opts
        flags' = foldr ($) (cmd_flag_empty cmd) (positions'' ++ extras ++ reverse flags ++ defaults)
        extras :: [Folded f -> Folded f]
        extras = [ if extra (attrs f) then flag_set f opts'filtered else id
                 | f :: f <- flag_list, enabled $ attrs f ]
        positions = [ (f, n, r) | f <- flag_list,
                                  enabled $ attrs f,
                                  Just n <- [positional $ attrs f],
                                  r <- [required $ attrs f] ]
        positions' = [ if length opts' > n
                         then Right $ flag_parse f (opts' !! n)
                         else Left (f, r)
                     | (f, n, r) <- positions ]
        (missingErrs, positions'') = filterRequiredMissing $
          partitionEithers positions'
        filterRequiredMissing (ls, rs) = (, rs) $ case filter snd ls of
          [] -> []
          rFlags -> let missingArgs = map (requiredFlagStr . fst) rFlags in
            [unwords $ "Missing required argument(s):" : missingArgs ]

        flagDescr f = let optDescr = head $ flagToOptDescr MergeSuffix attrs f
                          (ss', ls') = formatOptDescrOptions optDescr in
          intercalate "|" $ ss' ++ ls'

        errs' = errs ++ missingErrs
        opts'filtered = removemany opts'
          (reverse $ sort $ map (\(_,s,_) -> s) positions)
        removemany = foldl remove
        remove l n = let (a, b) = splitAt n l in (a ++ drop 1 b)
        defaults :: [Folded f -> Folded f]
        defaults = flag_defaults attrs
        attrs :: f -> [Attribute]
        attrs = attrFun (cmdattrs cmd %% flag_attrs)

-- | Parse options for and execute a single command (see "Command"). May be
-- useful for programs that do not need command-based "dispatch", but still
-- make use of the "Command" class to describe themselves. Handles @--help@
-- internally. You can use this as the entrypoint if your application is
-- non-modal (i.e. it has no subcommands).
execute :: forall cmd f. (Command cmd f) => cmd -> [String] -> IO ()
execute cmd opts = execute' cmd opts >>= \f -> case f of
  Just (flags, opts') -> run cmd flags opts'
  Nothing -> return ()

class Commands a where
  toCommands :: a -> [CommandWrap]

data CommandWrap where
  CommandWrap :: (Command a f, Typeable (Folded f)) => a -> CommandWrap
  CommandGroup :: String -> [CommandWrap] -> CommandWrap

instance Commands CommandWrap where
  toCommands = (:[])

instance Commands [CommandWrap] where
  toCommands = id

instance (Command c f, Typeable (Folded f)) => Commands c where
  toCommands c = [CommandWrap c]

-- | Chain commands into a list suitable for "dispatch" and "helpCommands". E.g.:
--
-- > dispatch (Command1 %: Command2 %: Command3) opts
(%:) :: (Commands a, Commands b) => a -> b -> [CommandWrap]
a %: b = toCommands a ++ toCommands b

commandGroup :: (Commands a) => String -> a -> [CommandWrap]
commandGroup s l = [CommandGroup s (toCommands l)]

#if !MIN_VERSION_base(4,3,0)
instance Monad (Either e) where
        return = Right
        Left  l >>= _ = Left l
        Right r >>= k = k r    
#endif

-- TODO: disambiguation, hidden commands (aliases)
findCommand :: String -> [CommandWrap] -> [CommandWrap]
findCommand key list = case accum list of Left x -> [x]
                                          Right x -> x
  where accum (c@(CommandWrap cmd):comms)
          | key == cmdname cmd = Left c -- short-circuit an exact match
          | key `isPrefixOf` cmdname cmd = (c:) `fmap` accum comms
          | otherwise = accum comms
        accum (CommandGroup _ comms:comms')
          | Right c <- accum comms = (c++) `fmap` accum comms'
          | Left x <- accum comms = Left x
          | otherwise = accum comms'
        accum [] = return []

printHelp c = putStr $ helpOptions c
printCommands comms = putStr $ helpCommands comms

dispatch' :: (String -> IO ()) -- ^ fail
          -> [DispatchOpt] -> [CommandWrap] -> [String] -> IO (Maybe (CommandWrap, [String]))
dispatch' diefn dopt comms' args = case args of
  [] | isNothing def -> dieHelp "Command required."
     | otherwise -> return $ Just (fromJust def, [])
  ("--help":x) -> dispatch' diefn dopt comms' ("help":x)
  (cmd:args') -> case findCommand cmd comms of
    [] -> case def of
      Nothing -> dieHelp $ "No such command '" ++ cmd ++ "'"
      Just x -> return $ Just (x, args)
    [x] -> return $ Just (x, args')
    disamb -> dieAmb cmd disamb >> return Nothing
  where comms | null [ () | NoHelp <- dopt ] = HelpCommand comms %: comms'
              | otherwise = comms'
        dieHelp msg = printCommands comms >> diefn msg >> return Nothing
        dieAmb cmd matches =
          do putStrLn $ "The following commands match your request:"
             printCommands matches
             diefn $ "Ambiguous command '" ++ cmd ++ "'"
        def | (DefaultCommand n:_) <- [ o | o@(DefaultCommand _) <- dopt ] = Just n
            | otherwise = Nothing

data DispatchOpt = NoHelp | DefaultCommand CommandWrap
noHelp = NoHelp
defaultCommand :: (Command f x, Typeable (Folded x)) => f -> DispatchOpt
defaultCommand = DefaultCommand . CommandWrap

-- | Given a list of commands (see @"%:"@) and a list of commandline arguments,
-- dispatch on the command name, parse the commandline options (see "execute")
-- and transfer control to the command.  This function also implements the
-- @help@ pseudocommand.
dispatch :: [DispatchOpt] -> [CommandWrap] -> [String] -> IO ()
dispatch = dispatchOr die

-- | Like 'dispatch' but with the ability to control what happens when there
--   is an error on user input
dispatchOr :: (String -> IO ()) -- ^ eg. 'die'
           -> [DispatchOpt] -> [CommandWrap] -> [String] -> IO ()
dispatchOr die dopt comms opts = dispatch' die dopt comms opts >>= \c -> case c of
  Nothing -> return ()
  Just (CommandWrap c, opts') -> execute c opts'


-- | Helper for dying with an error message (nicely, at least compared to
-- "fail" in IO).
die :: String -> IO a
die msg = do hPutStrLn stderr ("FATAL: " ++ trim msg)
             exitWith (ExitFailure 1)
             return (error "unreachable")
  where trim msg | last msg == '\n' = trim $ init msg
                 | otherwise = msg

data HelpCommand = HelpCommand [CommandWrap] deriving Typeable

instance Command HelpCommand () where
  cmdname   _ = "help"
  synopsis  _ = "help [command]"
  summary   _ = "show help for a command or commands overview"
  run (HelpCommand comms) _ args = case args of
    [] -> printCommands comms
    (cmd:_) -> case findCommand cmd comms of
      [] -> printCommands comms >> die ("No such command '" ++ cmd ++ "'")
      [CommandWrap comm] -> printHelp comm
      x -> printCommands x >> die ("Ambiguous command '" ++ cmd ++ "'")