@@ -7,21 +7,20 @@ module Obelisk.CliApp.Types where
77
88import Control.Concurrent.MVar (MVar)
99import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
10−import Control.Monad.Log (LoggingT, MonadLog, Severity (..), WithSeverity (..))
11−import Control.Monad.Reader (MonadIO, ReaderT (..), ask)
10+import Control.Monad.Log (LoggingT, MonadLog, Severity (..), WithSeverity (..), logMessage)
11+import Control.Monad.Reader (MonadIO, ReaderT (..), MonadReader, ask)
12+import Control.Monad.Writer (WriterT)
13+import Control.Monad.State (StateT)
14+import Control.Monad.Except (ExceptT, MonadError (..))
15+import Control.Monad.IO.Class (liftIO)
16+import Control.Monad.Trans (MonadTrans, lift)
1217import Data.IORef (IORef)
1318import Data.Text (Text)
19+import System.Exit (ExitCode (..), exitWith)
1420
1521import Obelisk.CliApp.TerminalString (TerminalString)
1622
17−data CliConfig = CliConfig
18− { _cliConfig_logLevel :: IORef Severity -- We are capable of changing the log level at runtime
19− , _cliConfig_noColor :: Bool -- Disallow coloured output
20− , _cliConfig_noSpinner :: Bool -- Disallow spinners
21− , _cliConfig_lock :: MVar Bool -- Whether the last message was an Overwrite output
22− , _cliConfig_tipDisplayed :: IORef Bool -- Whether the user tip (to make verbose) was already displayed
23− , _cliConfig_spinnerStack :: IORef ([Bool], [TerminalString]) -- Stack of logs from nested spinners
24− }
23+--------------------------------------------------------------------------------
2524
2625data Output
2726 = Output_Log (WithSeverity Text) -- Regular logging message (with colors and newlines)
@@ -31,19 +30,84 @@ data Output
3130 | Output_ClearLine -- Clear the line
3231 deriving (Eq, Show, Ord)
3332
34−type Cli m = MonadLog Output m
33+type CliLog m = MonadLog Output m
3534
36−newtype CliT m a = CliT
37− { unCliT :: ReaderT CliConfig (LoggingT Output m) a
38− }
35+type CliThrow m = MonadError Text m
36+
37+-- TODO could remove for granularity
38+type Cli m = (CliLog m, CliThrow m)
39+
40+-- | Log a message to the console.
41+--
42+-- Logs safely even if there are ongoing spinners.
43+putLog :: Cli m => Severity -> Text -> m ()
44+putLog sev = logMessage . Output_Log . WithSeverity sev
45+
46+newtype DieT m a = DieT { unDieT :: LoggingT Output m a }
3947 deriving
4048 ( Functor, Applicative, Monad, MonadIO
49+ , MonadReader r
4150 , MonadThrow, MonadCatch, MonadMask
4251 , MonadLog Output
4352 )
4453
54+instance MonadTrans DieT where
55+ lift = DieT . lift
56+
57+-- TODO generalize to bigger error types
58+instance MonadIO m => MonadError Text (DieT m) where
59+ throwError s = do
60+ putLog Alert s
61+ liftIO $ exitWith $ ExitFailure 2
62+
63+ -- Cannot catch
64+ catchError m _ = m
65+
66+--------------------------------------------------------------------------------
67+
68+data CliConfig = CliConfig
69+ { -- | We are capable of changing the log level at runtime
70+ _cliConfig_logLevel :: IORef Severity
71+ , -- | Disallow coloured output
72+ _cliConfig_noColor :: Bool
73+ , -- | Disallow spinners
74+ _cliConfig_noSpinner :: Bool
75+ , -- | Whether the last message was an Overwrite output
76+ _cliConfig_lock :: MVar Bool
77+ , -- | Whether the user tip (to make verbose) was already displayed
78+ _cliConfig_tipDisplayed :: IORef Bool
79+ , -- | Stack of logs from nested spinners
80+ _cliConfig_spinnerStack :: IORef ([Bool], [TerminalString])
81+ }
82+
4583class Monad m => HasCliConfig m where
4684 getCliConfig :: m CliConfig
4785
86+instance HasCliConfig m => HasCliConfig (ReaderT r m) where
87+ getCliConfig = lift getCliConfig
88+
89+instance (Monoid w, HasCliConfig m) => HasCliConfig (WriterT w m) where
90+ getCliConfig = lift getCliConfig
91+
92+instance HasCliConfig m => HasCliConfig (StateT s m) where
93+ getCliConfig = lift getCliConfig
94+
95+instance HasCliConfig m => HasCliConfig (ExceptT e m) where
96+ getCliConfig = lift getCliConfig
97+
98+--------------------------------------------------------------------------------
99+
100+newtype CliT m a = CliT
101+ { unCliT :: ReaderT CliConfig (DieT m) a
102+ }
103+ deriving
104+ ( Functor, Applicative, Monad, MonadIO
105+ , MonadThrow, MonadCatch, MonadMask
106+ , MonadLog Output, MonadError Text, MonadReader CliConfig
107+ )
108+
109+instance MonadTrans CliT where
110+ lift = CliT . lift . lift
111+
48112instance Monad m => HasCliConfig (CliT m) where
49− getCliConfig = CliT ask
113+ getCliConfig = ask