@@ -21,10 +21,10 @@ import qualified Data.List as L
21import Data.Maybe (isNothing)
21import Data.Maybe (isNothing)
22import Data.Text (Text)
22import Data.Text (Text)
23import System.Console.ANSI (Color (Blue, Cyan, Green, Red))
23import System.Console.ANSI (Color (Blue, Cyan, Green, Red))
24−import System.IO (utf8, utf8_bom, utf16, utf16be, utf16le, utf32, utf32be, utf32le, TextEncoding)
26import Obelisk.CliApp.Logging (allowUserToMakeLoggingVerbose, fork, putLog)
25import Obelisk.CliApp.Logging (allowUserToMakeLoggingVerbose, fork, putLog)
27import Obelisk.CliApp.TerminalString (TerminalString (..), enquiryCode)
26import Obelisk.CliApp.TerminalString (TerminalString (..), enquiryCode)
27+import Obelisk.CliApp.Theme
28import Obelisk.CliApp.Types (CliLog, CliConfig (..), HasCliConfig, Output (..), getCliConfig)
28import Obelisk.CliApp.Types (CliLog, CliConfig (..), HasCliConfig, Output (..), getCliConfig)
30-- | Run an action with a CLI spinner.
30-- | Run an action with a CLI spinner.
@@ -54,44 +54,38 @@ withSpinner'
54withSpinner' msg mkTrail action = do
54withSpinner' msg mkTrail action = do
55 cliConf <- getCliConfig
55 cliConf <- getCliConfig
56 let noSpinner = _cliConfig_noSpinner cliConf
56 let noSpinner = _cliConfig_noSpinner cliConf
57− mTextEncoding = _cliConfig_textEncoding cliConf
58 if noSpinner
57 if noSpinner
59 then putLog Notice msg >> action
58 then putLog Notice msg >> action
60− else bracket' (run mTextEncoding) (cleanup mTextEncoding) $ const action
59+ else bracket' run cleanup $ const action
62− run mTextEncoding = do
61+ run = do
63 -- Add this log to the spinner stack, and start a spinner if it is top-level.
62 -- Add this log to the spinner stack, and start a spinner if it is top-level.
64 modifyStack pushSpinner >>= \case
63 modifyStack pushSpinner >>= \case
65 True -> do -- Top-level spinner; fork a thread to manage output of anything on the stack
64 True -> do -- Top-level spinner; fork a thread to manage output of anything on the stack
66 ctrleThread <- fork $ allowUserToMakeLoggingVerbose enquiryCode
65 ctrleThread <- fork $ allowUserToMakeLoggingVerbose enquiryCode
66+ cliConf <- getCliConfig
67+ let theme = _cliConfig_theme cliConf
68+ spinner = coloredSpinner $ _cliTheme_spinner theme
67− spinnerThread <- fork $ runSpinner (spinner mTextEncoding) $ \c -> do
69+ spinnerThread <- fork $ runSpinner spinner $ \c -> do
68− logs <- renderSpinnerStack mTextEncoding c . snd <$> readStack
70+ logs <- renderSpinnerStack theme c . snd <$> readStack
69 logMessage $ Output_Overwrite logs
71 logMessage $ Output_Overwrite logs
70 pure [ctrleThread, spinnerThread]
72 pure [ctrleThread, spinnerThread]
71 False -> -- Sub-spinner; nothing to do.
73 False -> -- Sub-spinner; nothing to do.
73− cleanup mTextEncoding tids resultM = do
75+ cleanup tids resultM = do
74 liftIO $ mapM_ killThread tids
76 liftIO $ mapM_ killThread tids
75 logMessage Output_ClearLine
77 logMessage Output_ClearLine
78+ cliConf <- getCliConfig
79+ let theme = _cliConfig_theme cliConf
76− logsM <- modifyStack $ (popSpinner mTextEncoding) $ case resultM of
80+ logsM <- modifyStack $ (popSpinner theme) $ case resultM of
77− Nothing -> case mTextEncoding of
81+ Nothing ->
78− Just enc | supportUnicode enc ->
79− ( TerminalString_Colorized Red "✖"
82+ ( TerminalString_Colorized Red $ _cliTheme_failed $ _cliConfig_theme cliConf
80− , Just msg -- Always display final message if there was an exception.
83− ( TerminalString_Colorized Red "FAILED"
84− , Just msg -- Always display final message if there was an exception.
83+ , Just msg -- Always display final message if there was an exception.
86− Just result -> case mTextEncoding of
85+ Just result ->
87− Just enc | supportUnicode enc ->
88− ( TerminalString_Colorized Green "✔"
86+ ( TerminalString_Colorized Green $ _cliTheme_done $ _cliConfig_theme cliConf
89− , mkTrail <*> pure result
92− ( TerminalString_Colorized Green "DONE"
93− , mkTrail <*> pure result
87+ , mkTrail <*> pure result
95 -- Last message, finish off with newline.
89 -- Last message, finish off with newline.
96 forM_ logsM $ logMessage . Output_Write
90 forM_ logsM $ logMessage . Output_Write
97 pushSpinner (flag, old) =
91 pushSpinner (flag, old) =
@@ -115,36 +109,19 @@ withSpinner' msg mkTrail action = do
115 =<< fmap _cliConfig_spinnerStack getCliConfig
109 =<< fmap _cliConfig_spinnerStack getCliConfig
116 modifyStack f = liftIO . flip atomicModifyIORef' f
110 modifyStack f = liftIO . flip atomicModifyIORef' f
117 =<< fmap _cliConfig_spinnerStack getCliConfig
111 =<< fmap _cliConfig_spinnerStack getCliConfig
118− spinner mTextEncoding = case mTextEncoding of
119− Just enc | supportUnicode enc -> coloredSpinner defaultSpinnerTheme
120− _ -> coloredSpinner minimalSpinnerTheme
122−supportUnicode :: TextEncoding -> Bool
123−supportUnicode enc = any ((show enc ==) . show)
134-- | How nested spinner logs should be displayed
113-- | How nested spinner logs should be displayed
135renderSpinnerStack
114renderSpinnerStack
136− :: Maybe TextEncoding
115+ :: CliTheme
137 -> TerminalString -- ^ That which comes before the final element in stack
116 -> TerminalString -- ^ That which comes before the final element in stack
138 -> [TerminalString] -- ^ Spinner elements in reverse order
117 -> [TerminalString] -- ^ Spinner elements in reverse order
139 -> [TerminalString]
118 -> [TerminalString]
140−renderSpinnerStack mTextEncoding mark = L.intersperse space . go . L.reverse
119+renderSpinnerStack theme mark = L.intersperse space . go . L.reverse
142 go [] = []
121 go [] = []
143 go (x:[]) = mark : [x]
122 go (x:[]) = mark : [x]
144 go (x:xs) = arrow : x : go xs
123 go (x:xs) = arrow : x : go xs
145− arrow = case mTextEncoding of
146− Just enc | supportUnicode enc -> TerminalString_Colorized Blue "⇾"
124+ arrow = TerminalString_Colorized Blue $ _cliTheme_arrow theme
147− _ -> TerminalString_Colorized Blue "->"
148 space = TerminalString_Normal " "
125 space = TerminalString_Normal " "
150-- | A spinner is simply an infinite list of strings that supplant each other in a delayed loop, creating the
127-- | 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
161 delay = liftIO $ threadDelay 100000 -- A shorter delay ensures that we update promptly.
138 delay = liftIO $ threadDelay 100000 -- A shorter delay ensures that we update promptly.
163−type SpinnerTheme = [Text]
165−-- Find more spinners at https://github.com/sindresorhus/cli-spinners/blob/master/spinners.json
166−_spinnerSticks :: SpinnerTheme
167−_spinnerSticks = ["|", "/", "-", "\\"]
169−spinnerStick :: SpinnerTheme
170−spinnerStick = ["|", "/", "-", "\\"]
172−_spinnerCircleHalves :: SpinnerTheme
173−_spinnerCircleHalves = ["◐", "◓", "◑", "◒"]
175−spinnerMoon :: SpinnerTheme
176−spinnerMoon = ["🌑", "🌒", "🌓", "🌔", "🌕", "🌖", "🌗", "🌘"]
178−minimalSpinnerTheme :: SpinnerTheme
179−minimalSpinnerTheme = spinnerStick
181−defaultSpinnerTheme :: SpinnerTheme
182−defaultSpinnerTheme = spinnerMoon
184-- | Like `bracket` but the `release` function can know whether an exception was raised
140-- | Like `bracket` but the `release` function can know whether an exception was raised
185bracket' :: MonadMask m => m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c
141bracket' :: MonadMask m => m a -> (a -> Maybe c -> m b) -> (a -> m c) -> m c
186bracket' acquire release use = mask $ \unmasked -> do
142bracket' acquire release use = mask $ \unmasked -> do