@@ -1,16 +1,17 @@
11{-# LANGUAGE FlexibleContexts #-}
22{-# LANGUAGE MultiParamTypeClasses #-}
3+{-# LANGUAGE OverloadedStrings #-}
34module Obelisk.CLI.Spinner (withSpinner') where
45
56import Control.Concurrent (forkIO, killThread, threadDelay)
67import Control.Monad (forM_)
7−import Control.Monad.Catch (MonadMask, bracket)
8+import Control.Monad.Catch (MonadMask, mask, onException)
89import Control.Monad.IO.Class (liftIO)
910import Control.Monad.Log (MonadLog, logMessage, runLoggingT)
1011import Control.Monad.Reader (MonadIO)
1112import Data.Text (Text)
1213import qualified Data.Text as T
13−import System.Console.ANSI (Color (Magenta), ColorIntensity (Vivid), ConsoleLayer (Foreground),
14+import System.Console.ANSI (Color (Green, Magenta, Red), ColorIntensity (Vivid), ConsoleLayer (Foreground),
1415 SGR (Reset, SetColor), setSGRCode)
1516
1617import Obelisk.CLI.Logging (LoggingConfig, Output (..), handleLog)
@@ -20,17 +21,20 @@ import Obelisk.CLI.Logging (LoggingConfig, Output (..), handleLog)
2021withSpinner'
2122 :: (MonadIO m, MonadMask m, MonadLog Output m)
2223 => LoggingConfig -> Text -> m a -> m a
23−withSpinner' c s = bracket run cleanup . const
24+withSpinner' c s = bracket' run cleanup . const
2425 where
2526 -- TODO: Can we obviate passing LoggingConfig just to use forkIO?
2627 run = liftIO $ forkIO $ flip runLoggingT (handleLog c) $ do
27− forM_ (coloredSpinner spinnerPoint) $ \e -> do
28− logMessage $ Output_Raw ["\r", e, " ", T.unpack s]
28+ forM_ spin $ \e -> do
29+ logMessage $ Output_Overwrite [e, " ", T.unpack s]
2930 delay
30− cleanup tid = do
31+ cleanup failed tid = do
3132 liftIO $ killThread tid
3233 logMessage Output_ClearLine
34+ let mark = if failed then withColor Red "✖" else withColor Green "✔"
35+ logMessage $ Output_Overwrite [mark, " ", T.unpack s, "\n"]
3336 delay = liftIO $ threadDelay 100000 -- A shorter delay ensures that we update promptly.
37+ spin = coloredSpinner spinnerCircleHalves
3438
3539type Spinner = [String]
3640
@@ -38,27 +42,27 @@ spinner :: SpinnerTheme -> Spinner
3842spinner = cycle
3943
4044coloredSpinner :: SpinnerTheme -> Spinner
41−coloredSpinner = spinner . fmap withColor
42− where
43− withColor s = mconcat
44− [ setSGRCode [SetColor Foreground Vivid color]
45− , s
46− , setSGRCode [Reset]
47− ]
48− color = Magenta
45+coloredSpinner = spinner . fmap (withColor Magenta)
46+
47+withColor :: Color -> String -> String
48+withColor color s = mconcat
49+ [ setSGRCode [SetColor Foreground Vivid color]
50+ , s
51+ , setSGRCode [Reset]
52+ ]
53+
4954
5055-- Some spinners from https://github.com/sindresorhus/cli-spinners/blob/master/spinners.json
5156
5257type SpinnerTheme = [String]
5358
54−spinnerPoint :: SpinnerTheme
55−spinnerPoint =
56− [ "∙∙∙"
57− , "●∙∙"
58− , "∙●∙"
59− , "∙∙●"
60− , "∙∙∙"
61− ]
59+spinnerCircleHalves :: SpinnerTheme
60+spinnerCircleHalves = ["◐", "◓", "◑", "◒"]
6261
63−-- spinnerCircleHalves :: SpinnerTheme
64−-- spinnerCircleHalves = ["◐", "◓", "◑", "◒"]
62+-- | Like `bracket` but the `release` function can know whether an exception was raised
63+bracket' :: MonadMask m => m a -> (Bool -> a -> m b) -> (a -> m c) -> m c
64+bracket' acquire release use = mask $ \unmasked -> do
65+ resource <- acquire
66+ result <- unmasked (use resource) `onException` release True resource
67+ _ <- release False resource
68+ return result