@@ -7,25 +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)
1212import Control.Monad.Writer (WriterT)
1313import Control.Monad.State (StateT)
14−import Control.Monad.Except (ExceptT)
14+import Control.Monad.Except (ExceptT, MonadError (..))
15+import Control.Monad.IO.Class (liftIO)
1516import Control.Monad.Trans (MonadTrans, lift)
1617import Data.IORef (IORef)
1718import Data.Text (Text)
19+import System.Exit (ExitCode (..), exitWith)
1820
1921import Obelisk.CliApp.TerminalString (TerminalString)
2022
21−data CliConfig = CliConfig
22− { _cliConfig_logLevel :: IORef Severity -- We are capable of changing the log level at runtime
23− , _cliConfig_noColor :: Bool -- Disallow coloured output
24− , _cliConfig_noSpinner :: Bool -- Disallow spinners
25− , _cliConfig_lock :: MVar Bool -- Whether the last message was an Overwrite output
26− , _cliConfig_tipDisplayed :: IORef Bool -- Whether the user tip (to make verbose) was already displayed
27− , _cliConfig_spinnerStack :: IORef ([Bool], [TerminalString]) -- Stack of logs from nested spinners
28− }
23+--------------------------------------------------------------------------------
2924
3025data Output
3126 = Output_Log (WithSeverity Text) -- Regular logging message (with colors and newlines)
@@ -35,26 +30,59 @@ data Output
3530 | Output_ClearLine -- Clear the line
3631 deriving (Eq, Show, Ord)
3732
38−type Cli m = MonadLog Output m
33+type CliLog m = MonadLog Output m
3934
40−newtype CliT m a = CliT
41− { unCliT :: ReaderT CliConfig (LoggingT Output m) a
42− }
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 }
4347 deriving
4448 ( Functor, Applicative, Monad, MonadIO
49+ , MonadReader r
4550 , MonadThrow, MonadCatch, MonadMask
4651 , MonadLog Output
4752 )
4853
49−instance MonadTrans CliT where
50− lift = CliT . lift . lift
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+ }
5182
5283class Monad m => HasCliConfig m where
5384 getCliConfig :: m CliConfig
5485
55−instance Monad m => HasCliConfig (CliT m) where
56− getCliConfig = CliT ask
57−
5886instance HasCliConfig m => HasCliConfig (ReaderT r m) where
5987 getCliConfig = lift getCliConfig
6088
@@ -66,3 +94,20 @@ instance HasCliConfig m => HasCliConfig (StateT s m) where
6694
6795instance HasCliConfig m => HasCliConfig (ExceptT e m) where
6896 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+
112+instance Monad m => HasCliConfig (CliT m) where
113+ getCliConfig = ask