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 )
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 c = unwords $ cmdname c : opts where
opts = usageDescr $ attrFun (cmdattrs c %% flag_attrs)
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_defaults :: cmd -> (flag -> [Attribute]) -> Folded flag
cmd_flag_defaults _ attrs = flag_defaults attrs (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 ' ') ++ " "
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 (defaults, opts)
| otherwise = case errs' of
[] -> do checkFlags (flag_fold' 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 :: Folded f -> [f] -> IO ()
checkFlags providedFlags allFlags =
forM_ allFlags $ \f -> checkFlag f
where
checkFlag f =
(flag_eval f providedFlags
`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' :: Folded f = flag_fold' (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)
flag_fold' = flag_fold (undefined :: f)
defaults = cmd_flag_defaults cmd attrs
attrs :: f -> [Attribute]
attrs = attrFun (cmdattrs cmd %% 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] -> [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
| 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 ())
-> [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
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
[] -> printCommands comms >> die ("No such command '" ++ cmd ++ "'")
[CommandWrap comm] -> printHelp comm
x -> printCommands x >> die ("Ambiguous command '" ++ cmd ++ "'")