{-# 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 (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, fork, putLog)
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 e m)
  => Text -> m a -> m a
withSpinner :: forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
Text -> m a -> m a
withSpinner Text
s = Text -> Maybe (a -> Text) -> m a -> m a
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e 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 e m)
  => Text -> m a -> m a
withSpinnerNoTrail :: forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
Text -> m a -> m a
withSpinnerNoTrail Text
s = Text -> Maybe (a -> Text) -> m a -> m a
forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e 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 e m)
  => Text
  -> Maybe (a -> Text) -- ^ Leave an optional trail with the given message creator
  -> m a
  -> m a
withSpinner' :: forall (m :: * -> *) e a.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
Text -> Maybe (a -> Text) -> m a -> m a
withSpinner' Text
msg Maybe (a -> Text)
mkTrail m a
action = do
  cliConf <- m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
  let noSpinner = CliConfig e -> Bool
forall e. CliConfig e -> Bool
_cliConfig_noSpinner CliConfig e
cliConf
  if noSpinner
    then putLog Notice msg >> action
    else bracket' run cleanup $ const action
  where
    run :: m [ThreadId]
run = do
      -- Add this log to the spinner stack, and start a spinner if it is top-level.
      (([Bool], [TerminalString]) -> (([Bool], [TerminalString]), Bool))
-> m Bool
forall {m :: * -> *} {e} {b}.
(MonadIO m, HasCliConfig e m) =>
(([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b))
-> m b
modifyStack ([Bool], [TerminalString]) -> (([Bool], [TerminalString]), Bool)
pushSpinner m Bool -> (Bool -> m [ThreadId]) -> m [ThreadId]
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True -> do -- Top-level spinner; fork a thread to manage output of anything on the stack
          ctrleThread <- CliT e IO () -> m ThreadId
forall e (m :: * -> *).
(HasCliConfig e m, MonadIO m) =>
CliT e IO () -> m ThreadId
fork (CliT e IO () -> m ThreadId) -> CliT e IO () -> m ThreadId
forall a b. (a -> b) -> a -> b
$ String -> Text -> CliT e IO ()
forall (m :: * -> *) e.
(MonadIO m, MonadMask m, CliLog m, HasCliConfig e m) =>
String -> Text -> m ()
allowUserToMakeLoggingVerbose String
enquiryCode Text
"Ctrl+E"
          cliConf <- getCliConfig
          let theme = CliConfig e -> CliTheme
forall e. CliConfig e -> CliTheme
_cliConfig_theme CliConfig e
cliConf
              spinner = SpinnerTheme -> [TerminalString]
coloredSpinner (SpinnerTheme -> [TerminalString])
-> SpinnerTheme -> [TerminalString]
forall a b. (a -> b) -> a -> b
$ CliTheme -> SpinnerTheme
_cliTheme_spinner CliTheme
theme
          spinnerThread <- fork $ runSpinner spinner $ \TerminalString
c -> do
            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])
-> CliT e IO ([Bool], [TerminalString])
-> CliT e IO [TerminalString]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CliT e IO ([Bool], [TerminalString])
readStack
            logMessage $ Output_Overwrite logs
          pure [ctrleThread, spinnerThread]
        Bool
False -> -- Sub-spinner; nothing to do.
          [ThreadId] -> m [ThreadId]
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    cleanup :: t ThreadId -> Maybe a -> m ()
cleanup t ThreadId
tids Maybe a
resultM = do
      IO () -> m ()
forall a. IO a -> m a
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
      cliConf <- m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
      let theme = CliConfig e -> CliTheme
forall e. CliConfig e -> CliTheme
_cliConfig_theme CliConfig e
cliConf
      logsM <- modifyStack $ (popSpinner theme) $ case resultM of
        Maybe a
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 e -> CliTheme
forall e. CliConfig e -> CliTheme
_cliConfig_theme CliConfig e
cliConf
          , Text -> Maybe Text
forall a. a -> Maybe a
Just Text
msg  -- Always display final message if there was an exception.
          )
        Just 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 e -> CliTheme
