{-# LANGUAGE CPP #-}
{-# 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 argument types
ArgRead(..),
Def,
-- * Subcommands support
Group(..),
SubCmd, subCmd,
-- * Run a command
run, run_,
) where
import Control.Applicative
import Control.Monad
import Control.Monad.Catch
import Control.Monad.Reader
import Data.List
import Data.Maybe
import Data.Monoid
import Data.Proxy
import GHC.TypeLits
import System.Console.GetOpt
import System.Environment
import System.Exit
import System.IO
import Text.Read
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail
#endif
-- | 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 :: [String] -> Maybe a
default argRead :: Read a => [String] -> Maybe a
argRead ss = getLast $ mconcat $ Last . readMaybe <$> ss
-- | Indicate this argument is mandatory
needArg :: Proxy a -> Bool
needArg _ = True
instance ArgRead Int
instance ArgRead Integer
instance ArgRead Double
instance {-# OVERLAPPING #-} ArgRead String where
argRead [] = Nothing
argRead xs = Just $ last xs
instance ArgRead Bool where
argRead [] = Just False
argRead ["f"] = Just False
argRead ["t"] = Just True
argRead _ = Nothing
needArg _ = False
instance ArgRead a => ArgRead (Maybe a) where
argRead [] = Just Nothing
argRead xs = Just <$> argRead xs
instance {-# OVERLAPPABLE #-} ArgRead a => ArgRead [a] where
argRead xs = Just $ mapMaybe (argRead . (:[])) xs
-- | The argument which has default 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' = case s of
[] -> [symbolVal (Proxy :: Proxy defaultValue)]
v -> v
in Def <$> argRead s'
-- | Command
newtype Cmd (help :: Symbol) a =
Cmd (ReaderT Int IO a)
deriving (Functor, Applicative, Alternative, Monad, MonadIO, MonadFix, MonadPlus, MonadFail, MonadThrow, MonadCatch)
-- | 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 = map snd $ filter ((== flagName) . fst) options
in case (argRead mbs, mbs) of
(Nothing, []) ->
errorExit name $ "flag must be specified: --" ++ flagName
(Nothing, s:_) ->
errorExit name $ "bad argument: --" ++ flagName ++ "=" ++ s
(Just arg, _) ->
runCmd (f $ Flag arg) name mbver options nonOptions unrecognized
instance {-# OVERLAPPABLE #-}
( KnownSymbol placeholder, ArgRead a, IsCmd c )
=> IsCmd (Arg placeholder a -> c) where
getUsageHeader = getUsageHeaderOne (Proxy :: Proxy placeholder)
runCmd = runCmdOne
instance {-# OVERLAPPING #-}
( KnownSymbol placeholder, IsCmd c )
=> IsCmd (Arg placeholder String -> c) where
getUsageHeader = getUsageHeaderOne (Proxy :: Proxy placeholder)
runCmd = runCmdOne
getUsageHeaderOne :: ( KnownSymbol placeholder, ArgRead a, IsCmd c )
=> Proxy placeholder -> (Arg placeholder a -> c) -> String -> String
getUsageHeaderOne proxy f prog =
" " ++ symbolVal proxy ++ getUsageHeader (f undefined) prog
runCmdOne f name mbver options nonOptions unrecognized =
case nonOptions of
[] -> errorExit name "not enough arguments"
(opt: rest) ->
case argRead [opt] of
Nothing ->
errorExit name $ "bad argument: " ++ opt
Just arg ->
runCmd (f $ Arg arg) name mbver options rest unrecognized
instance {-# OVERLAPPING #-}
( KnownSymbol placeholder, ArgRead a, IsCmd c )
=> IsCmd (Arg placeholder [a] -> c) where
getUsageHeader f prog =
" " ++ symbolVal (Proxy :: Proxy placeholder) ++ getUsageHeader (f undefined) prog
runCmd f name mbver options nonOptions unrecognized =
case traverse argRead $ (:[]) <$> nonOptions of
Nothing ->
errorExit name $ "bad arguments: " ++ unwords nonOptions
Just opts ->
runCmd (f $ Arg opts) 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