{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
module Cli.Extras.Types where

import Control.Concurrent.MVar (MVar)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Fail (MonadFail)
import Control.Monad.Log (LoggingT(..), MonadLog, Severity (..), WithSeverity (..))
import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask)
import Control.Monad.Writer (WriterT)
import Control.Monad.State (StateT)
import Control.Monad.Except (ExceptT, MonadError (..))
import Control.Monad.Trans (MonadTrans, lift)
import Data.IORef (IORef)
import Data.Text (Text)

import Cli.Extras.TerminalString (TerminalString)
import Cli.Extras.Theme (CliTheme)
import Cli.Extras.SubExcept

--------------------------------------------------------------------------------

data Output
  = Output_Log (WithSeverity Text)  -- Regular logging message (with colors and newlines)
  | Output_LogRaw (WithSeverity Text)  -- Like `Output_Log` but without the implicit newline added.
  | Output_Write [TerminalString]  -- Render and write a TerminalString using putstrLn
  | Output_Overwrite [TerminalString]  -- Overwrite the current line (i.e. \r followed by `putStr`)
  | Output_ClearLine  -- Clear the line
  deriving (Output -> Output -> Bool
(Output -> Output -> Bool)
-> (Output -> Output -> Bool) -> Eq Output
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Output -> Output -> Bool
$c/= :: Output -> Output -> Bool
== :: Output -> Output -> Bool
$c== :: Output -> Output -> Bool
Eq, Int -> Output -> ShowS
[Output] -> ShowS
Output -> String
(Int -> Output -> ShowS)
-> (Output -> String) -> ([Output] -> ShowS) -> Show Output
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Output] -> ShowS
$cshowList :: [Output] -> ShowS
show :: Output -> String
$cshow :: Output -> String
showsPrec :: Int -> Output -> ShowS
$cshowsPrec :: Int -> Output -> ShowS
Show, Eq Output
Eq Output =>
(Output -> Output -> Ordering)
-> (Output -> Output -> Bool)
-> (Output -> Output -> Bool)
-> (Output -> Output -> Bool)
-> (Output -> Output -> Bool)
-> (Output -> Output -> Output)
-> (Output -> Output -> Output)
-> Ord Output
Output -> Output -> Bool
Output -> Output -> Ordering
Output -> Output -> Output
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Output -> Output -> Output
$cmin :: Output -> Output -> Output
max :: Output -> Output -> Output
$cmax :: Output -> Output -> Output
>= :: Output -> Output -> Bool
$c>= :: Output -> Output -> Bool
> :: Output -> Output -> Bool
$c> :: Output -> Output -> Bool
<= :: Output -> Output -> Bool
$c<= :: Output -> Output -> Bool
< :: Output -> Output -> Bool
$c< :: Output -> Output -> Bool
compare :: Output -> Output -> Ordering
$ccompare :: Output -> Output -> Ordering
$cp1Ord :: Eq Output
Ord)

type CliLog m = MonadLog Output m

type CliThrow e m = MonadError e m

--------------------------------------------------------------------------------

data CliConfig = CliConfig
  { -- | We are capable of changing the log level at runtime
    CliConfig -> IORef Severity
_cliConfig_logLevel :: IORef Severity
  , -- | Disallow coloured output
    CliConfig -> Bool
_cliConfig_noColor :: Bool
  , -- | Disallow spinners
    CliConfig -> Bool
_cliConfig_noSpinner :: Bool
  , -- | Whether the last message was an Overwrite output
    CliConfig -> MVar Bool
_cliConfig_lock :: MVar Bool
  , -- | Whether the user tip (to make verbose) was already displayed
    CliConfig -> IORef Bool
_cliConfig_tipDisplayed :: IORef Bool
  , -- | Stack of logs from nested spinners
    CliConfig -> IORef ([Bool], [TerminalString])
_cliConfig_spinnerStack :: IORef ([Bool], [TerminalString])
  , -- | Theme strings for spinners
    CliConfig -> CliTheme
_cliConfig_theme :: CliTheme
  }

class Monad m => HasCliConfig m where
  getCliConfig :: m CliConfig

instance HasCliConfig m => HasCliConfig (ReaderT r m) where
  getCliConfig :: ReaderT r m CliConfig
getCliConfig = m CliConfig -> ReaderT r m CliConfig
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig

