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
data OptionStyle = Permuted | NonPermuted | NoOptions deriving Eq
class (Typeable cmd, FlagType flag) => Command cmd flag | cmd -> flag where
options :: cmd -> AttributeMap Key
options _ = EmptyMap
supercommand :: cmd -> Bool
supercommand _ = False
optionStyle :: cmd -> OptionStyle
optionStyle _ = Permuted
run :: cmd -> Folded flag -> [String] -> IO ()
run cmd _ _ = die $ "BUG: Command " ++ cmdname cmd ++ " not implemented."
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 = 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 ' ') ++ " "
commandNames :: Bool
-> [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)
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' :: (String -> IO ())
-> [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
dispatch :: [DispatchOpt] -> [CommandWrap] -> [String] -> IO ()
dispatch = dispatchOr die
dispatchOr :: (String -> IO ())
-> [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'
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