{-| Integrated parser library created for tonatona meta application framework.
  It can construct system configuration from environment variables, command line arguments, and any IO values depends on them.
  See details for @example/Main.hs@.
-}

module TonaParser
  (
  -- * Run parser
    Parser
  , withConfig
  -- * Construct primitive parsers
  , optionalVal
  , requiredVal
  , optionalEnum
  , requiredEnum
  , liftWith
  , Source
  , module System.Envy
  , Description
  , (.||)
  , envVar
  , argLong
  -- * Modify parsers
  , 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 (typeOf, typeRep)
import Say (sayString)
import System.Environment (getArgs, getEnvironment)
import System.Envy (Var(fromVar, toVar))



-- Types

{-| Main type representing how to construct system configuration.
 -}
newtype Parser a = Parser
  { Parser a -> Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
runParser :: Bool -> Config -> (Bool -> a -> IO ()) -> IO () }

instance Functor Parser where
  fmap :: (a -> b) -> Parser a -> Parser b
  fmap :: (a -> b) -> Parser a -> Parser b
fmap a -> b
f Parser a
p = (Bool -> Config -> (Bool -> b -> IO ()) -> IO ()) -> Parser b
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> b -> IO ()) -> IO ()) -> Parser b)
-> (Bool -> Config -> (Bool -> b -> IO ()) -> IO ()) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Bool
b Config
conf Bool -> b -> IO ()
action ->
    Parser a -> Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
forall a.
Parser a -> Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
runParser Parser a
p Bool
b Config
conf (\Bool
b' -> Bool -> b -> IO ()
action Bool
b' (b -> IO ()) -> (a -> b) -> a -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> b
f)

instance Applicative Parser where
  pure :: a -> Parser a
  pure :: a -> Parser a
pure a
a = (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a)
-> (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Bool
b Config
_ Bool -> a -> IO ()
action -> Bool -> a -> IO ()
action Bool
b a
a

  <*> :: Parser (a -> b) -> Parser a -> Parser b
(<*>) = Parser (a -> b) -> Parser a -> Parser b
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
ap

instance Monad Parser where
  (>>=) :: Parser a -> (a -> Parser b) -> Parser b
  Parser a
p >>= :: Parser a -> (a -> Parser b) -> Parser b
>>= a -> Parser b
k = (Bool -> Config -> (Bool -> b -> IO ()) -> IO ()) -> Parser b
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> b -> IO ()) -> IO ()) -> Parser b)
-> (Bool -> Config -> (Bool -> b -> IO ()) -> IO ()) -> Parser b
forall a b. (a -> b) -> a -> b
$ \Bool
b Config
conf Bool -> b -> IO ()
action ->
    Parser a -> Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
