diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,3 +1,7 @@ +# 0.2.0 + +- Verbosity support + # 0.1.0 - First release diff --git a/example/simple.hs b/example/simple.hs --- a/example/simple.hs +++ b/example/simple.hs @@ -1,12 +1,13 @@ {-# LANGUAGE DataKinds #-} +import Control.Monad.Trans import Options.Declarative greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String) -> Arg "NAME" String - -> Cmd "greet" -greet msg name = Cmd $ do - putStrLn $ get msg ++ ", " ++ get name ++ "!" + -> Cmd "greet" () +greet msg name = do + liftIO $ putStrLn $ get msg ++ ", " ++ get name ++ "!" main :: IO () main = run_ greet diff --git a/example/subcmd.hs b/example/subcmd.hs --- a/example/subcmd.hs +++ b/example/subcmd.hs @@ -1,30 +1,31 @@ {-# LANGUAGE DataKinds #-} +import Control.Monad.Trans import Options.Declarative greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String) -> Flag "" '["decolate"] "" "decolate message" Bool -> Arg "NAME" String - -> Cmd "Greeting command" -greet msg deco name = Cmd $ do + -> Cmd "Greeting command" () +greet msg deco name = do let f x | get deco = "*** " ++ x ++ " ***" | otherwise = x - putStrLn $ f $ get msg ++ ", " ++ get name ++ "!" + liftIO $ putStrLn $ f $ get msg ++ ", " ++ get name ++ "!" connect :: Flag "h" '["host"] "HOST" "host name" (Def "localhost" String) -> Flag "p" '["port"] "PORT" "port number" (Def "8080" Int ) - -> Cmd "Connect command" -connect host port = Cmd $ do + -> Cmd "Connect command" () +connect host port = do let addr = get host ++ ":" ++ show (get port) - putStrLn $ "connect to " ++ addr + liftIO $ putStrLn $ "connect to " ++ addr getOptExample :: Flag "o" '["output"] "FILE" "output FILE" (Def "stdout" String) -> Flag "c" '[] "FILE" "input FILE" (Def "stdin" String) -> Flag "L" '["libdir"] "DIR" "library directory" String - -> Cmd "GetOpt example" -getOptExample output input libdir = Cmd $ - print (get output, get input, get libdir) + -> Cmd "GetOpt example" () +getOptExample output input libdir = + liftIO $ print (get output, get input, get libdir) main :: IO () main = run_ $ diff --git a/example/verbose.hs b/example/verbose.hs new file mode 100644 --- /dev/null +++ b/example/verbose.hs @@ -0,0 +1,16 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +import Control.Monad.Logger +import Options.Declarative + +test :: Cmd "verbosity test" () +test = do + $logDebug "this is debug level" + $logInfo "this is info level" + $logWarn "this is warn level" + $logError "this is error level" + +main :: IO () +main = run_ test diff --git a/optparse-declarative.cabal b/optparse-declarative.cabal --- a/optparse-declarative.cabal +++ b/optparse-declarative.cabal @@ -1,5 +1,5 @@ name: optparse-declarative -version: 0.1.0 +version: 0.2.0 synopsis: Declarative command line option parser description: Declarative and easy to use command line option parser homepage: https://github.com/tanakh/optparse-declarative @@ -14,17 +14,18 @@ extra-source-files: README.md ChangeLog.md - example/simple.hs - example/subcmd.hs + example/*.hs source-repository head type: git location: https://github.com/tanakh/optparse-declarative.git library - exposed-modules: Options.Declarative - -- other-modules: - -- other-extensions: - build-depends: base >=4.7 && <5 hs-source-dirs: src + exposed-modules: Options.Declarative default-language: Haskell2010 + build-depends: base >=4.7 && <5 + , mtl + , monad-logger + , bytestring + , fast-logger diff --git a/src/Options/Declarative.hs b/src/Options/Declarative.hs --- a/src/Options/Declarative.hs +++ b/src/Options/Declarative.hs @@ -1,314 +1,337 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DefaultSignatures #-} -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE PolyKinds #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE Trustworthy #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} - --- | Declarative options parser - -module Options.Declarative ( - -- * Command type - Cmd(..), - IsCmd, - - -- * Argument definition tools - Option(..), - Flag, - Arg, - - -- * Defining argment types - ArgRead(..), - Def, - - -- * Subcommands support - Group(..), - SubCmd, subCmd, - - -- * Run a command - run, run_, - ) where - -import Control.Applicative -import Control.Monad -import Data.List -import Data.Maybe -import Data.Proxy -import GHC.TypeLits -import System.Console.GetOpt -import System.Environment -import System.Exit -import System.IO -import Text.Read - --- argument types - -class Option a where - type Value a :: * - get :: a -> Value a - -newtype Flag (shortNames :: Symbol ) - (longNames :: [Symbol]) - (placeholder :: Symbol ) - (help :: Symbol ) - a - = Flag { getFlag :: a } - -newtype Arg (placeholder :: Symbol) a = Arg { getArg :: a } - -instance ArgRead a => Option (Flag _a _b _c _d a) where - type Value (Flag _a _b _c _d a) = Unwrap a - get = unwrap . getFlag - -instance Option (Arg _a a) where - type Value (Arg _a a) = a - get = getArg - -class ArgRead a where - type Unwrap a :: * - type Unwrap a = a - - unwrap :: a -> Unwrap a - default unwrap :: a ~ Unwrap a => a -> Unwrap a - unwrap = id - - argRead :: Maybe String -> Maybe a - default argRead :: Read a => Maybe String -> Maybe a - argRead s = readMaybe =<< s - - needArg :: Proxy a -> Bool - needArg _ = True - -instance ArgRead Int - -instance ArgRead Integer - -instance ArgRead Double - -instance ArgRead String where - argRead = id - -instance ArgRead Bool where - argRead Nothing = Just False - argRead (Just "t") = Just True - argRead _ = Nothing - - needArg _ = False - -instance ArgRead a => ArgRead (Maybe a) where - argRead Nothing = Just Nothing - argRead (Just a) = Just <$> argRead (Just a) - -newtype Def (defaultValue :: Symbol) a = - Def { getDef :: a } - -instance (KnownSymbol defaultValue, ArgRead a) => ArgRead (Def defaultValue a) where - type Unwrap (Def defaultValue a) = Unwrap a - unwrap = unwrap . getDef - - argRead s = - let s' = fromMaybe (symbolVal (Proxy :: Proxy defaultValue)) s - in Def <$> argRead (Just s') - --- command types - -newtype Cmd (help :: Symbol) = Cmd (IO ()) - -data Group - = Group - { groupHelp :: String - , groupCmds :: [SubCmd] - } - -data SubCmd = forall c. IsCmd c => SubCmd String c - -class IsCmd c where - getCmdHelp :: c -> String - default getCmdHelp :: (c ~ (a -> b), IsCmd b) => c -> String - getCmdHelp f = getCmdHelp $ f undefined - - getOptDescr :: c -> [OptDescr (String, String)] - default getOptDescr :: (c ~ (a -> b), IsCmd b) => c -> [OptDescr (String, String)] - getOptDescr f = getOptDescr $ f undefined - - getUsageHeader :: c -> String -> String - default getUsageHeader :: (c ~ (a -> b), IsCmd b) => c -> String -> String - getUsageHeader f = getUsageHeader $ f undefined - - getUsageFooter :: c -> String -> String - default getUsageFooter :: (c ~ (a -> b), IsCmd b) => c -> String -> String - getUsageFooter f = getUsageFooter $ f undefined - - runCmd :: c - -> [String] -- ^ Command name - -> Maybe String -- ^ Version - -> [(String, String)] -- ^ Options - -> [String] -- ^ Non options - -> [String] -- ^ Unrecognized options - -> IO () - -class KnownSymbols (s :: [Symbol]) where - symbolVals :: Proxy s -> [String] - -instance KnownSymbols '[] where - symbolVals _ = [] - -instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where - symbolVals _ = symbolVal (Proxy :: Proxy s) : symbolVals (Proxy :: Proxy ss) - -instance ( KnownSymbol shortNames - , KnownSymbols longNames - , KnownSymbol placeholder - , KnownSymbol help - , ArgRead a - , IsCmd c ) - => IsCmd (Flag shortNames longNames placeholder help a -> c) where - getOptDescr f = - let flagname = head $ - symbolVals (Proxy :: Proxy longNames) ++ - [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ] - in Option - (symbolVal (Proxy :: Proxy shortNames)) - (symbolVals (Proxy :: Proxy longNames)) - (if needArg (Proxy :: Proxy a) - then ReqArg - (flagname, ) - (symbolVal (Proxy :: Proxy placeholder)) - else NoArg - (flagname, "t")) - (symbolVal (Proxy :: Proxy help)) - : getOptDescr (f undefined) - - runCmd f name mbver options nonOptions unrecognized = - let flagname = head $ - symbolVals (Proxy :: Proxy longNames) ++ - [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ] - mbs = lookup flagname options - in case (argRead mbs, mbs) of - (Nothing, Nothing) -> - errorExit name $ "flag must be specified: --" ++ flagname - (Nothing, Just s) -> - errorExit name $ "bad argument: --" ++ flagname ++ "=" ++ s - (Just arg, _) -> - runCmd (f $ Flag arg) name mbver options nonOptions unrecognized - -instance ( KnownSymbol placeholder, IsCmd c ) - => IsCmd (Arg placeholder String -> c) where - getUsageHeader f prog = - " " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog - - runCmd f name mbver options nonOptions unrecognized = - case nonOptions of - [] -> errorExit name "not enough arguments" - (opt: rest) -> - case argRead (Just opt) of - Nothing -> - errorExit name $ "bad argument: " ++ opt - Just arg -> - runCmd (f $ Arg arg) name mbver options rest unrecognized - -instance ( KnownSymbol placeholder, IsCmd c ) - => IsCmd (Arg placeholder [String] -> c) where - getUsageHeader f prog = - " " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog - - runCmd f name mbver options nonOptions unrecognized = - runCmd (f $ Arg nonOptions) name mbver options [] unrecognized - -instance KnownSymbol help => IsCmd (Cmd help) where - getCmdHelp _ = symbolVal (Proxy :: Proxy help) - getOptDescr _ = [] - - getUsageHeader _ _ = "" - getUsageFooter _ _ = "" - - runCmd (Cmd m) name _ options nonOptions unrecognized = - case (options, nonOptions, unrecognized) of - (_, [], []) -> m - _ -> do - forM_ nonOptions $ \o -> - errorExit name $ "unrecognized argument '" ++ o ++ "'" - forM_ unrecognized $ \o -> - errorExit name $ "unrecognized option '" ++ o ++ "'" - exitFailure - -instance IsCmd Group where - getCmdHelp = groupHelp - getOptDescr _ = [] - - getUsageHeader _ _ = " [ARGS...]" - getUsageFooter g _ = unlines $ - [ "" - , "Commands: " - ] ++ - [ " " ++ name ++ replicate (12 - length name) ' ' ++ getCmdHelp c - | SubCmd name c <- groupCmds g - ] - - runCmd g name mbver _options (cmd: nonOptions) unrecognized = - case [ SubCmd subname c | SubCmd subname c <- groupCmds g, subname == cmd ] of - [SubCmd subname c] -> - run' c (name ++ [subname]) mbver (nonOptions ++ unrecognized) - _ -> - errorExit name $ "unrecognized command: " ++ cmd - runCmd _ name _ _ _ _ = - errorExit name "no command given" - -subCmd :: IsCmd c => String -> c -> SubCmd -subCmd = SubCmd - --- runner - -run' :: IsCmd c => c -> [String] -> Maybe String -> [String] -> IO () -run' cmd name mbver args = do - let optDescr = - getOptDescr cmd - ++ [ Option "?" ["help"] (NoArg ("help", "t")) "display this help and exit" ] - ++ [ Option "V" ["version"] (NoArg ("version", "t")) "output version information and exit" - | isJust mbver ] - - prog = unwords name - vermsg = prog ++ maybe "" (" version " ++) mbver - usage = - -- prog ++ ": " ++ getCmdHelp cmd ++ "\n\n" ++ - usageInfo ("Usage: " ++ prog ++ " [OPTION...]" ++ getUsageHeader cmd prog ++ "\nOptions:") optDescr ++ - getUsageFooter cmd prog - - case getOpt' RequireOrder optDescr args of - (options, nonOptions, unrecognized, errors) - | not $ null errors -> - errorExit name $ intercalate ", " errors - | isJust (lookup "help" options) -> do - putStr usage - exitSuccess - | isJust (lookup "version" options) -> do - putStrLn vermsg - exitSuccess - | otherwise -> - runCmd cmd name mbver options nonOptions unrecognized - --- | Run a command with specifying program name and version -run :: IsCmd c => String -> Maybe String -> c -> IO () -run progName progVer cmd = - run' cmd [progName] progVer =<< getArgs - --- | Run a command -run_ :: IsCmd c => c -> IO () -run_ cmd = do - progName <- getProgName - run progName Nothing cmd - -errorExit :: [String] -> String -> IO () -errorExit name msg = do - let prog = unwords name - hPutStrLn stderr $ prog ++ ": " ++ msg - hPutStrLn stderr $ "Try '" ++ prog ++ " --help' for more information." - exitFailure +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DefaultSignatures #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | Declarative options parser + +module Options.Declarative ( + -- * Command type + Cmd, + IsCmd, + + -- * Argument definition tools + Option(..), + Flag, + Arg, + + -- * Defining argment types + ArgRead(..), + Def, + + -- * Subcommands support + Group(..), + SubCmd, subCmd, + + -- * Run a command + run, run_, + ) where + +import Control.Applicative +import Control.Monad +import Control.Monad.Logger +import Control.Monad.Trans +import qualified Data.ByteString.Char8 as S +import Data.List +import Data.Maybe +import Data.Proxy +import GHC.TypeLits +import System.Console.GetOpt +import System.Environment +import System.Exit +import System.IO +import System.Log.FastLogger +import Text.Read + +-- argument types + +class Option a where + type Value a :: * + get :: a -> Value a + +newtype Flag (shortNames :: Symbol ) + (longNames :: [Symbol]) + (placeholder :: Symbol ) + (help :: Symbol ) + a + = Flag { getFlag :: a } + +newtype Arg (placeholder :: Symbol) a = Arg { getArg :: a } + +instance ArgRead a => Option (Flag _a _b _c _d a) where + type Value (Flag _a _b _c _d a) = Unwrap a + get = unwrap . getFlag + +instance Option (Arg _a a) where + type Value (Arg _a a) = a + get = getArg + +class ArgRead a where + type Unwrap a :: * + type Unwrap a = a + + unwrap :: a -> Unwrap a + default unwrap :: a ~ Unwrap a => a -> Unwrap a + unwrap = id + + argRead :: Maybe String -> Maybe a + default argRead :: Read a => Maybe String -> Maybe a + argRead s = readMaybe =<< s + + needArg :: Proxy a -> Bool + needArg _ = True + +instance ArgRead Int + +instance ArgRead Integer + +instance ArgRead Double + +instance ArgRead String where + argRead = id + +instance ArgRead Bool where + argRead Nothing = Just False + argRead (Just "t") = Just True + argRead _ = Nothing + + needArg _ = False + +instance ArgRead a => ArgRead (Maybe a) where + argRead Nothing = Just Nothing + argRead (Just a) = Just <$> argRead (Just a) + +newtype Def (defaultValue :: Symbol) a = + Def { getDef :: a } + +instance (KnownSymbol defaultValue, ArgRead a) => ArgRead (Def defaultValue a) where + type Unwrap (Def defaultValue a) = Unwrap a + unwrap = unwrap . getDef + + argRead s = + let s' = fromMaybe (symbolVal (Proxy :: Proxy defaultValue)) s + in Def <$> argRead (Just s') + +-- command types + +newtype Cmd (help :: Symbol) a = + Cmd { unCmd :: LoggingT IO a } + deriving (Functor, Applicative, Monad, MonadIO, MonadLogger, MonadLoggerIO) + +cmdLogger :: Int -> Loc -> LogSource -> LogLevel -> LogStr -> IO () +cmdLogger verbosityLevel _loc _src level msg = do + let minLevel = + [ LevelError + , LevelWarn + , LevelInfo + , LevelDebug + ] !! verbosityLevel + when (level >= minLevel) $ + S.putStrLn $ fromLogStr msg + +data Group = + Group + { groupHelp :: String + , groupCmds :: [SubCmd] + } + +data SubCmd = forall c. IsCmd c => SubCmd String c + +class IsCmd c where + getCmdHelp :: c -> String + default getCmdHelp :: (c ~ (a -> b), IsCmd b) => c -> String + getCmdHelp f = getCmdHelp $ f undefined + + getOptDescr :: c -> [OptDescr (String, String)] + default getOptDescr :: (c ~ (a -> b), IsCmd b) => c -> [OptDescr (String, String)] + getOptDescr f = getOptDescr $ f undefined + + getUsageHeader :: c -> String -> String + default getUsageHeader :: (c ~ (a -> b), IsCmd b) => c -> String -> String + getUsageHeader f = getUsageHeader $ f undefined + + getUsageFooter :: c -> String -> String + default getUsageFooter :: (c ~ (a -> b), IsCmd b) => c -> String -> String + getUsageFooter f = getUsageFooter $ f undefined + + runCmd :: c + -> [String] -- ^ Command name + -> Maybe String -- ^ Version + -> [(String, String)] -- ^ Options + -> [String] -- ^ Non options + -> [String] -- ^ Unrecognized options + -> IO () + +class KnownSymbols (s :: [Symbol]) where + symbolVals :: Proxy s -> [String] + +instance KnownSymbols '[] where + symbolVals _ = [] + +instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where + symbolVals _ = symbolVal (Proxy :: Proxy s) : symbolVals (Proxy :: Proxy ss) + +instance ( KnownSymbol shortNames + , KnownSymbols longNames + , KnownSymbol placeholder + , KnownSymbol help + , ArgRead a + , IsCmd c ) + => IsCmd (Flag shortNames longNames placeholder help a -> c) where + getOptDescr f = + let flagname = head $ + symbolVals (Proxy :: Proxy longNames) ++ + [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ] + in Option + (symbolVal (Proxy :: Proxy shortNames)) + (symbolVals (Proxy :: Proxy longNames)) + (if needArg (Proxy :: Proxy a) + then ReqArg + (flagname, ) + (symbolVal (Proxy :: Proxy placeholder)) + else NoArg + (flagname, "t")) + (symbolVal (Proxy :: Proxy help)) + : getOptDescr (f undefined) + + runCmd f name mbver options nonOptions unrecognized = + let flagname = head $ + symbolVals (Proxy :: Proxy longNames) ++ + [ [c] | c <- symbolVal (Proxy :: Proxy shortNames) ] + mbs = lookup flagname options + in case (argRead mbs, mbs) of + (Nothing, Nothing) -> + errorExit name $ "flag must be specified: --" ++ flagname + (Nothing, Just s) -> + errorExit name $ "bad argument: --" ++ flagname ++ "=" ++ s + (Just arg, _) -> + runCmd (f $ Flag arg) name mbver options nonOptions unrecognized + +instance ( KnownSymbol placeholder, IsCmd c ) + => IsCmd (Arg placeholder String -> c) where + getUsageHeader f prog = + " " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog + + runCmd f name mbver options nonOptions unrecognized = + case nonOptions of + [] -> errorExit name "not enough arguments" + (opt: rest) -> + case argRead (Just opt) of + Nothing -> + errorExit name $ "bad argument: " ++ opt + Just arg -> + runCmd (f $ Arg arg) name mbver options rest unrecognized + +instance ( KnownSymbol placeholder, IsCmd c ) + => IsCmd (Arg placeholder [String] -> c) where + getUsageHeader f prog = + " " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog + + runCmd f name mbver options nonOptions unrecognized = + runCmd (f $ Arg nonOptions) name mbver options [] unrecognized + +instance KnownSymbol help => IsCmd (Cmd help ()) where + getCmdHelp _ = symbolVal (Proxy :: Proxy help) + getOptDescr _ = [] + + getUsageHeader _ _ = "" + getUsageFooter _ _ = "" + + runCmd (Cmd m) name _ options nonOptions unrecognized = + case (options, nonOptions, unrecognized) of + (_, [], []) -> do + let verbosityLevel = fromMaybe 0 $ do + s <- lookup "verbose" options + if null s then return 1 else readMaybe s + runLoggingT m $ cmdLogger verbosityLevel + + _ -> do + forM_ nonOptions $ \o -> + errorExit name $ "unrecognized argument '" ++ o ++ "'" + forM_ unrecognized $ \o -> + errorExit name $ "unrecognized option '" ++ o ++ "'" + exitFailure + +instance IsCmd Group where + getCmdHelp = groupHelp + getOptDescr _ = [] + + getUsageHeader _ _ = " [ARGS...]" + getUsageFooter g _ = unlines $ + [ "" + , "Commands: " + ] ++ + [ " " ++ name ++ replicate (12 - length name) ' ' ++ getCmdHelp c + | SubCmd name c <- groupCmds g + ] + + runCmd g name mbver _options (cmd: nonOptions) unrecognized = + case [ SubCmd subname c | SubCmd subname c <- groupCmds g, subname == cmd ] of + [SubCmd subname c] -> + run' c (name ++ [subname]) mbver (nonOptions ++ unrecognized) + _ -> + errorExit name $ "unrecognized command: " ++ cmd + runCmd _ name _ _ _ _ = + errorExit name "no command given" + +subCmd :: IsCmd c => String -> c -> SubCmd +subCmd = SubCmd + +-- runner + +run' :: IsCmd c => c -> [String] -> Maybe String -> [String] -> IO () +run' cmd name mbver args = do + let optDescr = + getOptDescr cmd + ++ [ Option "?" ["help"] (NoArg ("help", "t")) "display this help and exit" ] + ++ [ Option "V" ["version"] (NoArg ("version", "t")) "output version information and exit" + | isJust mbver ] + ++ [ Option "v" ["verbose"] (OptArg (\arg -> ("verbose", fromMaybe "" arg)) "n") "set verbosity level" ] + + prog = unwords name + vermsg = prog ++ maybe "" (" version " ++) mbver + usage = + -- prog ++ ": " ++ getCmdHelp cmd ++ "\n\n" ++ + usageInfo ("Usage: " ++ prog ++ " [OPTION...]" ++ getUsageHeader cmd prog ++ "\nOptions:") optDescr ++ + getUsageFooter cmd prog + + case getOpt' RequireOrder optDescr args of + (options, nonOptions, unrecognized, errors) + | not $ null errors -> + errorExit name $ intercalate ", " errors + | isJust (lookup "help" options) -> do + putStr usage + exitSuccess + | isJust (lookup "version" options) -> do + putStrLn vermsg + exitSuccess + | otherwise -> + runCmd cmd name mbver options nonOptions unrecognized + +-- | Run a command with specifying program name and version +run :: IsCmd c => String -> Maybe String -> c -> IO () +run progName progVer cmd = + run' cmd [progName] progVer =<< getArgs + +-- | Run a command +run_ :: IsCmd c => c -> IO () +run_ cmd = do + progName <- getProgName + run progName Nothing cmd + +errorExit :: [String] -> String -> IO () +errorExit name msg = do + let prog = unwords name + hPutStrLn stderr $ prog ++ ": " ++ msg + hPutStrLn stderr $ "Try '" ++ prog ++ " --help' for more information." + exitFailure