{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE UndecidableInstances #-}

module Mensam.Server.Application.Options where

import Mensam.Server.Application.Options.Class
import Mensam.Server.Environment

import Control.Monad.Trans
import Control.Monad.Trans.Compose
import Control.Monad.Trans.Control
import Control.Monad.Trans.Control.Identity
import Control.Monad.Trans.Reader
import Data.Foldable
import Data.Kind
import Data.String
import Options.Applicative
import Options.Applicative.Extra
import Options.Applicative.Help.Pretty

type OptionsT :: (Type -> Type) -> Type -> Type
newtype OptionsT m a = MkOptionsT {forall (m :: * -> *) a. OptionsT m a -> ReaderT Options m a
unOptionsT :: ReaderT Options m a}
  deriving newtype (Functor (OptionsT m)
Functor (OptionsT m) =>
(forall a. a -> OptionsT m a)
-> (forall a b.
    OptionsT m (a -> b) -> OptionsT m a -> OptionsT m b)
-> (forall a b c.
    (a -> b -> c) -> OptionsT m a -> OptionsT m b -> OptionsT m c)
-> (forall a b. OptionsT m a -> OptionsT m b -> OptionsT m b)
-> (forall a b. OptionsT m a -> OptionsT m b -> OptionsT m a)
-> Applicative (OptionsT m)
forall a. a -> OptionsT m a
forall a b. OptionsT m a -> OptionsT m b -> OptionsT m a
forall a b. OptionsT m a -> OptionsT m b -> OptionsT m b
forall a b. OptionsT m (a -> b) -> OptionsT m a -> OptionsT m b
forall a b c.
(a -> b -> c) -> OptionsT m a -> OptionsT m b -> OptionsT m c
forall (f :: * -> *).
Functor f =>
(forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall (m :: * -> *). Applicative m => Functor (OptionsT m)
forall (m :: * -> *) a. Applicative m => a -> OptionsT m a
forall (m :: * -> *) a b.
Applicative m =>
OptionsT m a -> OptionsT m b -> OptionsT m a
forall (m :: * -> *) a b.
Applicative m =>
OptionsT m a -> OptionsT m b -> OptionsT m b
forall (m :: * -> *) a b.
Applicative m =>
OptionsT m (a -> b) -> OptionsT m a -> OptionsT m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> OptionsT m a -> OptionsT m b -> OptionsT m c
$cpure :: forall (m :: * -> *) a. Applicative m => a -> OptionsT m a
pure :: forall a. a -> OptionsT m a
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
OptionsT m (a -> b) -> OptionsT m a -> OptionsT m b
<*> :: forall a b. OptionsT m (a -> b) -> OptionsT m a -> OptionsT m b
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> OptionsT m a -> OptionsT m b -> OptionsT m c
liftA2 :: forall a b c.
(a -> b -> c) -> OptionsT m a -> OptionsT m b -> OptionsT m c
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
OptionsT m a -> OptionsT m b -> OptionsT m b
*> :: forall a b. OptionsT m a -> OptionsT m b -> OptionsT m b
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
OptionsT m a -> OptionsT m b -> OptionsT m a
<* :: forall a b. OptionsT m a -> OptionsT m b -> OptionsT m a
Applicative, (forall a b. (a -> b) -> OptionsT m a -> OptionsT m b)
-> (forall a b. a -> OptionsT m b -> OptionsT m a)
-> Functor (OptionsT m)
forall a b. a -> OptionsT m b -> OptionsT m a
forall a b. (a -> b) -> OptionsT m a -> OptionsT m b
forall (m :: * -> *) a b.
Functor m =>
a -> OptionsT m b -> OptionsT m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> OptionsT m a -> OptionsT m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> OptionsT m a -> OptionsT m b
fmap :: forall a b. (a -> b) -> OptionsT m a -> OptionsT m b
$c<$ :: forall (m :: * -> *) a b.
Functor m =>
a -> OptionsT m b -> OptionsT m a
<$ :: forall a b. a -> OptionsT m b -> OptionsT m a
Functor, Applicative (OptionsT m)
Applicative (OptionsT m) =>
(forall a b. OptionsT m a -> (a -> OptionsT m b) -> OptionsT m b)
-> (forall a b. OptionsT m a -> OptionsT m b -> OptionsT m b)
-> (forall a. a -> OptionsT m a)
-> Monad (OptionsT m)
forall a. a -> OptionsT m a
forall a b. OptionsT m a -> OptionsT m b -> OptionsT m b
forall a b. OptionsT m a -> (a -> OptionsT m b) -> OptionsT m b
forall (m :: * -> *). Monad m => Applicative (OptionsT m)
forall (m :: * -> *) a. Monad m => a -> OptionsT m a
forall (m :: * -> *) a b.
Monad m =>
OptionsT m a -> OptionsT m b -> OptionsT m b
forall (m :: * -> *) a b.
Monad m =>
OptionsT m a -> (a -> OptionsT m b) -> OptionsT m b
forall (m :: * -> *).
Applicative m =>
(forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
OptionsT m a -> (a -> OptionsT m b) -> OptionsT m b
>>= :: forall a b. OptionsT m a -> (a -> OptionsT m b) -> OptionsT m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
OptionsT m a -> OptionsT m b -> OptionsT m b
>> :: forall a b. OptionsT m a -> OptionsT m b -> OptionsT m b
$creturn :: forall (m :: * -> *) a. Monad m => a -> OptionsT m a
return :: forall a. a -> OptionsT m a
Monad)
  deriving newtype ((forall (m :: * -> *). Monad m => Monad (OptionsT m)) =>
(forall (m :: * -> *) a. Monad m => m a -> OptionsT m a)
-> MonadTrans OptionsT
forall (m :: * -> *). Monad m => Monad (OptionsT m)
forall (m :: * -> *) a. Monad m => m a -> OptionsT m a
forall (t :: (* -> *) -> * -> *).
(forall (m :: * -> *). Monad m => Monad (t m)) =>
(forall (m :: * -> *) a. Monad m => m a -> t m a) -> MonadTrans t
$clift :: forall (m :: * -> *) a. Monad m => m a -> OptionsT m a
lift :: forall (m :: * -> *) a. Monad m => m a -> OptionsT m a
MonadTrans, MonadTrans OptionsT
MonadTrans OptionsT =>
(forall (m :: * -> *) a.
 Monad m =>
 (Run OptionsT -> m a) -> OptionsT m a)
-> (forall (m :: * -> *) a.
    Monad m =>
    m (StT OptionsT a) -> OptionsT m a)
-> MonadTransControl OptionsT
forall (m :: * -> *) a.
Monad m =>
m (StT OptionsT a) -> OptionsT m a
forall (m :: * -> *) a.
Monad m =>
(Run OptionsT -> m a) -> OptionsT m a
forall (t :: (* -> *) -> * -> *).
MonadTrans t =>
(forall (m :: * -> *) a. Monad m => (Run t -> m a) -> t m a)
-> (forall (m :: * -> *) a. Monad m => m (StT t a) -> t m a)
-> MonadTransControl t
$cliftWith :: forall (m :: * -> *) a.
Monad m =>
(Run OptionsT -> m a) -> OptionsT m a
liftWith :: forall (m :: * -> *) a.
Monad m =>
(Run OptionsT -> m a) -> OptionsT m a
$crestoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT OptionsT a) -> OptionsT m a
restoreT :: forall (m :: * -> *) a.
Monad m =>
m (StT OptionsT a) -> OptionsT m a
MonadTransControl, MonadTransControl OptionsT
MonadTransControl OptionsT =>
(forall (m :: * -> *) a.
 Monad m =>
 ((forall x. OptionsT m x -> m x) -> m a) -> OptionsT m a)
-> MonadTransControlIdentity OptionsT
forall (m :: * -> *) a.
Monad m =>
((forall x. OptionsT m x -> m x) -> m a) -> OptionsT m a
forall (t :: (* -> *) -> * -> *).
MonadTransControl t =>
(forall (m :: * -> *) a.
 Monad m =>
 ((forall x. t m x -> m x) -> m a) -> t m a)
-> MonadTransControlIdentity t
$cliftWithIdentity :: forall (m :: * -> *) a.
Monad m =>
((forall x. OptionsT m x -> m x) -> m a) -> OptionsT m a
liftWithIdentity :: forall (m :: * -> *) a.
Monad m =>
((forall x. OptionsT m x -> m x) -> m a) -> OptionsT m a
MonadTransControlIdentity)

instance Monad m => MonadOptions (OptionsT m) where
  options :: OptionsT m Options
options = ReaderT Options m Options -> OptionsT m Options
forall (m :: * -> *) a. ReaderT Options m a -> OptionsT m a
MkOptionsT ReaderT Options m Options
forall (m :: * -> *) r. Monad m => ReaderT r m r
ask

deriving via
  OptionsT ((t2 :: (Type -> Type) -> Type -> Type) m)
  instance
    Monad (t2 m) => MonadOptions (ComposeT OptionsT t2 m)

runOptionsT :: OptionsT m a -> Options -> m a
runOptionsT :: forall (m :: * -> *) a. OptionsT m a -> Options -> m a
runOptionsT = ReaderT Options m a -> Options -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (ReaderT Options m a -> Options -> m a)
-> (OptionsT m a -> ReaderT Options m a)
-> OptionsT m a
-> Options
-> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. OptionsT m a -> ReaderT Options m a
forall (m :: * -> *) a. OptionsT m a -> ReaderT Options m a
unOptionsT

runAppOptionsT ::
  MonadIO m =>
  OptionsT m a ->
  m a
runAppOptionsT :: forall (m :: * -> *) a. MonadIO m => OptionsT m a -> m a
runAppOptionsT OptionsT m a
tma = do
  Options
parsedOptions <- IO Options -> m Options
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Options -> m Options) -> IO Options -> m Options
forall a b. (a -> b) -> a -> b
$ ParserInfo Options -> IO Options
forall a. ParserInfo a -> IO a
execParser ParserInfo Options
parserInfoOptions
  OptionsT m a -> Options -> m a
forall (m :: * -> *) a. OptionsT m a -> Options -> m a
runOptionsT OptionsT m a
tma Options
parsedOptions

parserInfoOptions :: ParserInfo Options
parserInfoOptions :: ParserInfo Options
parserInfoOptions =
  Parser Options -> InfoMod Options -> ParserInfo Options
forall a. Parser a -> InfoMod a -> ParserInfo a
info Parser Options
parserOptions (InfoMod Options -> ParserInfo Options)
-> InfoMod Options -> ParserInfo Options
forall a b. (a -> b) -> a -> b
$
    [InfoMod Options] -> InfoMod Options
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
      [ InfoMod Options
forall a. InfoMod a
fullDesc
      , String -> InfoMod Options
forall a. String -> InfoMod a
header String
"Mensam"
      , Maybe (Doc AnsiStyle) -> InfoMod Options
forall a. Maybe (Doc AnsiStyle) -> InfoMod a
progDescDoc (Maybe (Doc AnsiStyle) -> InfoMod Options)
-> Maybe (Doc AnsiStyle) -> InfoMod Options
forall a b. (a -> b) -> a -> b
$
          Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a. a -> Maybe a
Just (Doc AnsiStyle -> Maybe (Doc AnsiStyle))
-> Doc AnsiStyle -> Maybe (Doc AnsiStyle)
forall a b. (a -> b) -> a -> b
$
            [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vcat
              [ Doc AnsiStyle
"Environment variables:"
              , Int -> Doc AnsiStyle -> Doc AnsiStyle
forall ann. Int -> Doc ann -> Doc ann
indent Int
2 (Doc AnsiStyle -> Doc AnsiStyle) -> Doc AnsiStyle -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ [Doc AnsiStyle] -> Doc AnsiStyle
forall ann. [Doc ann] -> Doc ann
vcat ([Doc AnsiStyle] -> Doc AnsiStyle)
-> [Doc AnsiStyle] -> Doc AnsiStyle
forall a b. (a -> b) -> a -> b
$ String -> Doc AnsiStyle
forall a. IsString a => String -> a
fromString (String -> Doc AnsiStyle) -> [String] -> [Doc AnsiStyle]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [String]
envVarHelp
              ]
      ]

parserOptions :: Parser Options
parserOptions :: Parser Options
parserOptions = do
  Options -> Options
addHelper <-
    Mod OptionFields (Options -> Options)
-> Parser (Options -> Options)
forall a. Mod OptionFields (a -> a) -> Parser (a -> a)
helperWith (Mod OptionFields (Options -> Options)
 -> Parser (Options -> Options))
-> Mod OptionFields (Options -> Options)
-> Parser (Options -> Options)
forall a b. (a -> b) -> a -> b
$
      [Mod OptionFields (Options -> Options)]
-> Mod OptionFields (Options -> Options)
forall m. Monoid m => [m] -> m
forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
        [ Char -> Mod OptionFields (Options -> Options)
forall (f :: * -> *) a. HasName f => Char -> Mod f a
short Char
'h'
        , String -> Mod OptionFields (Options -> Options)
forall (f :: * -> *) a. HasName f => String -> Mod f a
long String
"help"
        , String -> Mod OptionFields (Options -> Options)
forall (f :: * -> *) a. String -> Mod f a
help String
"display this help message"
        ]
  pure $ Options -> Options
addHelper (Options -> Options) -> Options -> Options
forall a b. (a -> b) -> a -> b
$ MkOptions {optionUnit :: ()
optionUnit = ()}