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 Control.Monad( when )
import System.IO( hPutStrLn, stderr )
import System.Exit
class (Typeable cmd, FlagType flag) => Command cmd flag | cmd -> flag where
options :: cmd -> AttributeMap Key
options _ = EmptyMap
supercommand :: cmd -> Bool
supercommand _ = False
run :: cmd -> Folded flag -> [String] -> IO ()
synopsis :: cmd -> String
synopsis _ = ""
summary :: cmd -> String
summary _ = ""
help :: cmd -> String
help _ = ""
cmdname :: cmd -> String
cmdname c = map toLower $ reverse . takeWhile (/= '.') . reverse . show $ typeOf c
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 = unlines $ map one x
where one (CommandWrap c) = " " ++ pad (cmdname c) ++ " " ++ summary c
one (CommandGroup name l) = name ++ ":\n" ++ helpCommands l
pad str = (take 15 $ str ++ replicate 15 ' ') ++ " "
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
| 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 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_set 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)
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]
(%:) :: (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)]
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' :: [CommandWrap] -> [String] -> IO (Maybe (CommandWrap, [String]))
dispatch' comms [] = printCommands comms >> die "Command required." >> return Nothing
dispatch' comms ["help"] = printCommands comms >> return Nothing
dispatch' comms ("help":cmd:_) =
case findCommand cmd comms of
Nothing -> printCommands comms >> die ("No such command " ++ cmd) >> return Nothing
Just (CommandWrap comm) -> printHelp comm >> return Nothing
dispatch' comms (cmd:opts) =
case findCommand cmd comms of
Nothing -> printCommands comms >> die ("No such command " ++ cmd) >> return Nothing
Just x -> return $ Just (x, opts)
dispatch :: [CommandWrap] -> [String] -> IO ()
dispatch comms opts = dispatch' comms opts >>= \c -> case c of
Nothing -> return ()
Just (CommandWrap c, opts') -> execute c opts'
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 deriving Typeable
instance Command HelpCommand () where
cmdname _ = "help"
synopsis _ = "help [command]"
summary _ = "show help for a command or commands overview"
run _ _ _ = die "BUG: Help should never run!"