{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Cli.Extras.Spinner
( withSpinner
, withSpinnerNoTrail
, withSpinner'
) where
import Control.Concurrent (forkIO, killThread, threadDelay)
import Control.Monad (forM_, (>=>))
import Control.Monad.Catch (MonadMask, mask, onException)
import Control.Monad.IO.Class
import Control.Monad.Log (Severity (..), logMessage)
import Data.IORef
import qualified Data.List as L
import Data.Maybe (isNothing)
import Data.Text (Text)
import System.Console.ANSI (Color (Blue, Cyan, Green, Red))
import Cli.Extras.Logging (allowUserToMakeLoggingVerbose, putLog, handleLog)
import Cli.Extras.TerminalString (TerminalString (..), enquiryCode)
import Cli.Extras.Theme
import Cli.Extras.Types (CliLog, CliConfig (..), HasCliConfig, Output (..), getCliConfig)
withSpinner
:: (MonadIO m, MonadMask m, CliLog m, HasCliConfig m)
=> Text -> m a -> m a
withSpinner :: Text -> m a -> m a
withSpinner s :: Text
s = Text -> Maybe (a -> Text) -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig m) =>
Text -> Maybe (a -> Text) -> m a -> m a
withSpinner' Text
s (Maybe (a -> Text) -> m a -> m a)
-> Maybe (a -> Text) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ (a -> Text) -> Maybe (a -> Text)
forall a. a -> Maybe a
Just ((a -> Text) -> Maybe (a -> Text))
-> (a -> Text) -> Maybe (a -> Text)
forall a b. (a -> b) -> a -> b
$ Text -> a -> Text
forall a b. a -> b -> a
const Text
s
withSpinnerNoTrail
:: (MonadIO m, MonadMask m, CliLog m, HasCliConfig m)
=> Text -> m a -> m a
withSpinnerNoTrail :: Text -> m a -> m a
withSpinnerNoTrail s :: Text
s = Text -> Maybe (a -> Text) -> m a -> m a
forall (m :: * -> *) a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig m) =>
Text -> Maybe (a -> Text) -> m a -> m a
withSpinner' Text
s Maybe (a -> Text)
forall a. Maybe a
Nothing
withSpinner'
:: (MonadIO m, MonadMask m, CliLog m, HasCliConfig m)
=> Text
-> Maybe (a -> Text)
-> m a
-> m a
withSpinner' :: Text -> Maybe (a -> Text) -> m a -> m a
withSpinner' msg :: Text
msg mkTrail :: Maybe (a -> Text)
mkTrail action :: m a
action = do
CliConfig
cliConf <- m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig
let noSpinner :: Bool
noSpinner = CliConfig -> Bool
_cliConfig_noSpinner CliConfig
cliConf
if Bool
noSpinner
then Severity -> Text -> m ()
forall (m :: * -> *). CliLog m => Severity -> Text -> m ()
putLog Severity
Notice Text
msg m () -> m a -> m a
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m a
action
else m [ThreadId]
-> ([ThreadId] -> Maybe a -> m ()) -> ([ThreadId] -> m a) -> m a
forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c
bracket' m [ThreadId]
run [ThreadId] -> Maybe a -> m ()
forall (m :: * -> *) (t :: * -> *).
(MonadIO m, Foldable t, MonadLog Output m, HasCliConfig m) =>
t ThreadId -> Maybe a -> m ()
cleanup (([ThreadId] -> m a) -> m a) -> ([ThreadId] -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ m a -> [ThreadId] -> m a
forall a b. a -> b -> a
const m a
action
where
run :: m [ThreadId]
run = do
CliConfig
cliConf <- m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig
(([Bool], [TerminalString]) -> (([Bool], [TerminalString]), Bool))
-> m Bool
forall (m :: * -> *) b.
(MonadIO m, HasCliConfig m) =>
(([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b))
-> m b
modifyStack ([Bool], [TerminalString]) -> (([Bool], [TerminalString]), Bool)
pushSpinner m Bool -> (Bool -> m [ThreadId]) -> m [ThreadId]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
True -> do
ThreadId
ctrleThread <- IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ CliConfig -> String -> IO ()
allowUserToMakeLoggingVerbose CliConfig
cliConf String
enquiryCode
let theme :: CliTheme
theme = CliConfig -> CliTheme
_cliConfig_theme CliConfig
cliConf
spinner :: [TerminalString]
spinner = SpinnerTheme -> [TerminalString]
coloredSpinner (SpinnerTheme -> [TerminalString])
-> SpinnerTheme -> [TerminalString]
forall a b. (a -> b) -> a -> b
$ CliTheme -> SpinnerTheme
_cliTheme_spinner CliTheme
theme
ThreadId
spinnerThread <- IO ThreadId -> m ThreadId
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ThreadId -> m ThreadId) -> IO ThreadId -> m ThreadId
forall a b. (a -> b) -> a -> b
$ IO () -> IO ThreadId
forkIO (IO () -> IO ThreadId) -> IO () -> IO ThreadId
forall a b. (a -> b) -> a -> b
$ [TerminalString] -> (TerminalString -> IO ()) -> IO ()
forall (m :: * -> *).
MonadIO m =>
[TerminalString] -> (TerminalString -> m ()) -> m ()
runSpinner [TerminalString]
spinner ((TerminalString -> IO ()) -> IO ())
-> (TerminalString -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ \c :: TerminalString
c -> do
[TerminalString]
logs <- CliTheme -> TerminalString -> [TerminalString] -> [TerminalString]
renderSpinnerStack CliTheme
theme TerminalString
c ([TerminalString] -> [TerminalString])
-> (([Bool], [TerminalString]) -> [TerminalString])
-> ([Bool], [TerminalString])
-> [TerminalString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Bool], [TerminalString]) -> [TerminalString]
forall a b. (a, b) -> b
snd (([Bool], [TerminalString]) -> [TerminalString])
-> IO ([Bool], [TerminalString]) -> IO [TerminalString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IORef ([Bool], [TerminalString]) -> IO ([Bool], [TerminalString])
forall a. IORef a -> IO a
readIORef (CliConfig -> IORef ([Bool], [TerminalString])
_cliConfig_spinnerStack CliConfig
cliConf)
CliConfig -> Output -> IO ()
forall (m :: * -> *). MonadIO m => CliConfig -> Output -> m ()
handleLog CliConfig
cliConf (Output -> IO ()) -> Output -> IO ()
forall a b. (a -> b) -> a -> b
$ [TerminalString] -> Output
Output_Overwrite [TerminalString]
logs
[ThreadId] -> m [ThreadId]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [ThreadId
ctrleThread, ThreadId
spinnerThread]
False ->
[ThreadId] -> m [ThreadId]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
cleanup :: t ThreadId -> Maybe a -> m ()
cleanup tids :: t ThreadId
tids resultM :: Maybe a
resultM = do
IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (ThreadId -> IO ()) -> t ThreadId -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ThreadId -> IO ()
killThread t ThreadId
tids
Output -> m ()
forall message (m :: * -> *). MonadLog message m => message -> m ()
logMessage Output
Output_ClearLine
CliConfig
cliConf <- m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig
let theme :: CliTheme
theme = CliConfig -> CliTheme
_cliConfig_theme CliConfig
cliConf
Maybe [TerminalString]
logsM <- (([Bool], [TerminalString])
-> (([Bool], [TerminalString]), Maybe [TerminalString]))
-> m (Maybe [TerminalString])
forall (m :: * -> *) b.
(MonadIO m, HasCliConfig m) =>
(([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b))
-> m b
modifyStack ((([Bool], [TerminalString])
-> (([Bool], [TerminalString]), Maybe [TerminalString]))
-> m (Maybe [TerminalString]))
-> (([Bool], [TerminalString])
-> (([Bool], [TerminalString]), Maybe [TerminalString]))
-> m (Maybe [TerminalString])
forall a b. (a -> b) -> a -> b
$ CliTheme
-> (TerminalString, Maybe Text)
-> ([Bool], [TerminalString])
-> (([Bool], [TerminalString]), Maybe [TerminalString])
popSpinner CliTheme
theme ((TerminalString, Maybe Text)
-> ([Bool], [TerminalString])
-> (([Bool], [TerminalString]), Maybe [TerminalString]))
-> (TerminalString, Maybe Text)
-> ([Bool], [TerminalString])
-> (([Bool], [TerminalString]), Maybe [TerminalString])
forall a b. (a -> b) -> a -> b
$ case Maybe a
resultM of
Nothing ->
( Color -> Text -> TerminalString
TerminalString_Colorized Color
Red (Text -> TerminalString) -> Text -> TerminalString
forall a b. (a -> b) -> a -> b
$ CliTheme -> Text
_cliTheme_failed (CliTheme -> Text) -> CliTheme -> Text
forall a b. (a -> b) -> a -> b
$ CliConfig -> CliTheme
_cliConfig_theme CliConfig
cliConf
, Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg
)
Just result :: a
result ->
( Color -> Text -> TerminalString
TerminalString_Colorized Color
Green (Text -> TerminalString) -> Text -> TerminalString
forall a b. (a -> b) -> a -> b
$ CliTheme -> Text
_cliTheme_done (CliTheme -> Text) -> CliTheme -> Text
forall a b. (a -> b) -> a -> b
$ CliConfig -> CliTheme
_cliConfig_theme CliConfig
cliConf
, Maybe (a -> Text)
mkTrail Maybe (a -> Text) -> Maybe a -> Maybe Text
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
)
Maybe [TerminalString] -> ([TerminalString] -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [TerminalString]
logsM (([TerminalString] -> m ()) -> m ())
-> ([TerminalString] -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ Output -> m ()
forall message (m :: * -> *). MonadLog message m => message -> m ()
logMessage (Output -> m ())
-> ([TerminalString] -> Output) -> [TerminalString] -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TerminalString] -> Output
Output_Write
pushSpinner :: ([Bool], [TerminalString]) -> (([Bool], [TerminalString]), Bool)
pushSpinner (flag :: [Bool]
flag, old :: [TerminalString]
old) =
( (Bool
isTemporary Bool -> [Bool] -> [Bool]
forall a. a -> [a] -> [a]
: [Bool]
flag, Text -> TerminalString
TerminalString_Normal Text
msg TerminalString -> [TerminalString] -> [TerminalString]
forall a. a -> [a] -> [a]
: [TerminalString]
old)
, [TerminalString] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TerminalString]
old
)
where
isTemporary :: Bool
isTemporary = Maybe (a -> Text) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (a -> Text)
mkTrail
popSpinner :: CliTheme
-> (TerminalString, Maybe Text)
-> ([Bool], [TerminalString])
-> (([Bool], [TerminalString]), Maybe [TerminalString])
popSpinner theme :: CliTheme
theme (mark :: TerminalString
mark, trailMsgM :: Maybe Text
trailMsgM) (flag :: [Bool]
flag, old :: [TerminalString]
old) =
( ([Bool]
newFlag, [TerminalString]
new)
, CliTheme -> TerminalString -> [TerminalString] -> [TerminalString]
renderSpinnerStack CliTheme
theme TerminalString
mark ([TerminalString] -> [TerminalString])
-> (Text -> [TerminalString]) -> Text -> [TerminalString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TerminalString -> [TerminalString] -> [TerminalString]
forall a. a -> [a] -> [a]
: [TerminalString]
new) (TerminalString -> [TerminalString])
-> (Text -> TerminalString) -> Text -> [TerminalString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> TerminalString
TerminalString_Normal (Text -> [TerminalString]) -> Maybe Text -> Maybe [TerminalString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (
if Bool
inTemporarySpinner then Maybe Text
forall a. Maybe a
Nothing else Maybe Text
trailMsgM
)
)
where
inTemporarySpinner :: Bool
inTemporarySpinner = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
newFlag
newFlag :: [Bool]
newFlag = Int -> [Bool] -> [Bool]
forall a. Int -> [a] -> [a]
drop 1 [Bool]
flag
new :: [TerminalString]
new = TerminalString -> [TerminalString] -> [TerminalString]
forall a. Eq a => a -> [a] -> [a]
L.delete (Text -> TerminalString
TerminalString_Normal Text
msg) [TerminalString]
old
modifyStack :: (([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b))
-> m b
modifyStack f :: ([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b)
f = IO b -> m b
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO b -> m b)
-> (IORef ([Bool], [TerminalString]) -> IO b)
-> IORef ([Bool], [TerminalString])
-> m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IORef ([Bool], [TerminalString])
-> (([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b))
-> IO b)
-> (([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b))
-> IORef ([Bool], [TerminalString])
-> IO b
forall a b c. (a -> b -> c) -> b -> a -> c
flip IORef ([Bool], [TerminalString])
-> (([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b))
-> IO b
forall a b. IORef a -> (a -> (a, b)) -> IO b
atomicModifyIORef' ([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b)
f
(IORef ([Bool], [TerminalString]) -> m b)
-> m (IORef ([Bool], [TerminalString])) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (CliConfig -> IORef ([Bool], [TerminalString]))
-> m CliConfig -> m (IORef ([Bool], [TerminalString]))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CliConfig -> IORef ([Bool], [TerminalString])
_cliConfig_spinnerStack m CliConfig
forall (m :: * -> *). HasCliConfig m => m CliConfig
getCliConfig
renderSpinnerStack
:: CliTheme
-> TerminalString
-> [TerminalString]
-> [TerminalString]
renderSpinnerStack :: CliTheme -> TerminalString -> [TerminalString] -> [TerminalString]
renderSpinnerStack theme :: CliTheme
theme mark :: TerminalString
mark = TerminalString -> [TerminalString] -> [TerminalString]
forall a. a -> [a] -> [a]
L.intersperse TerminalString
space ([TerminalString] -> [TerminalString])
-> ([TerminalString] -> [TerminalString])
-> [TerminalString]
-> [TerminalString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TerminalString] -> [TerminalString]
go ([TerminalString] -> [TerminalString])
-> ([TerminalString] -> [TerminalString])
-> [TerminalString]
-> [TerminalString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TerminalString] -> [TerminalString]
forall a. [a] -> [a]
L.reverse
where
go :: [TerminalString] -> [TerminalString]
go [] = []
go [x :: TerminalString
x] = TerminalString
mark TerminalString -> [TerminalString] -> [TerminalString]
forall a. a -> [a] -> [a]
: [TerminalString
x]
go (x :: TerminalString
x:xs :: [TerminalString]
xs) = TerminalString
arrow TerminalString -> [TerminalString] -> [TerminalString]
forall a. a -> [a] -> [a]
: TerminalString
x TerminalString -> [TerminalString] -> [TerminalString]
forall a. a -> [a] -> [a]
: [TerminalString] -> [TerminalString]
go [TerminalString]
xs
arrow :: TerminalString
arrow = Color -> Text -> TerminalString
TerminalString_Colorized Color
Blue (Text -> TerminalString) -> Text -> TerminalString
forall a b. (a -> b) -> a -> b
$ CliTheme -> Text
_cliTheme_arrow CliTheme
theme
space :: TerminalString
space = Text -> TerminalString
TerminalString_Normal " "
type Spinner = [TerminalString]
coloredSpinner :: SpinnerTheme -> Spinner
coloredSpinner :: SpinnerTheme -> [TerminalString]
coloredSpinner = [TerminalString] -> [TerminalString]
forall a. [a] -> [a]
cycle ([TerminalString] -> [TerminalString])
-> (SpinnerTheme -> [TerminalString])
-> SpinnerTheme
-> [TerminalString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> TerminalString) -> SpinnerTheme -> [TerminalString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Color -> Text -> TerminalString
TerminalString_Colorized Color
Cyan)
runSpinner :: MonadIO m => Spinner -> (TerminalString -> m ()) -> m ()
runSpinner :: [TerminalString] -> (TerminalString -> m ()) -> m ()
runSpinner spinner :: [TerminalString]
spinner f :: TerminalString -> m ()
f = [TerminalString] -> (TerminalString -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [TerminalString]
spinner ((TerminalString -> m ()) -> m ())
-> (TerminalString -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ TerminalString -> m ()
f (TerminalString -> m ()) -> (() -> m ()) -> TerminalString -> m ()
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> m () -> () -> m ()
forall a b. a -> b -> a
const m ()
delay
where
delay :: m ()
delay = IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay 100000
bracket' :: MonadMask m => m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c
bracket' :: m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c
bracket' acquire :: m a
acquire release :: a -> Maybe c -> m b
release use :: a -> m c
use = ((forall a. m a -> m a) -> m c) -> m c
forall (m :: * -> *) b.
MonadMask m =>
((forall a. m a -> m a) -> m b) -> m b
mask (((forall a. m a -> m a) -> m c) -> m c)
-> ((forall a. m a -> m a) -> m c) -> m c
forall a b. (a -> b) -> a -> b
$ \unmasked :: forall a. m a -> m a
unmasked -> do
a
resource <- m a
acquire
c
result <- m c -> m c
forall a. m a -> m a
unmasked (a -> m c
use a
resource) m c -> m b -> m c
forall (m :: * -> *) a b. MonadCatch m => m a -> m b -> m a
`onException` a -> Maybe c -> m b
release a
resource Maybe c
forall a. Maybe a
Nothing
b
_ <- a -> Maybe c -> m b
release a
resource (Maybe c -> m b) -> Maybe c -> m b
forall a b. (a -> b) -> a -> b
$ c -> Maybe c
forall a. a -> Maybe a
Just c
result
c -> m c
forall (m :: * -> *) a. Monad m => a -> m a
return c
result