forall e. CliConfig e -> CliTheme
_cliConfig_theme CliConfig e
cliConf
          , Maybe (a -> Text)
mkTrail Maybe (a -> Text) -> Maybe a -> Maybe Text
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> Maybe a
forall a. a -> Maybe a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
result
          )
      -- Last message, finish off with newline.
      forM_ logsM $ logMessage . Output_Write
    pushSpinner :: ([Bool], [TerminalString]) -> (([Bool], [TerminalString]), Bool)
pushSpinner ([Bool]
flag, [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 a. [a] -> 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 CliTheme
theme (TerminalString
mark, Maybe Text
trailMsgM) ([Bool]
flag, [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 Int
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
    readStack :: CliT e IO ([Bool], [TerminalString])
readStack = IO ([Bool], [TerminalString])
-> CliT e IO ([Bool], [TerminalString])
forall a. IO a -> CliT e IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ([Bool], [TerminalString])
 -> CliT e IO ([Bool], [TerminalString]))
-> (IORef ([Bool], [TerminalString])
    -> IO ([Bool], [TerminalString]))
-> IORef ([Bool], [TerminalString])
-> CliT e IO ([Bool], [TerminalString])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IORef ([Bool], [TerminalString]) -> IO ([Bool], [TerminalString])
forall a. IORef a -> IO a
readIORef
      (IORef ([Bool], [TerminalString])
 -> CliT e IO ([Bool], [TerminalString]))
-> CliT e IO (IORef ([Bool], [TerminalString]))
-> CliT e IO ([Bool], [TerminalString])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (CliConfig e -> IORef ([Bool], [TerminalString]))
-> CliT e IO (CliConfig e)
-> CliT e IO (IORef ([Bool], [TerminalString]))
forall a b. (a -> b) -> CliT e IO a -> CliT e IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CliConfig e -> IORef ([Bool], [TerminalString])
forall e. CliConfig e -> IORef ([Bool], [TerminalString])
_cliConfig_spinnerStack CliT e IO (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
getCliConfig
    modifyStack :: (([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b))
-> m b
modifyStack ([Bool], [TerminalString]) -> (([Bool], [TerminalString]), b)
f = IO b -> m b
forall a. IO a -> m a
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 e -> IORef ([Bool], [TerminalString]))
-> m (CliConfig e) -> m (IORef ([Bool], [TerminalString]))
forall a b. (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CliConfig e -> IORef ([Bool], [TerminalString])
forall e. CliConfig e -> IORef ([Bool], [TerminalString])
_cliConfig_spinnerStack m (CliConfig e)
forall e (m :: * -> *). HasCliConfig e m => m (CliConfig e)
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 CliTheme
theme 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 [TerminalString
x] = TerminalString
mark TerminalString -> [TerminalString] -> [TerminalString]
forall a. a -> [a] -> [a]
: [TerminalString
x]
    go (TerminalString
x:[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 Text
" "

-- | 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. HasCallStack => [a] -> [a]
cycle ([TerminalString] -> [TerminalString])
-> (SpinnerTheme -> [TerminalString])
-> SpinnerTheme
-> [TerminalString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text -> TerminalString) -> SpinnerTheme -> [TerminalString]
forall a b. (a -> b) -> [a] -> [b]
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 :: forall (m :: * -> *).
MonadIO m =>
[TerminalString] -> (TerminalString -> m ()) -> m ()
runSpinner [TerminalString]
spinner 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 a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
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' :: forall (m :: * -> *) a c b.
MonadMask m =>
m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c
bracket' m a
acquire a -> Maybe c -> m b
release a -> m c
use = ((forall a. m a -> m a) -> m c) -> m c
forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b
forall (m :: * -> *) b.
(MonadMask m, HasCallStack) =>
((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
$ \forall a. m a -> m a
unmasked -> do
  resource <- m a
acquire
  result <- unmasked (use resource) `onException` release resource Nothing
  _ <- release resource $ Just result
  return result