/
Types.hs
134 lines (110 loc) · 4.55 KB
/
Types.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FunctionalDependencies #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE CPP #-}
module Cli.Extras.Types where
import Control.Concurrent.MVar (MVar)
import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
import Control.Monad.Log (LoggingT(..), MonadLog, Severity (..), WithSeverity (..), logMessage)
import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader (..), ask, mapReaderT)
import Control.Monad.Writer (WriterT)
import Control.Monad.State (StateT)
import Control.Monad.Except (ExceptT, MonadError (..))
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans (MonadTrans, lift)
import Data.IORef (IORef)
import Data.Text (Text)
import System.Exit (ExitCode (..), exitWith)
import Cli.Extras.TerminalString (TerminalString)
import Cli.Extras.Theme (CliTheme)
#if !(MIN_VERSION_base(4, 13, 0))
import Control.Monad.Fail (MonadFail)
#endif
--------------------------------------------------------------------------------
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 (Eq, Show, Ord)
type CliLog m = MonadLog Output m
type CliThrow e m = MonadError e m
-- | Log a message to the console.
--
-- Logs safely even if there are ongoing spinners.
putLog :: CliLog m => Severity -> Text -> m ()
putLog sev = logMessage . Output_Log . WithSeverity sev
newtype DieT e m a = DieT { unDieT :: ReaderT (e -> (Text, ExitCode)) (LoggingT Output m) a }
deriving
( Functor, Applicative, Monad, MonadIO, MonadFail
, MonadThrow, MonadCatch, MonadMask
, MonadLog Output
)
instance MonadTrans (DieT e) where
lift = DieT . lift . lift
instance MonadReader r m => MonadReader r (DieT e m) where
ask = DieT $ lift $ ask
local = (\f (DieT a) -> DieT $ f a) . mapReaderT . local
reader = DieT . lift . lift . reader
-- TODO generalize to bigger error types
instance MonadIO m => MonadError e (DieT e m) where
throwError e = do
handler <- DieT ask
let (output, exitCode) = handler e
putLog Alert output
liftIO $ exitWith $ exitCode
-- Cannot catch
catchError m _ = m
--------------------------------------------------------------------------------
data CliConfig e = CliConfig
{ -- | We are capable of changing the log level at runtime
_cliConfig_logLevel :: IORef Severity
, -- | Disallow coloured output
_cliConfig_noColor :: Bool
, -- | Disallow spinners
_cliConfig_noSpinner :: Bool
, -- | Whether the last message was an Overwrite output
_cliConfig_lock :: MVar Bool
, -- | Whether the user tip (to make verbose) was already displayed
_cliConfig_tipDisplayed :: IORef Bool
, -- | Stack of logs from nested spinners
_cliConfig_spinnerStack :: IORef ([Bool], [TerminalString])
, -- | Handler for failures. Determines, given an error, what message
-- should be printed, and what the exit status should be.
_cliConfig_errorLogExitCode :: e -> (Text, ExitCode)
, -- | Theme strings for spinners
_cliConfig_theme :: CliTheme
}
class Monad m => HasCliConfig e m | m -> e where
getCliConfig :: m (CliConfig e)
instance HasCliConfig e m => HasCliConfig e (ReaderT r m) where
getCliConfig = lift getCliConfig
instance (Monoid w, HasCliConfig e m) => HasCliConfig e (WriterT w m) where
getCliConfig = lift getCliConfig
instance HasCliConfig e m => HasCliConfig e (StateT s m) where
getCliConfig = lift getCliConfig
instance HasCliConfig e m => HasCliConfig e (ExceptT e m) where
getCliConfig = lift getCliConfig
--------------------------------------------------------------------------------
newtype CliT e m a = CliT
{ unCliT :: ReaderT (CliConfig e) (DieT e m) a
}
deriving
( Functor, Applicative, Monad, MonadIO, MonadFail
, MonadThrow, MonadCatch, MonadMask
, MonadLog Output -- CliLog
, MonadError e -- CliThrow
, MonadReader (CliConfig e) -- HasCliConfig
)
instance MonadTrans (CliT e) where
lift = CliT . lift . lift
instance Monad m => HasCliConfig e (CliT e m)where
getCliConfig = ask