git.iko.soy/obelisk
on decrease-android-validity help sign in
obelisk/lib/cliapp/src/Obelisk/CliApp/Spinner.hs
146 lines 5.9 kB history raw
1{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE LambdaCase #-}
3{-# LANGUAGE MultiParamTypeClasses #-}
4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE ScopedTypeVariables #-}
6{-# LANGUAGE TupleSections #-}
7-- | Provides a simple CLI spinner that interoperates cleanly with the rest of the logging output.
8module Obelisk.CliApp.Spinner
9 ( withSpinner
10 , withSpinnerNoTrail
11 , withSpinner'
12 ) where
14import Control.Concurrent (killThread, threadDelay)
15import Control.Monad (forM_, (>=>))
16import Control.Monad.Catch (MonadMask, mask, onException)
17import Control.Monad.IO.Class
18import Control.Monad.Log (Severity (..), logMessage)
19import Data.IORef
20import qualified Data.List as L
21import Data.Maybe (isNothing)
22import Data.Text (Text)
23import System.Console.ANSI (Color (Blue, Cyan, Green, Red))
25import Obelisk.CliApp.Logging (allowUserToMakeLoggingVerbose, fork, putLog)
26import Obelisk.CliApp.TerminalString (TerminalString (..), enquiryCode)
27import Obelisk.CliApp.Theme
28import Obelisk.CliApp.Types (CliLog, CliConfig (..), HasCliConfig, Output (..), getCliConfig)
30-- | Run an action with a CLI spinner.
31withSpinner
32 :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)
33 => Text -> m a -> m a
34withSpinner s = withSpinner' s $ Just $ const s
36-- | A spinner that leaves no trail after a successful run.
37--
38-- Use if you wish the spinner to be ephemerally visible to the user.
39--
40-- The 'no trail' property automatically carries over to sub-spinners (in that
41-- they won't leave a trail either).
42withSpinnerNoTrail
43 :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)
44 => Text -> m a -> m a
45withSpinnerNoTrail s = withSpinner' s Nothing
47-- | Advanced version that controls the display and content of the trail message.
48withSpinner'
49 :: (MonadIO m, MonadMask m, CliLog m, HasCliConfig e m)
50 => Text
51 -> Maybe (a -> Text) -- ^ Leave an optional trail with the given message creator
52 -> m a
53 -> m a
54withSpinner' msg mkTrail action = do
55 cliConf <- getCliConfig
56 let noSpinner = _cliConfig_noSpinner cliConf
57 if noSpinner
58 then putLog Notice msg >> action
59 else bracket' run cleanup $ const action
60 where
61 run = do
62 -- Add this log to the spinner stack, and start a spinner if it is top-level.
63 modifyStack pushSpinner >>= \case
64 True -> do -- Top-level spinner; fork a thread to manage output of anything on the stack
65 ctrleThread <- fork $ allowUserToMakeLoggingVerbose enquiryCode
66 cliConf <- getCliConfig
67 let theme = _cliConfig_theme cliConf
68 spinner = coloredSpinner $ _cliTheme_spinner theme
69 spinnerThread <- fork $ runSpinner spinner $ \c -> do
70 logs <- renderSpinnerStack theme c . snd <$> readStack
71 logMessage $ Output_Overwrite logs
72 pure [ctrleThread, spinnerThread]
73 False -> -- Sub-spinner; nothing to do.
74 pure []
75 cleanup tids resultM = do
76 liftIO $ mapM_ killThread tids
77 logMessage Output_ClearLine
78 cliConf <- getCliConfig
79 let theme = _cliConfig_theme cliConf
80 logsM <- modifyStack $ (popSpinner theme) $ case resultM of
81 Nothing ->
82 ( TerminalString_Colorized Red $ _cliTheme_failed $ _cliConfig_theme cliConf
83 , Just msg -- Always display final message if there was an exception.
84 )
85 Just result ->
86 ( TerminalString_Colorized Green $ _cliTheme_done $ _cliConfig_theme cliConf
87 , mkTrail <*> pure result
88 )
89 -- Last message, finish off with newline.
90 forM_ logsM $ logMessage . Output_Write
91 pushSpinner (flag, old) =
92 ( (isTemporary : flag, TerminalString_Normal msg : old)
93 , null old -- Is empty?
94 )
95 where
96 isTemporary = isNothing mkTrail
97 popSpinner theme (mark, trailMsgM) (flag, old) =
98 ( (newFlag, new)
99 -- With final trail spinner message to render
100 , renderSpinnerStack theme mark . (: new) . TerminalString_Normal <$> (
101 if inTemporarySpinner then Nothing else trailMsgM
102 )
103 )
104 where
105 inTemporarySpinner = or newFlag -- One of our parent spinners is temporary
106 newFlag = drop 1 flag
107 new = L.delete (TerminalString_Normal msg) old
108 readStack = liftIO . readIORef
109 =<< fmap _cliConfig_spinnerStack getCliConfig
110 modifyStack f = liftIO . flip atomicModifyIORef' f
111 =<< fmap _cliConfig_spinnerStack getCliConfig
113-- | How nested spinner logs should be displayed
114renderSpinnerStack
115 :: CliTheme
116 -> TerminalString -- ^ That which comes before the final element in stack
117 -> [TerminalString] -- ^ Spinner elements in reverse order
118 -> [TerminalString]
119renderSpinnerStack theme mark = L.intersperse space . go . L.reverse
120 where
121 go [] = []
122 go (x:[]) = mark : [x]
123 go (x:xs) = arrow : x : go xs
124 arrow = TerminalString_Colorized Blue $ _cliTheme_arrow theme
125 space = TerminalString_Normal " "
127-- | A spinner is simply an infinite list of strings that supplant each other in a delayed loop, creating the
128-- animation of a "spinner".
129type Spinner = [TerminalString]
131coloredSpinner :: SpinnerTheme -> Spinner
132coloredSpinner = cycle . fmap (TerminalString_Colorized Cyan)
134-- | Run a spinner with a monadic function that defines how to represent the individual spinner characters.
135runSpinner :: MonadIO m => Spinner -> (TerminalString -> m ()) -> m ()
136runSpinner spinner f = forM_ spinner $ f >=> const delay
137 where
138 delay = liftIO $ threadDelay 100000 -- A shorter delay ensures that we update promptly.
140-- | Like `bracket` but the `release` function can know whether an exception was raised
141bracket' :: MonadMask m => m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c
142bracket' acquire release use = mask $ \unmasked -> do
143 resource <- acquire
144 result <- unmasked (use resource) `onException` release resource Nothing
145 _ <- release resource $ Just result
146 return result