packages feed

optparse-declarative 0.2.0 → 0.3.0

raw patch · 7 files changed

+435/−410 lines, 7 filesdep −bytestringdep −fast-loggerdep −monad-logger

Dependencies removed: bytestring, fast-logger, monad-logger

Files

ChangeLog.md view
@@ -1,3 +1,9 @@+# 0.3.0
+
+- Simplify API
+- Support -vv -vvv verbosity
+- Improve help message
+
 # 0.2.0
 
 - Verbosity support
README.md view
@@ -25,9 +25,9 @@ ```hs 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 "Greeting command" ()+greet msg name =+    liftIO $ putStrLn $ get msg ++ ", " ++ get name ++ "!" ```  There are two type of options, `Flag` and `Arg`.@@ -40,10 +40,9 @@ you can use `get` function.  The whole type of command is `Cmd`.-`Cmd <description>` is basically newtype of `IO ()`,-except this contains extra information.+`Cmd` is an instance of `MonadIO` and it has some extra information. -When you define the command, there remains only invoking the command.+After defining a command, you just invoke it by `run_`.  ```hs main :: IO ()@@ -95,18 +94,18 @@ 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 ```  And this is the output:
example/simple.hs view
@@ -1,13 +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 = do-    liftIO $ putStrLn $ get msg ++ ", " ++ get name ++ "!"--main :: IO ()-main = run_ greet+{-# LANGUAGE DataKinds #-}
+
+import           Control.Monad.Trans
+import           Options.Declarative
+
+greet :: Flag "g" '["greet"] "STRING" "greeting message" (Def "Hello" String)
+      -> Arg "NAME" String
+      -> Cmd "Simple greeting example" ()
+greet msg name =
+    liftIO $ putStrLn $ get msg ++ ", " ++ get name ++ "!"
+
+main :: IO ()
+main = run_ greet
example/subcmd.hs view
@@ -1,36 +1,36 @@-{-# 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 = do-    let f x | get deco = "*** " ++ x ++ " ***"-            | otherwise = x-    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 = do-    let addr = get host ++ ":" ++ show (get port)-    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 =-    liftIO $ print (get output, get input, get libdir)--main :: IO ()-main = run_ $-    Group "Test program for library"-    [ subCmd "greet"   greet-    , subCmd "connect" connect-    , subCmd "getopt"  getOptExample-    ]+{-# 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 = do
+    let f x | get deco = "*** " ++ x ++ " ***"
+            | otherwise = x
+    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 = do
+    let addr = get host ++ ":" ++ show (get port)
+    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 =
+    liftIO $ print (get output, get input, get libdir)
+
+main :: IO ()
+main = run_ $
+    Group "Test program for sub commands"
+    [ subCmd "greet"   greet
+    , subCmd "connect" connect
+    , subCmd "getopt"  getOptExample
+    ]
example/verbose.hs view
@@ -1,16 +1,13 @@-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE DataKinds #-}
 
-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"
+    logStr 0 "verbosity level 0"
+    logStr 1 "verbosity level 1"
+    logStr 2 "verbosity level 2"
+    logStr 3 "verbosity level 3"
 
 main :: IO ()
 main = run_ test
optparse-declarative.cabal view
@@ -1,5 +1,5 @@ name:                optparse-declarative
-version:             0.2.0
+version:             0.3.0
 synopsis:            Declarative command line option parser
 description:         Declarative and easy to use command line option parser
 homepage:            https://github.com/tanakh/optparse-declarative
@@ -26,6 +26,3 @@   default-language:    Haskell2010
   build-depends:       base >=4.7 && <5
                      , mtl
-                     , monad-logger
-                     , bytestring
-                     , fast-logger
src/Options/Declarative.hs view
@@ -1,337 +1,363 @@-{-# 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 _ _ = " <COMMAND> [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+{-# LANGUAGE DataKinds                  #-}
+{-# LANGUAGE DefaultSignatures          #-}
+{-# LANGUAGE ExistentialQuantification  #-}
+{-# LANGUAGE FlexibleContexts           #-}
+{-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE KindSignatures             #-}
+{-# LANGUAGE MultiWayIf                 #-}
+{-# LANGUAGE PolyKinds                  #-}
+{-# LANGUAGE RankNTypes                 #-}
+{-# LANGUAGE ScopedTypeVariables        #-}
+{-# LANGUAGE TupleSections              #-}
+{-# LANGUAGE TypeFamilies               #-}
+{-# LANGUAGE TypeOperators              #-}
+
+-- | Declarative options parser
+
+module Options.Declarative (
+    -- * Command type
+    IsCmd,
+    Cmd,
+    logStr,
+    getVerbosity,
+    getLogger,
+
+    -- * 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.Reader
+import           Control.Monad.Trans
+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
+
+-- | Command line option
+class Option a where
+    -- | Type of the argument' value
+    type Value a :: *
+    -- | Get the argument' value
+    get :: a -> Value a
+
+-- | Named argument
+newtype Flag (shortNames  :: Symbol  )
+             (longNames   :: [Symbol])
+             (placeholder :: Symbol  )
+             (help        :: Symbol  )
+             a
+    = Flag { getFlag :: a }
+
+-- | Unnamed argument
+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
+
+-- | Command line option's annotated types
+class ArgRead a where
+    -- | Type of the argument
+    type Unwrap a :: *
+    type Unwrap a = a
+
+    -- | Get the argument's value
+    unwrap :: a -> Unwrap a
+    default unwrap :: a ~ Unwrap a => a -> Unwrap a
+    unwrap = id
+
+    -- | Argument parser
+    argRead :: Maybe String -> Maybe a
+    default argRead :: Read a => Maybe String -> Maybe a
+    argRead s = readMaybe =<< s
+
+    -- | Indicate this argument is mandatory
+    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)
+
+-- | The argument which has defalut value
+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
+newtype Cmd (help :: Symbol) a =
+    Cmd { unCmd :: ReaderT Int IO a }
+    deriving (Functor, Applicative, Monad, MonadIO)
+
+-- | Output string when the verbosity level is greater than or equal to `logLevel`
+logStr :: Int         -- ^ Verbosity Level
+       -> String      -- ^ Message
+       -> Cmd help ()
+logStr logLevel msg = do
+    l <- getLogger
+    l logLevel msg
+
+-- | Return the verbosity level ('--verbosity=n')
+getVerbosity :: Cmd help Int
+getVerbosity = Cmd ask
+
+-- | Retrieve the logger function
+getLogger :: MonadIO m => Cmd a (Int -> String -> m ())
+getLogger = do
+    verbosity <- getVerbosity
+    return $ \logLevel msg -> when (verbosity >= logLevel) $ liftIO $ putStrLn msg
+
+-- | Command group
+data Group =
+    Group
+    { groupHelp :: String
+    , groupCmds :: [SubCmd]
+    }
+
+-- | Sub command
+data SubCmd = forall c. IsCmd c => SubCmd String c
+
+-- | Command class
+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 -> return 1
+                           | all (== 'v') s -> return $ length s + 1
+                           | otherwise -> readMaybe s
+                runReaderT m 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 _ _ = " <COMMAND> [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"
+
+-- | Make a sub command
+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
+        header = "Usage: " ++ prog ++ " [OPTION...]" ++ getUsageHeader cmd prog ++ "\n" ++
+                 "  " ++ getCmdHelp cmd ++ "\n\n" ++
+                 "Options:"
+
+        usage    =
+            usageInfo header 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