instance (Monoid w, HasCliConfig m) => HasCliConfig (WriterT w m) where
  getCliConfig :: WriterT w m CliConfig
getCliConfig = m CliConfig -> WriterT w m CliConfig
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig

instance HasCliConfig m => HasCliConfig (StateT s m) where
  getCliConfig :: StateT s m CliConfig
getCliConfig = m CliConfig -> StateT s m CliConfig
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig

instance HasCliConfig m => HasCliConfig (ExceptT e m) where
  getCliConfig :: ExceptT e m CliConfig
getCliConfig = m CliConfig -> ExceptT e m CliConfig
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig

instance HasCliConfig m => HasCliConfig (SubExceptT e eSub m) where
  getCliConfig :: SubExceptT e eSub m CliConfig
getCliConfig = m CliConfig -> SubExceptT e eSub m CliConfig
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig

--------------------------------------------------------------------------------

newtype CliT e m a = CliT
  { CliT e m a -> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
unCliT :: ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
  }
  deriving
    ( a -> CliT e m b -> CliT e m a
(a -> b) -> CliT e m a -> CliT e m b
(forall a b. (a -> b) -> CliT e m a -> CliT e m b)
-> (forall a b. a -> CliT e m b -> CliT e m a)
-> Functor (CliT e m)
forall a b. a -> CliT e m b -> CliT e m a
forall a b. (a -> b) -> CliT e m a -> CliT e m b
forall e (m :: * -> *) a b.
Functor m =>
a -> CliT e m b -> CliT e m a
forall e (m :: * -> *) a b.
Functor m =>
(a -> b) -> CliT e m a -> CliT e m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> CliT e m b -> CliT e m a
$c<$ :: forall e (m :: * -> *) a b.
Functor m =>
a -> CliT e m b -> CliT e m a
fmap :: (a -> b) -> CliT e m a -> CliT e m b
$cfmap :: forall e (m :: * -> *) a b.
Functor m =>
(a -> b) -> CliT e m a -> CliT e m b
Functor, Functor (CliT e m)
a -> CliT e m a
Functor (CliT e m) =>
(forall a. a -> CliT e m a)
-> (forall a b. CliT e m (a -> b) -> CliT e m a -> CliT e m b)
-> (forall a b c.
    (a -> b -> c) -> CliT e m a -> CliT e m b -> CliT e m c)
-> (forall a b. CliT e m a -> CliT e m b -> CliT e m b)
-> (forall a b. CliT e m a -> CliT e m b -> CliT e m a)
-> Applicative (CliT e m)
CliT e m a -> CliT e m b -> CliT e m b
CliT e m a -> CliT e m b -> CliT e m a
CliT e m (a -> b) -> CliT e m a -> CliT e m b
(a -> b -> c) -> CliT e m a -> CliT e m b -> CliT e m c
forall a. a -> CliT e m a
forall a b. CliT e m a -> CliT e m b -> CliT e m a
forall a b. CliT e m a -> CliT e m b -> CliT e m b
forall a b. CliT e m (a -> b) -> CliT e m a -> CliT e m b
forall a b c.
(a -> b -> c) -> CliT e m a -> CliT e m b -> CliT e m c
forall e (m :: * -> *). Monad m => Functor (CliT e m)
forall e (m :: * -> *) a. Monad m => a -> CliT e m a
forall e (m :: * -> *) a b.
Monad m =>
CliT e m a -> CliT e m b -> CliT e m a
forall e (m :: * -> *) a b.
Monad m =>
CliT e m a -> CliT e m b -> CliT e m b
forall e (m :: * -> *) a b.
Monad m =>
CliT e m (a -> b) -> CliT e m a -> CliT e m b
forall e (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> CliT e m a -> CliT e m b -> CliT e 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
<* :: CliT e m a -> CliT e m b -> CliT e m a
$c<* :: forall e (m :: * -> *) a b.
Monad m =>
CliT e m a -> CliT e m b -> CliT e m a
*> :: CliT e m a -> CliT e m b -> CliT e m b
$c*> :: forall e (m :: * -> *) a b.
Monad m =>
CliT e m a -> CliT e m b -> CliT e m b
liftA2 :: (a -> b -> c) -> CliT e m a -> CliT e m b -> CliT e m c
$cliftA2 :: forall e (m :: * -> *) a b c.
Monad m =>
(a -> b -> c) -> CliT e m a -> CliT e m b -> CliT e m c
<*> :: CliT e m (a -> b) -> CliT e m a -> CliT e m b
$c<*> :: forall e (m :: * -> *) a b.
Monad m =>
CliT e m (a -> b) -> CliT e m a -> CliT e m b
pure :: a -> CliT e m a
$cpure :: forall e (m :: * -> *) a. Monad m => a -> CliT e m a
$cp1Applicative :: forall e (m :: * -> *). Monad m => Functor (CliT e m)
Applicative, Applicative (CliT e m)
a -> CliT e m a
Applicative (CliT e m) =>
(forall a b. CliT e m a -> (a -> CliT e m b) -> CliT e m b)
-> (forall a b. CliT e m a -> CliT e m b -> CliT e m b)
-> (forall a. a -> CliT e m a)
-> Monad (CliT e m)
CliT e m a -> (a -> CliT e m b) -> CliT e m b
CliT e m a -> CliT e m b -> CliT e m b
forall a. a -> CliT e m a
forall a b. CliT e m a -> CliT e m b -> CliT e m b
forall a b. CliT e m a -> (a -> CliT e m b) -> CliT e m b
forall e (m :: * -> *). Monad m => Applicative (CliT e m)
forall e (m :: * -> *) a. Monad m => a -> CliT e m a
forall e (m :: * -> *) a b.
Monad m =>
CliT e m a -> CliT e m b -> CliT e m b
forall e (m :: * -> *) a b.
Monad m =>
CliT e m a -> (a -> CliT e m b) -> CliT e 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
return :: a -> CliT e m a
$creturn :: forall e (m :: * -> *) a. Monad m => a -> CliT e m a
>> :: CliT e m a -> CliT e m b -> CliT e m b
$c>> :: forall e (m :: * -> *) a b.
Monad m =>
CliT e m a -> CliT e m b -> CliT e m b
>>= :: CliT e m a -> (a -> CliT e m b) -> CliT e m b
$c>>= :: forall e (m :: * -> *) a b.
Monad m =>
CliT e m a -> (a -> CliT e m b) -> CliT e m b
$cp1Monad :: forall e (m :: * -> *). Monad m => Applicative (CliT e m)
Monad, Monad (CliT e m)
Monad (CliT e m) =>
(forall a. IO a -> CliT e m a) -> MonadIO (CliT e m)
IO a -> CliT e m a
forall a. IO a -> CliT e m a
forall e (m :: * -> *). MonadIO m => Monad (CliT e m)
forall e (m :: * -> *) a. MonadIO m => IO a -> CliT e m a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
liftIO :: IO a -> CliT e m a
$cliftIO :: forall e (m :: * -> *) a. MonadIO m => IO a -> CliT e m a
$cp1MonadIO :: forall e (m :: * -> *). MonadIO m => Monad (CliT e m)
MonadIO, Monad (CliT e m)
Monad (CliT e m) =>
(forall a. String -> CliT e m a) -> MonadFail (CliT e m)
String -> CliT e m a
forall a. String -> CliT e m a
forall e (m :: * -> *). MonadFail m => Monad (CliT e m)
forall e (m :: * -> *) a. MonadFail m => String -> CliT e m a
forall (m :: * -> *).
Monad m =>
(forall a. String -> m a) -> MonadFail m
fail :: String -> CliT e m a
$cfail :: forall e (m :: * -> *) a. MonadFail m => String -> CliT e m a
$cp1MonadFail :: forall e (m :: * -> *). MonadFail m => Monad (CliT e m)
MonadFail
    , Monad (CliT e m)
e -> CliT e m a
Monad (CliT e m) =>
(forall e a. Exception e => e -> CliT e m a)
-> MonadThrow (CliT e m)
forall e a. Exception e => e -> CliT e m a
forall e (m :: * -> *). MonadThrow m => Monad (CliT e m)
forall e (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> CliT e m a
forall (m :: * -> *).
Monad m =>
(forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: e -> CliT e m a
$cthrowM :: forall e (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> CliT e m a
$cp1MonadThrow :: forall e (m :: * -> *). MonadThrow m => Monad (CliT e m)
MonadThrow, MonadThrow (CliT e m)
MonadThrow (CliT e m) =>
(forall e a.
 Exception e =>
 CliT e m a -> (e -> CliT e m a) -> CliT e m a)
-> MonadCatch (CliT e m)
CliT e m a -> (e -> CliT e m a) -> CliT e m a
forall e a.
Exception e =>
CliT e m a -> (e -> CliT e m a) -> CliT e m a
forall e (m :: * -> *). MonadCatch m => MonadThrow (CliT e m)
forall e (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
CliT e m a -> (e -> CliT e m a) -> CliT e m a
forall (m :: * -> *).
MonadThrow m =>
(forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: CliT e m a -> (e -> CliT e m a) -> CliT e m a
$ccatch :: forall e (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
CliT e m a -> (e -> CliT e m a) -> CliT e m a
$cp1MonadCatch :: forall e (m :: * -> *). MonadCatch m => MonadThrow (CliT e m)
MonadCatch, MonadCatch (CliT e m)
MonadCatch (CliT e m) =>
(forall b.
 ((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b)
-> (forall b.
    ((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b)
-> (forall a b c.
    CliT e m a
    -> (a -> ExitCase b -> CliT e m c)
    -> (a -> CliT e m b)
    -> CliT e m (b, c))
-> MonadMask (CliT e m)
CliT e m a
-> (a -> ExitCase b -> CliT e m c)
-> (a -> CliT e m b)
-> CliT e m (b, c)
((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b
((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b
forall b.
((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b
forall a b c.
CliT e m a
-> (a -> ExitCase b -> CliT e m c)
-> (a -> CliT e m b)
-> CliT e m (b, c)
forall e (m :: * -> *). MonadMask m => MonadCatch (CliT e m)
forall e (m :: * -> *) b.
MonadMask m =>
((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b
forall e (m :: * -> *) a b c.
MonadMask m =>
CliT e m a
-> (a -> ExitCase b -> CliT e m c)
-> (a -> CliT e m b)
-> CliT e m (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: CliT e m a
-> (a -> ExitCase b -> CliT e m c)
-> (a -> CliT e m b)
-> CliT e m (b, c)
$cgeneralBracket :: forall e (m :: * -> *) a b c.
MonadMask m =>
CliT e m a
-> (a -> ExitCase b -> CliT e m c)
-> (a -> CliT e m b)
-> CliT e m (b, c)
uninterruptibleMask :: ((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b
$cuninterruptibleMask :: forall e (m :: * -> *) b.
MonadMask m =>
((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b
mask :: ((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b
$cmask :: forall e (m :: * -> *) b.
MonadMask m =>
((forall a. CliT e m a -> CliT e m a) -> CliT e m b) -> CliT e m b
$cp1MonadMask :: forall e (m :: * -> *). MonadMask m => MonadCatch (CliT e m)
MonadMask
    , MonadLog Output -- CliLog
    , MonadError e -- CliThrow
    )

instance MonadTrans (CliT e) where
  lift :: m a -> CliT e m a
lift = ReaderT CliConfig (LoggingT Output (ExceptT e m)) a -> CliT e m a
forall e (m :: * -> *) a.
ReaderT CliConfig (LoggingT Output (ExceptT e m)) a -> CliT e m a
CliT (ReaderT CliConfig (LoggingT Output (ExceptT e m)) a -> CliT e m a)
-> (m a -> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a)
-> m a
-> CliT e m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LoggingT Output (ExceptT e m) a
-> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (LoggingT Output (ExceptT e m) a
 -> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a)
-> (m a -> LoggingT Output (ExceptT e m) a)
-> m a
-> ReaderT CliConfig (LoggingT Output (ExceptT e m)) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT e m a -> LoggingT Output (ExceptT e m) a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT e m a -> LoggingT Output (ExceptT e m) a)
-> (m a -> ExceptT e m a) -> m a -> LoggingT Output (ExceptT e m) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift

instance Monad m => HasCliConfig (CliT e m)where
  getCliConfig :: CliT e m CliConfig
getCliConfig = ReaderT CliConfig (LoggingT Output (ExceptT e m)) CliConfig
-> CliT e m CliConfig
forall e (m :: * -> *) a.
ReaderT CliConfig (LoggingT Output (ExceptT e m)) a -> CliT e m a
CliT ReaderT CliConfig (LoggingT Output (ExceptT e m)) CliConfig
forall r (m :: * -> *). MonadReader r m => m r
ask