forall a.
Parser a -> Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
runParser Parser a
p Bool
b Config
conf ((Bool -> a -> IO ()) -> IO ()) -> (Bool -> a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
b' a
x ->
      Parser b -> Bool -> Config -> (Bool -> b -> IO ()) -> IO ()
forall a.
Parser a -> Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
runParser (a -> Parser b
k a
x) Bool
b' Config
conf Bool -> b -> IO ()
action

instance MonadIO Parser where
  liftIO :: forall a. IO a -> Parser a
  liftIO :: IO a -> Parser a
liftIO IO a
ma = (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a)
-> (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Bool
b Config
_ Bool -> a -> IO ()
action -> Bool -> a -> IO ()
action Bool
b (a -> IO ()) -> IO a -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO a
ma


-- Operators


modify :: ParserMods -> Parser a -> Parser a
modify :: ParserMods -> Parser a -> Parser a
modify ParserMods
mods (Parser Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
parserFunc) =
  (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a)
-> (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Bool
b Config
oldConfig ->
    let newConfig :: Config
newConfig =
          Config
oldConfig
            { confParserMods :: ParserMods
confParserMods = Config -> ParserMods
confParserMods Config
oldConfig ParserMods -> ParserMods -> ParserMods
forall a. Semigroup a => a -> a -> a
<> ParserMods
mods
            }
    in Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
parserFunc Bool
b Config
newConfig

withConfig :: Parser a -> (a -> IO ()) -> IO ()
withConfig :: Parser a -> (a -> IO ()) -> IO ()
withConfig Parser a
parser a -> IO ()
action = do
  Map String String
envVars <- IO (Map String String)
getEnvVars
  [(String, String)]
cmdLineArgs <- IO [(String, String)]
getCmdLineArgs
  [String]
args <- IO [String]
getArgs
  let isHelp :: Bool
isHelp = [String] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((String -> Bool) -> [String] -> [String]
forall a. (a -> Bool) -> [a] -> [a]
filter (String -> [String] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [String
"--help", String
"-h"]) [String]
args) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  Parser a
-> Bool
-> Map String String
-> [(String, String)]
-> (a -> IO ())
-> IO ()
forall a.
Parser a
-> Bool
-> Map String String
-> [(String, String)]
-> (a -> IO ())
-> IO ()
parse Parser a
parser Bool
isHelp Map String String
envVars [(String, String)]
cmdLineArgs a -> IO ()
action

parse ::
     Parser a
  -> Bool
  -> Map String String -- ^ Environment variables.
  -> [(String, String)] -- ^ Command line arguments and values.
  -> (a -> IO ())
  -> IO ()
parse :: Parser a
-> Bool
-> Map String String
-> [(String, String)]
-> (a -> IO ())
-> IO ()
parse (Parser Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
parserFunc) Bool
isHelp Map String String
envVars [(String, String)]
cmdLineArgs a -> IO ()
action =
  Bool -> Config -> (Bool -> a -> IO ()) -> IO ()
parserFunc Bool
isHelp Config
conf ((Bool -> a -> IO ()) -> IO ()) -> (Bool -> a -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \Bool
b a
a ->
    if Bool
b
      then do
        String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
sayString (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ [String] -> String
unlines
          [ String
"Display this help and exit"
          , String
"    Default: False"
          , String
"    Type: Bool"
          , String
"    Command line option: -h"
          , String
"    Command line option: --help"
          ]
      else a -> IO ()
action a
a
  where
    conf :: Config
conf =
        Config :: [(String, String)] -> Map String String -> ParserMods -> Config
Config
          { confCmdLineArgs :: [(String, String)]
confCmdLineArgs = [(String, String)]
cmdLineArgs
          , confEnvVars :: Map String String
confEnvVars = Map String String
envVars
          , confParserMods :: ParserMods
confParserMods = ParserMods
defParserMods
          }


getEnvVars :: IO (Map String String)
getEnvVars :: IO (Map String String)
getEnvVars = do
  [(String, String)]
environment <- IO [(String, String)]
getEnvironment
  Map String String -> IO (Map String String)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Map String String -> IO (Map String String))
-> Map String String -> IO (Map String String)
forall a b. (a -> b) -> a -> b
$ [(String, String)] -> Map String String
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(String, String)]
environment

-- TODO: Handle short-hands options.
getCmdLineArgs :: IO [(String, String)]
getCmdLineArgs :: IO [(String, String)]
getCmdLineArgs = do
  [String]
args <- IO [String]
getArgs
  [(String, String)] -> IO [(String, String)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(String, String)] -> IO [(String, String)])
-> [(String, String)] -> IO [(String, String)]
forall a b. (a -> b) -> a -> b
$ [String] -> [(String, String)]
parseArgs [String]
args

{-|
  >>> parseArgs ["--bool", "--foo", "bar", "-v"]
  [("bool",""),("foo","bar")]
-}
parseArgs :: [String] -> [(String, String)]
parseArgs :: [String] -> [(String, String)]
parseArgs [] = []
parseArgs [(Char
'-':Char
'-':String
key)] = [(String
key, String
"")]
parseArgs ((Char
'-':Char
'-':String
key):ls :: [String]
ls@((Char
'-':String
_):[String]
_)) = (String
key, String
"") (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [String] -> [(String, String)]
parseArgs [String]
ls
parseArgs ((Char
'-':Char
'-':String
key):String
val:[String]
ls) = (String
key, String
val) (String, String) -> [(String, String)] -> [(String, String)]
forall a. a -> [a] -> [a]
: [String] -> [(String, String)]
parseArgs [String]
ls
parseArgs ((Char
'-':String
_):[String]
ls) = [String] -> [(String, String)]
parseArgs [String]
ls
parseArgs (String
_:[String]
ls) = [String] -> [(String, String)]
parseArgs [String]
ls

{-| A 'Parser' constructor for required values.
-}
requiredVal :: Var a => Description -> Source -> Parser a
requiredVal :: Description -> Source -> Parser a
requiredVal Description
desc Source
srcs = do
  Maybe a
ma <- Maybe a -> Description -> Source -> Parser (Maybe a)
forall a.
Var a =>
Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybe Maybe a
forall a. Maybe a
Nothing Description
desc Source
srcs
  Description -> Maybe a -> Parser a
forall a. Description -> Maybe a -> Parser a
handleRequired Description
desc Maybe a
ma

{-| A 'Parser' constructor for optional values.
-}
optionalVal :: Var a => Description -> Source -> a -> Parser a
optionalVal :: Description -> Source -> a -> Parser a
optionalVal Description
desc Source
srcs a
df = do
  Maybe a
ma <- Maybe a -> Description -> Source -> Parser (Maybe a)
forall a.
Var a =>
Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybe (a -> Maybe a
forall a. a -> Maybe a
Just a
df) Description
desc Source
srcs
  Parser a -> (a -> Parser a) -> Maybe a -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
df) a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
ma

{-| A 'Parser' constructor for required values.
-}
requiredEnum :: (Var a, Enum a, Bounded a) => Description -> Source -> Parser a
requiredEnum :: Description -> Source -> Parser a
requiredEnum Description
desc Source
srcs = do
  Maybe a
ma <- Maybe a -> Description -> Source -> Parser (Maybe a)
forall a.
(Var a, Enum a, Bounded a) =>
Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybeEnum Maybe a
forall a. Maybe a
Nothing Description
desc Source
srcs
  Description -> Maybe a -> Parser a
forall a. Description -> Maybe a -> Parser a
handleRequired Description
desc Maybe a
ma

{-| A 'Parser' constructor for optional values.
-}
optionalEnum :: (Var a, Enum a, Bounded a) => Description -> Source -> a -> Parser a
optionalEnum :: Description -> Source -> a -> Parser a
optionalEnum Description
desc Source
srcs a
df = do
  Maybe a
ma <- Maybe a -> Description -> Source -> Parser (Maybe a)
forall a.
(Var a, Enum a, Bounded a) =>
Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybeEnum (a -> Maybe a
forall a. a -> Maybe a
Just a
df) Description
desc Source
srcs
  Parser a -> (a -> Parser a) -> Maybe a -> Parser a
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
df) a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
ma

handleRequired :: Description -> Maybe a -> Parser a
handleRequired :: Description -> Maybe a -> Parser a
handleRequired Description
_ (Just a
a) = a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a
handleRequired Description
desc Maybe a
Nothing =
  (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a)
-> (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Bool
isHelp Config
_ Bool -> a -> IO ()
action ->
    if Bool
isHelp
      then Bool -> a -> IO ()
action Bool
isHelp (a -> IO ()) -> a -> IO ()
forall a b. (a -> b) -> a -> b
$ String -> a
forall a. HasCallStack => String -> a
error String
"unreachable"
      else String -> IO ()
forall a. HasCallStack => String -> a
error (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$
           String
"No required configuration for \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Description -> String
unDescription Description
desc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\"\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
           String
"Try with '--help' option for more information."

{-| A `Parser` constructor from @cont@.
-}
liftWith :: ((a -> IO ()) -> IO ()) -> Parser a
liftWith :: ((a -> IO ()) -> IO ()) -> Parser a
liftWith (a -> IO ()) -> IO ()
cont = (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a)
-> (Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
forall a b. (a -> b) -> a -> b
$ \Bool
b Config
_ Bool -> a -> IO ()
action -> (a -> IO ()) -> IO ()
cont (Bool -> a -> IO ()
action Bool
b)

fieldMaybe :: forall a. (Var a) => Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybe :: Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybe Maybe a
mdef Description
desc Source
source =
  (Bool -> Config -> (Bool -> Maybe a -> IO ()) -> IO ())
-> Parser (Maybe a)
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> Maybe a -> IO ()) -> IO ())
 -> Parser (Maybe a))
-> (Bool -> Config -> (Bool -> Maybe a -> IO ()) -> IO ())
-> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Bool
isHelp Config
conf Bool -> Maybe a -> IO ()
action -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHelp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
sayString (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe a -> ParserMods -> Description -> Source -> String
forall a.
Var a =>
Maybe a -> ParserMods -> Description -> Source -> String
helpLine Maybe a
mdef (Config -> ParserMods
confParserMods Config
conf) Description
desc Source
source
    Bool -> Maybe a -> IO ()
action Bool
isHelp (Maybe a -> IO ()) -> Maybe a -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Config -> Description -> Source -> Maybe a
forall a.
Var a =>
Bool -> Config -> Description -> Source -> Maybe a
fieldMaybeVal Bool
isHelp Config
conf Description
desc Source
source


fieldMaybeVal ::
     forall a. (Var a)
  => Bool
  -> Config
  -> Description
  -> Source
  -> Maybe a
fieldMaybeVal :: Bool -> Config -> Description -> Source -> Maybe a
fieldMaybeVal Bool
isHelp Config
conf Description
desc (Source [InnerSource]
srcs) = do
  String
val <- Config -> [InnerSource] -> Maybe String
findValInSrc Config
conf [InnerSource]
srcs
  let v :: String
v =
        case (TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a)), String
val) of
          (String
"Bool", String
"") -> String
"True"
          (String
"Bool", String
"true") -> String
"True"
          (String
"Bool", String
"false") -> String
"False"
          (String, String)
