module TonaParser
(
Parser
, withConfig
, optionalVal
, requiredVal
, optionalEnum
, requiredEnum
, liftWith
, Source
, module System.Envy
, Description
, (.||)
, envVar
, argLong
, modify
, defParserMods
, ParserMods
, cmdLineLongMods
, envVarMods
) where
import RIO
import qualified RIO.List as List
import qualified RIO.Map as Map
import Control.Monad (ap)
import Data.Typeable (Proxy(..), typeOf, typeRep)
import Say (sayString)
import System.Environment (getArgs, getEnvironment)
import System.Envy (Var(fromVar, toVar))
newtype Parser a = Parser
{ runParser :: Bool -> Config -> (Bool -> a -> IO ()) -> IO () }
instance Functor Parser where
fmap :: (a -> b) -> Parser a -> Parser b
fmap f p = Parser $ \b conf action ->
runParser p b conf (\b' -> action b' . f)
instance Applicative Parser where
pure :: a -> Parser a
pure a = Parser $ \b _ action -> action b a
(<*>) = ap
instance Monad Parser where
(>>=) :: Parser a -> (a -> Parser b) -> Parser b
p >>= k = Parser $ \b conf action ->
runParser p b conf $ \b' x ->
runParser (k x) b' conf action
instance MonadIO Parser where
liftIO :: forall a. IO a -> Parser a
liftIO ma = Parser $ \b _ action -> action b =<< ma
modify :: ParserMods -> Parser a -> Parser a
modify mods (Parser parserFunc) =
Parser $ \b oldConfig ->
let newConfig =
oldConfig
{ confParserMods = confParserMods oldConfig <> mods
}
in parserFunc b newConfig
withConfig :: Parser a -> (a -> IO ()) -> IO ()
withConfig parser action = do
envVars <- getEnvVars
cmdLineArgs <- getCmdLineArgs
args <- getArgs
let isHelp = length (filter (`elem` ["--help", "-h"]) args) > 0
parse parser isHelp envVars cmdLineArgs action
parse ::
Parser a
-> Bool
-> Map String String
-> [(String, String)]
-> (a -> IO ())
-> IO ()
parse (Parser parserFunc) isHelp envVars cmdLineArgs action =
parserFunc isHelp conf $ \b a ->
if b
then do
sayString $ unlines
[ "Display this help and exit"
, " Default: False"
, " Type: Bool"
, " Command line option: -h"
, " Command line option: --help"
]
else action a
where
conf =
Config
{ confCmdLineArgs = cmdLineArgs
, confEnvVars = envVars
, confParserMods = defParserMods
}
getEnvVars :: IO (Map String String)
getEnvVars = do
environment <- getEnvironment
pure $ Map.fromList environment
getCmdLineArgs :: IO [(String, String)]
getCmdLineArgs = do
args <- getArgs
pure $ parseArgs args
parseArgs :: [String] -> [(String, String)]
parseArgs [] = []
parseArgs [('-':'-':key)] = [(key, "")]
parseArgs (('-':'-':key):ls@(('-':_):_)) = (key, "") : parseArgs ls
parseArgs (('-':'-':key):val:ls) = (key, val) : parseArgs ls
parseArgs (('-':_):ls) = parseArgs ls
parseArgs (_:ls) = parseArgs ls
requiredVal :: Var a => Description -> Source -> Parser a
requiredVal desc srcs = do
ma <- fieldMaybe Nothing desc srcs
handleRequired desc ma
optionalVal :: Var a => Description -> Source -> a -> Parser a
optionalVal desc srcs df = do
ma <- fieldMaybe (Just df) desc srcs
maybe (pure df) pure ma
requiredEnum :: (Var a, Enum a, Bounded a) => Description -> Source -> Parser a
requiredEnum desc srcs = do
ma <- fieldMaybeEnum Nothing desc srcs
handleRequired desc ma
optionalEnum :: (Var a, Enum a, Bounded a) => Description -> Source -> a -> Parser a
optionalEnum desc srcs df = do
ma <- fieldMaybeEnum (Just df) desc srcs
maybe (pure df) pure ma
handleRequired :: Description -> Maybe a -> Parser a
handleRequired _ (Just a) = pure a
handleRequired desc Nothing =
Parser $ \isHelp _ action ->
if isHelp
then action isHelp $ error "unreachable"
else error $
"No required configuration for \"" <> unDescription desc <> "\"\n" <>
"Try with '--help' option for more information."
liftWith :: ((a -> IO ()) -> IO ()) -> Parser a
liftWith cont = Parser $ \b _ action -> cont (action b)
fieldMaybe :: forall a. (Var a) => Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybe mdef desc source =
Parser $ \isHelp conf action -> do
when isHelp $
sayString $ helpLine mdef (confParserMods conf) desc source
action isHelp $ fieldMaybeVal isHelp conf desc source
fieldMaybeVal ::
forall a. (Var a)
=> Bool
-> Config
-> Description
-> Source
-> Maybe a
fieldMaybeVal isHelp conf desc (Source srcs) = do
val <- findValInSrc conf srcs
let v =
case (show (typeRep (Proxy :: Proxy a)), val) of
("Bool", "") -> "True"
("Bool", "true") -> "True"
("Bool", "false") -> "False"
_ -> val
case fromVar v of
Nothing ->
if isHelp
then Nothing
else error $
"Invalid type of value for \"" <> unDescription desc <> "\".\n" <>
"Try with '--help' option for more information."
a -> a
helpLine :: forall a. (Var a) => Maybe a -> ParserMods -> Description -> Source -> String
helpLine mdef mods (Description desc) (Source srcs) =
unlines $
desc : map (indent 4)
(helpDefault mdef : helpType (Proxy :: Proxy a) : map (helpSource mods) srcs)
indent :: Int -> String -> String
indent n str =
replicate n ' ' <> str
helpType :: forall a. Typeable a => Proxy a -> String
helpType p = "Type: " <> case show (typeRep p) of
"[Char]" -> "String"
"ByteString" -> "String"
"Text" -> "String"
a -> a
helpDefault :: Var a => Maybe a -> String
helpDefault a@Nothing = case show (typeOf a) of
"Bool" -> "Default: False"
_ -> "Required"
helpDefault (Just def) = "Default: " <> toVar def
helpSource :: ParserMods -> InnerSource -> String
helpSource ParserMods {envVarMods} (EnvVar str) =
"Environment variable: " <> envVarMods str
helpSource ParserMods {cmdLineLongMods} (ArgLong str) =
"Command line option: --" <> cmdLineLongMods str
helpSource ParserMods {cmdLineShortMods} (ArgShort c) =
"Command line option: -" <> [cmdLineShortMods c]
fieldMaybeEnum :: (Var a, Enum a, Bounded a) => Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybeEnum mdef desc source =
Parser $ \isHelp conf action -> do
when isHelp $
sayString $ helpLineEnum mdef (confParserMods conf) desc source
action isHelp $ fieldMaybeVal isHelp conf desc source
helpLineEnum :: forall a. (Var a, Enum a, Bounded a) => Maybe a -> ParserMods -> Description -> Source -> String
helpLineEnum mdef mods (Description desc) (Source srcs) =
unlines $
desc : map (indent 4)
(helpDefault mdef : helpType (Proxy :: Proxy a) <> helpEnum (Proxy :: Proxy a) : map (helpSource mods) srcs)
helpEnum :: forall a. (Var a, Enum a, Bounded a) => Proxy a -> String
helpEnum _ = if (length enums <= 8)
then " (" <> (List.intercalate "|" . map toVar) enums <> ")"
else ""
where
enums = [(minBound :: a)..maxBound]
findValInSrc :: Config -> [InnerSource] -> Maybe String
findValInSrc conf srcs = listToMaybe $ mapMaybe (findValInSrcs conf) srcs
findValInSrcs :: Config -> InnerSource -> Maybe String
findValInSrcs conf innerSource =
let cmdLineArgs = confCmdLineArgs conf
envVars = confEnvVars conf
mods = confParserMods conf
longMods = cmdLineLongMods mods
shortMods = cmdLineShortMods mods
envMods = envVarMods mods
in
case innerSource of
ArgLong str -> findValInCmdLineLong cmdLineArgs longMods str
ArgShort ch -> findValInCmdLineShort cmdLineArgs shortMods ch
EnvVar var -> findValInEnvVar envVars envMods var
findValInCmdLineLong
:: [(String, String)]
-> (String -> String)
-> String
-> Maybe String
findValInCmdLineLong args modFunc str =
let modifiedVal = modFunc str
in lookup modifiedVal args
findValInCmdLineShort
:: [(String, String)]
-> (Char -> Char)
-> Char
-> Maybe String
findValInCmdLineShort args modFunc ch =
let modifiedVal = modFunc ch
in lookup [modifiedVal] args
findValInEnvVar
:: Map String String
-> (String -> String)
-> String
-> Maybe String
findValInEnvVar args modFunc var =
let modifiedVal = modFunc var
in Map.lookup modifiedVal args
data Config = Config
{ confCmdLineArgs :: [(String, String)]
, confEnvVars :: Map String String
, confParserMods :: ParserMods
}
data ParserMods = ParserMods
{ cmdLineLongMods :: String -> String
, cmdLineShortMods :: Char -> Char
, envVarMods :: String -> String
}
instance Semigroup ParserMods where
ParserMods a b c <> ParserMods a' b' c' =
ParserMods (a' . a) (b' . b) (c' . c)
instance Monoid ParserMods where
mappend = (<>)
mempty = ParserMods id id id
defParserMods :: ParserMods
defParserMods = mempty
data InnerSource
= EnvVar String
| ArgLong String
| ArgShort Char
newtype Source = Source { _unSource :: [InnerSource] }
(.||) :: Source -> Source -> Source
(.||) (Source a) (Source b) = Source (a ++ b)
newtype Description = Description { unDescription :: String }
deriving (Show, Eq, Read, IsString)
envVar :: String -> Source
envVar name =
Source [EnvVar name]
argLong :: String -> Source
argLong name = Source [ArgLong name]