@@ -21,10 +21,10 @@ import qualified Data.List as L
2121import Data.Maybe (isNothing)
2222import Data.Text (Text)
2323import System.Console.ANSI (Color (Blue, Cyan, Green, Red))
24−import System.IO (utf8, utf8_bom, utf16, utf16be, utf16le, utf32, utf32be, utf32le, TextEncoding)
2524
2625import Obelisk.CliApp.Logging (allowUserToMakeLoggingVerbose, fork, putLog)
2726import Obelisk.CliApp.TerminalString (TerminalString (..), enquiryCode)
27+import Obelisk.CliApp.Theme
2828import Obelisk.CliApp.Types (CliLog, CliConfig (..), HasCliConfig, Output (..), getCliConfig)
2929
3030-- | Run an action with a CLI spinner.
@@ -54,44 +54,38 @@ withSpinner'
5454withSpinner' msg mkTrail action = do
5555 cliConf <- getCliConfig
5656 let noSpinner = _cliConfig_noSpinner cliConf
57− mTextEncoding = _cliConfig_textEncoding cliConf
5857 if noSpinner
5958 then putLog Notice msg >> action
60− else bracket' (run mTextEncoding) (cleanup mTextEncoding) $ const action
59+ else bracket' run cleanup $ const action
6160 where
62− run mTextEncoding = do
61+ run = do
6362 -- Add this log to the spinner stack, and start a spinner if it is top-level.
6463 modifyStack pushSpinner >>= \case
6564 True -> do -- Top-level spinner; fork a thread to manage output of anything on the stack
6665 ctrleThread <- fork $ allowUserToMakeLoggingVerbose enquiryCode
67− spinnerThread <- fork $ runSpinner (spinner mTextEncoding) $ \c -> do
68− logs <- renderSpinnerStack mTextEncoding c . snd <$> readStack
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
6971 logMessage $ Output_Overwrite logs
7072 pure [ctrleThread, spinnerThread]
7173 False -> -- Sub-spinner; nothing to do.
7274 pure []
73− cleanup mTextEncoding tids resultM = do
75+ cleanup tids resultM = do
7476 liftIO $ mapM_ killThread tids
7577 logMessage Output_ClearLine
76− logsM <- modifyStack $ (popSpinner mTextEncoding) $ case resultM of
77− Nothing -> case mTextEncoding of
78− Just enc | supportUnicode enc ->
79− ( TerminalString_Colorized Red "✖"
80− , Just msg -- Always display final message if there was an exception.
81− )
82− _ ->
83− ( TerminalString_Colorized Red "FAILED"
84− , Just msg -- Always display final message if there was an exception.
85− )
86− Just result -> case mTextEncoding of
87− Just enc | supportUnicode enc ->
88− ( TerminalString_Colorized Green "✔"
89− , mkTrail <*> pure result
90− )
91− _ ->
92− ( TerminalString_Colorized Green "DONE"
93− , mkTrail <*> pure result
94− )
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+ )
9589 -- Last message, finish off with newline.
9690 forM_ logsM $ logMessage . Output_Write
9791 pushSpinner (flag, old) =
@@ -115,36 +109,19 @@ withSpinner' msg mkTrail action = do
115109 =<< fmap _cliConfig_spinnerStack getCliConfig
116110 modifyStack f = liftIO . flip atomicModifyIORef' f
117111 =<< fmap _cliConfig_spinnerStack getCliConfig
118− spinner mTextEncoding = case mTextEncoding of
119− Just enc | supportUnicode enc -> coloredSpinner defaultSpinnerTheme
120− _ -> coloredSpinner minimalSpinnerTheme
121−
122−supportUnicode :: TextEncoding -> Bool
123−supportUnicode enc = any ((show enc ==) . show)
124− [ utf8
125− , utf8_bom
126− , utf16
127− , utf16be
128− , utf16le
129− , utf32
130− , utf32be
131− , utf32le
132− ]
133112
134113-- | How nested spinner logs should be displayed
135114renderSpinnerStack
136− :: Maybe TextEncoding
115+ :: CliTheme
137116 -> TerminalString -- ^ That which comes before the final element in stack
138117 -> [TerminalString] -- ^ Spinner elements in reverse order
139118 -> [TerminalString]
140−renderSpinnerStack mTextEncoding mark = L.intersperse space . go . L.reverse
119+renderSpinnerStack theme mark = L.intersperse space . go . L.reverse
141120 where
142121 go [] = []
143122 go (x:[]) = mark : [x]
144123 go (x:xs) = arrow : x : go xs
145− arrow = case mTextEncoding of
146− Just enc | supportUnicode enc -> TerminalString_Colorized Blue "⇾"
147− _ -> TerminalString_Colorized Blue "->"
124+ arrow = TerminalString_Colorized Blue $ _cliTheme_arrow theme
148125 space = TerminalString_Normal " "
149126
150127-- | A spinner is simply an infinite list of strings that supplant each other in a delayed loop, creating the
@@ -160,27 +137,6 @@ runSpinner spinner f = forM_ spinner $ f >=> const delay
160137 where
161138 delay = liftIO $ threadDelay 100000 -- A shorter delay ensures that we update promptly.
162139
163−type SpinnerTheme = [Text]
164−
165−-- Find more spinners at https://github.com/sindresorhus/cli-spinners/blob/master/spinners.json
166−_spinnerSticks :: SpinnerTheme
167−_spinnerSticks = ["|", "/", "-", "\\"]
168−
169−spinnerStick :: SpinnerTheme
170−spinnerStick = ["|", "/", "-", "\\"]
171−
172−_spinnerCircleHalves :: SpinnerTheme
173−_spinnerCircleHalves = ["◐", "◓", "◑", "◒"]
174−
175−spinnerMoon :: SpinnerTheme
176−spinnerMoon = ["🌑", "🌒", "🌓", "🌔", "🌕", "🌖", "🌗", "🌘"]
177−
178−minimalSpinnerTheme :: SpinnerTheme
179−minimalSpinnerTheme = spinnerStick
180−
181−defaultSpinnerTheme :: SpinnerTheme
182−defaultSpinnerTheme = spinnerMoon
183−
184140-- | Like `bracket` but the `release` function can know whether an exception was raised
185141bracket' :: MonadMask m => m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c
186142bracket' acquire release use = mask $ \unmasked -> do