_ -> String
val
  case String -> Maybe a
forall a. Var a => String -> Maybe a
fromVar String
v of
    Maybe a
Nothing ->
      if Bool
isHelp
        then Maybe a
forall a. Maybe a
Nothing
        else String -> Maybe a
forall a. HasCallStack => String -> a
error (String -> Maybe a) -> String -> Maybe a
forall a b. (a -> b) -> a -> b
$
             String
"Invalid type of value for \"" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Description -> String
unDescription Description
desc String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
"\".\n" String -> String -> String
forall a. Semigroup a => a -> a -> a
<>
             String
"Try with '--help' option for more information."
    Maybe a
a -> Maybe a
a

helpLine :: forall a. (Var a) => Maybe a -> ParserMods -> Description -> Source -> String
helpLine :: Maybe a -> ParserMods -> Description -> Source -> String
helpLine Maybe a
mdef ParserMods
mods (Description String
desc) (Source [InnerSource]
srcs) =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    String
desc String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
indent Int
4)
      (Maybe a -> String
forall a. Var a => Maybe a -> String
helpDefault Maybe a
mdef String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Proxy a -> String
forall k (a :: k). Typeable a => Proxy a -> String
helpType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (InnerSource -> String) -> [InnerSource] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ParserMods -> InnerSource -> String
helpSource ParserMods
mods) [InnerSource]
srcs)

