{-# 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 _ _ = " [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