{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
-- | Provides a simple CLI spinner that interoperates cleanly with the rest of the logging output.
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)

-- | Run an action with a CLI spinner.
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

-- | A spinner that leaves no trail after a successful run.
--
-- Use if you wish the spinner to be ephemerally visible to the user.
--
-- The 'no trail' property automatically carries over to sub-spinners (in that
-- they won't leave a trail either).
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

-- | Advanced version that controls the display and content of the trail message.
withSpinner'
  :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig m)
  => Text
  -> Maybe (a -> Text) -- ^ Leave an optional trail with the given message creator
  -> 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
      -- Add this log to the spinner stack, and start a spinner if it is top-level.
      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 -- Top-level spinner; fork a thread to manage output of anything on the stack
          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 -> -- Sub-spinner; nothing to do.
          [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  -- Always display final message if there was an exception.
          )
        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
          )
      -- Last message, finish off with newline.
      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 -- Is empty?
      )
      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)
      -- With final trail spinner message to render
      , 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  -- One of our parent spinners is temporary
        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

-- | How nested spinner logs should be displayed
renderSpinnerStack
  :: CliTheme
  -> TerminalString  -- ^ That which comes before the final element in stack
  -> [TerminalString]  -- ^ Spinner elements in reverse order
  -> [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 " "

-- | A spinner is simply an infinite list of strings that supplant each other in a delayed loop, creating the
-- animation of a "spinner".
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)

-- | Run a spinner with a monadic function that defines how to represent the individual spinner characters.
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  -- A shorter delay ensures that we update promptly.

-- | Like `bracket` but the `release` function can know whether an exception was raised
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