indent :: Int -> String -> String
indent :: Int -> String -> String
indent Int
n String
str =
  Int -> Char -> String
forall a. Int -> a -> [a]
replicate Int
n Char
' ' String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
str

helpType :: forall a. Typeable a => Proxy a -> String
helpType :: Proxy a -> String
helpType Proxy a
p = String
"Type: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> case TypeRep -> String
forall a. Show a => a -> String
show (Proxy a -> TypeRep
forall k (proxy :: k -> *) (a :: k).
Typeable a =>
proxy a -> TypeRep
typeRep Proxy a
p) of
  String
"[Char]" -> String
"String"
  String
"ByteString" -> String
"String"
  String
"Text" -> String
"String"
  String
a -> String
a

helpDefault :: Var a => Maybe a -> String
helpDefault :: Maybe a -> String
helpDefault a :: Maybe a
a@Maybe a
Nothing = case TypeRep -> String
forall a. Show a => a -> String
show (Maybe a -> TypeRep
forall a. Typeable a => a -> TypeRep
typeOf Maybe a
a) of
  String
"Bool" -> String
"Default: False"
  String
_ -> String
"Required"
helpDefault (Just a
def) = String
"Default: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> a -> String
forall a. Var a => a -> String
toVar a
def

helpSource :: ParserMods -> InnerSource -> String
helpSource :: ParserMods -> InnerSource -> String
helpSource ParserMods {String -> String
envVarMods :: String -> String
envVarMods :: ParserMods -> String -> String
envVarMods} (EnvVar String
str) =
  String
