Command.hs

{-# LANGUAGE ScopedTypeVariables, GADTs, MultiParamTypeClasses, FunctionalDependencies,
             FlexibleInstances, UndecidableInstances, OverlappingInstances, DeriveDataTypeable,
             FlexibleContexts #-}
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.List( sort )
import Data.Char( toLower )
import Data.Maybe( fromJust, isNothing )
import Control.Monad( when )
import System.IO( hPutStrLn, stderr )
import System.Exit

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

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

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 cmd_attrs :: f -> [Attribute]
          cmd_attrs = cmdoptions cmd . flag_attrkey
          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 (cmd_attrs %% flag_attrs) ]

helpCommands x = concat $ map 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 = do case errs of
                     [] -> do sequence_ [ setglobal (attrs f) (flag_value f flags') | f <- flag_list ]
                              return $ Just (flags', opts'filtered)
                     _ -> die (concat errs) >> return Nothing
  where getopts = optDescr attrs
        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) | f <- flag_list, enabled $ attrs f, Just n <- [positional $ attrs f] ]
        positions' = [ if (length opts' > n) then flag_parse f (opts' !! n) else id
                     | (f, n) <- positions ]
        opts'filtered = removemany opts' (reverse $ sort $ map snd positions)
        removemany l (n:ns) = removemany (remove l n) ns
        removemany l [] = l
        remove l n = let (a, b) = splitAt n l in (a ++ drop 1 b)
        defaults :: [Folded f -> Folded f]
        defaults = flag_defaults attrs
        cmd_attrs :: f -> [Attribute]
        cmd_attrs = cmdoptions cmd . flag_attrkey
        attrs :: f -> [Attribute]
        attrs = attrFun (cmd_attrs %% 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)]

-- TODO: disambiguation, hidden commands (aliases)
findCommand :: String -> [CommandWrap] -> Maybe CommandWrap
findCommand key (c@(CommandWrap cmd):comms) | key == cmdname cmd = Just c
                                             | otherwise = findCommand key comms
findCommand key (CommandGroup _ comms:comms')
  | Just c <- findCommand key comms = Just c
  | otherwise = findCommand key comms'
findCommand _ [] = Nothing

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
    Nothing -> case def of
      Nothing -> dieHelp $ "No such command " ++ cmd
      Just x -> return $ Just (x, args)
    Just x -> return $ Just (x, args')
  where comms | null [ () | NoHelp <- dopt ] = HelpCommand comms %: comms'
              | otherwise = comms'
        dieHelp msg = printCommands comms >> diefn msg >> return Nothing
        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
      Nothing -> printCommands comms >> die ("No such command " ++ cmd)
      Just (CommandWrap comm) -> printHelp comm