"Environment variable: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
envVarMods String
str
helpSource ParserMods {String -> String
cmdLineLongMods :: String -> String
cmdLineLongMods :: ParserMods -> String -> String
cmdLineLongMods} (ArgLong String
str) =
  String
"Command line option: --" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String -> String
cmdLineLongMods String
str
helpSource ParserMods {Char -> Char
cmdLineShortMods :: ParserMods -> Char -> Char
cmdLineShortMods :: Char -> Char
cmdLineShortMods} (ArgShort Char
c) =
  String
"Command line option: -" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> [Char -> Char
cmdLineShortMods Char
c]

fieldMaybeEnum :: (Var a, Enum a, Bounded a) => Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybeEnum :: Maybe a -> Description -> Source -> Parser (Maybe a)
fieldMaybeEnum Maybe a
mdef Description
desc Source
source =
  (Bool -> Config -> (Bool -> Maybe a -> IO ()) -> IO ())
-> Parser (Maybe a)
forall a.
(Bool -> Config -> (Bool -> a -> IO ()) -> IO ()) -> Parser a
Parser ((Bool -> Config -> (Bool -> Maybe a -> IO ()) -> IO ())
 -> Parser (Maybe a))
-> (Bool -> Config -> (Bool -> Maybe a -> IO ()) -> IO ())
-> Parser (Maybe a)
forall a b. (a -> b) -> a -> b
$ \Bool
isHelp Config
conf Bool -> Maybe a -> IO ()
action -> do
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
isHelp (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      String -> IO ()
forall (m :: * -> *). MonadIO m => String -> m ()
sayString (String -> IO ()) -> String -> IO ()
forall a b. (a -> b) -> a -> b
$ Maybe a -> ParserMods -> Description -> Source -> String
forall a.
(Var a, Enum a, Bounded a) =>
Maybe a -> ParserMods -> Description -> Source -> String
helpLineEnum Maybe a
mdef (Config -> ParserMods
confParserMods Config
conf) Description
desc Source
source
    Bool -> Maybe a -> IO ()
action Bool
isHelp (Maybe a -> IO ()) -> Maybe a -> IO ()
forall a b. (a -> b) -> a -> b
$ Bool -> Config -> Description -> Source -> Maybe a
forall a.
Var a =>
Bool -> Config -> Description -> Source -> Maybe a
fieldMaybeVal Bool
isHelp Config
conf Description
desc Source
source

helpLineEnum :: forall a. (Var a, Enum a, Bounded a) => Maybe a -> ParserMods -> Description -> Source -> String
helpLineEnum :: Maybe a -> ParserMods -> Description -> Source -> String
helpLineEnum Maybe a
mdef ParserMods
mods (Description String
desc) (Source [InnerSource]
srcs) =
  [String] -> String
unlines ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
    String
desc String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (String -> String) -> [String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> String -> String
indent Int
4)
      (Maybe a -> String
forall a. Var a => Maybe a -> String
helpDefault Maybe a
mdef String -> [String] -> [String]
forall a. a -> [a] -> [a]
: Proxy a -> String
forall k (a :: k). Typeable a => Proxy a -> String
helpType (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Proxy a -> String
forall a. (Var a, Enum a, Bounded a) => Proxy a -> String
helpEnum (Proxy a
forall k (t :: k). Proxy t
Proxy :: Proxy a) String -> [String] -> [String]
forall a. a -> [a] -> [a]
: (InnerSource -> String) -> [InnerSource] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (ParserMods -> InnerSource -> String
helpSource ParserMods
mods) [InnerSource]
srcs)

helpEnum :: forall a. (Var a, Enum a, Bounded a) => Proxy a -> String
helpEnum :: Proxy a -> String
helpEnum Proxy a
_ = if ([a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [a]
enums Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
<= Int
8)
  then String
" (" String -> String -> String
forall a. Semigroup a => a -> a -> a
<> (String -> [String] -> String
forall a. [a] -> [[a]] -> [a]
List.intercalate String
"|" ([String] -> String) -> ([a] -> [String]) -> [a] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> String) -> [a] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map a -> String
forall a. Var a => a -> String
toVar) [a]
enums String -> String -> String
forall a. Semigroup a => a -> a -> a
<> String
")"
  else String
""
  where
    enums :: [a]
enums = [(a
forall a. Bounded a => a
minBound :: a)..a
forall a. Bounded a => a
maxBound]

findValInSrc :: Config -> [InnerSource] -> Maybe String
findValInSrc :: Config -> [InnerSource] -> Maybe String
findValInSrc Config
conf [InnerSource]
srcs = [String] -> Maybe String
forall a. [a] -> Maybe a
listToMaybe ([String] -> Maybe String) -> [String] -> Maybe String
forall a b. (a -> b) -> a -> b
$ (InnerSource -> Maybe String) -> [InnerSource] -> [String]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Config -> InnerSource -> Maybe String
findValInSrcs Config
conf) [InnerSource]
srcs

findValInSrcs :: Config -> InnerSource -> Maybe String
findValInSrcs :: Config -> InnerSource -> Maybe String
findValInSrcs Config
conf InnerSource
innerSource =
  let cmdLineArgs :: [(String, String)]
cmdLineArgs = Config -> [(String, String)]
confCmdLineArgs Config
conf
      envVars :: Map String String
envVars = Config -> Map String String
confEnvVars Config
conf
      mods :: ParserMods
mods = Config -> ParserMods
confParserMods Config
conf
      longMods :: String -> String
longMods = ParserMods -> String -> String
cmdLineLongMods ParserMods
mods
      shortMods :: Char -> Char
shortMods = ParserMods -> Char -> Char
cmdLineShortMods ParserMods
mods
      envMods :: String -> String
envMods = ParserMods -> String -> String
envVarMods ParserMods
mods
  in
  case InnerSource
innerSource of
    ArgLong String
str -> [(String, String)] -> (String -> String) -> String -> Maybe String
findValInCmdLineLong [(String, String)]
cmdLineArgs String -> String
longMods String
str
    ArgShort Char
ch -> [(String, String)] -> (Char -> Char) -> Char -> Maybe String
findValInCmdLineShort [(String, String)]
cmdLineArgs Char -> Char
shortMods Char
ch
    EnvVar String
var -> Map String String -> (String -> String) -> String -> Maybe String
findValInEnvVar Map String String
envVars String -> String
envMods String
var

findValInCmdLineLong
  :: [(String, String)]
  -> (String -> String)
  -> String
  -> Maybe String
findValInCmdLineLong :: [(String, String)] -> (String -> String) -> String -> Maybe String
findValInCmdLineLong [(String, String)]
args String -> String
modFunc String
str =
  let modifiedVal :: String
modifiedVal = String -> String
modFunc String
str
  in String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup String
modifiedVal [(String, String)]
args

findValInCmdLineShort
  :: [(String, String)]
  -> (Char -> Char)
  -> Char
  -> Maybe String
findValInCmdLineShort :: [(String, String)] -> (Char -> Char) -> Char -> Maybe String
findValInCmdLineShort [(String, String)]
args Char -> Char
modFunc Char
ch =
  let modifiedVal :: Char
modifiedVal = Char -> Char
modFunc Char
ch
  in String -> [(String, String)] -> Maybe String
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup [Char
modifiedVal] [(String, String)]
args

findValInEnvVar
  :: Map String String
  -> (String -> String)
  -> String
  -> Maybe String
findValInEnvVar :: Map String String -> (String -> String) -> String -> Maybe String
findValInEnvVar Map String String
args String -> String
modFunc String
var =
  let modifiedVal :: String
modifiedVal = String -> String
modFunc String
var
  in String -> Map String String -> Maybe String
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup String
modifiedVal Map String String
args

data Config = Config
  { Config -> [(String, String)]
confCmdLineArgs :: [(String, String)]
  , Config -> Map String String
confEnvVars :: Map String String
  , Config -> ParserMods
confParserMods :: ParserMods
  }

data ParserMods = ParserMods
  { ParserMods -> String -> String
cmdLineLongMods :: String -> String
  , ParserMods -> Char -> Char
cmdLineShortMods :: Char -> Char
  , ParserMods -> String -> String
envVarMods :: String -> String
  }

instance Semigroup ParserMods where
  ParserMods String -> String
a Char -> Char
b String -> String
c <> :: ParserMods -> ParserMods -> ParserMods
<> ParserMods String -> String
a' Char -> Char
b' String -> String
c' =
    (String -> String)
-> (Char -> Char) -> (String -> String) -> ParserMods
ParserMods (String -> String
a' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
a) (Char -> Char
b' (Char -> Char) -> (Char -> Char) -> Char -> Char
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> Char
b) (String -> String
c' (String -> String) -> (String -> String) -> String -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> String
c)

instance Monoid ParserMods where
  mappend :: ParserMods -> ParserMods -> ParserMods
mappend = ParserMods -> ParserMods -> ParserMods
forall a. Semigroup a => a -> a -> a
(<>)
  mempty :: ParserMods
mempty = (String -> String)
-> (Char -> Char) -> (String -> String) -> ParserMods
ParserMods String -> String
forall a. a -> a
id Char -> Char
forall a. a -> a
id String -> String
forall a. a -> a
id

defParserMods :: ParserMods
defParserMods :: ParserMods
defParserMods = ParserMods
forall a. Monoid a => a
mempty

data InnerSource
  = EnvVar String
  | ArgLong String
  | ArgShort Char

newtype Source = Source { Source -> [InnerSource]
_unSource :: [InnerSource] }

(.||) :: Source -> Source -> Source
.|| :: Source -> Source -> Source
(.||) (Source [InnerSource]
a) (Source [InnerSource]
b) = [InnerSource] -> Source
Source ([InnerSource]
a [InnerSource] -> [InnerSource] -> [InnerSource]
forall a. [a] -> [a] -> [a]
++ [InnerSource]
b)

newtype Description = Description { Description -> String
unDescription :: String }
  deriving (Int -> Description -> String -> String
[Description] -> String -> String
Description -> String
(Int -> Description -> String -> String)
-> (Description -> String)
-> ([Description] -> String -> String)
-> Show Description
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
showList :: [Description] -> String -> String
$cshowList :: [Description] -> String -> String
show :: Description -> String
$cshow :: Description -> String
showsPrec :: Int -> Description -> String -> String
$cshowsPrec :: Int -> Description -> String -> String
Show, Description -> Description -> Bool
(Description -> Description -> Bool)
-> (Description -> Description -> Bool) -> Eq Description
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Description -> Description -> Bool
$c/= :: Description -> Description -> Bool
== :: Description -> Description -> Bool
$c== :: Description -> Description -> Bool
Eq, ReadPrec [Description]
ReadPrec Description
Int -> ReadS Description
ReadS [Description]
(Int -> ReadS Description)
-> ReadS [Description]
-> ReadPrec Description
-> ReadPrec [Description]
-> Read Description
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [Description]
$creadListPrec :: ReadPrec [Description]
readPrec :: ReadPrec Description
$creadPrec :: ReadPrec Description
readList :: ReadS [Description]
$creadList :: ReadS [Description]
readsPrec :: Int -> ReadS Description
$creadsPrec :: Int -> ReadS Description
Read, String -> Description
(String -> Description) -> IsString Description
forall a. (String -> a) -> IsString a
fromString :: String -> Description
$cfromString :: String -> Description
IsString)

envVar :: String -> Source
envVar :: String -> Source
envVar String
name =
  [InnerSource] -> Source
Source [String -> InnerSource
EnvVar String
name]

argLong :: String -> Source
argLong :: String -> Source
argLong String
name = [InnerSource] -> Source
Source [String -> InnerSource
ArgLong String
name]

-- argShort :: Char -> Source
-- argShort name = Source [ArgShort name]