module System.Console.Questioner.ProgressIndicators
where
import Control.Applicative ((<$>))
import Control.Concurrent
import Control.Monad (forever)
import Data.Maybe (fromMaybe)
import System.Console.ANSI (clearLine, setCursorColumn)
import System.Console.Terminal.Size (size, Window(..))
import System.IO (BufferMode(NoBuffering), stdout)
import System.Console.Questioner.Util
data ProgressIndicator = BarIndicator ThreadId (MVar Double)
| SpinnerIndicator ThreadId
stopIndicator :: ProgressIndicator -> IO ()
stopIndicator i = case i of
(BarIndicator tid _) -> stopProgressIndicator' tid
(SpinnerIndicator tid) -> stopProgressIndicator' tid
where
stopProgressIndicator' tid = do
killThread tid
clearLine
setCursorColumn 0
updateIndicator :: ProgressIndicator -> Double -> IO ()
updateIndicator (BarIndicator _ c) i = putMVar c i
updateIndicator _ _ = return ()
newtype ProgressBarTheme = ProgressBarTheme (Double -> IO ())
progressBar :: ProgressBarTheme -> IO ProgressIndicator
progressBar (ProgressBarTheme render) = do
mi <- newEmptyMVar
render 0
tid <- forkIO $ hWithBufferMode stdout NoBuffering $ forever $ do
i <- takeMVar mi
clearLine
setCursorColumn 0
render i
putMVar mi 0
return $ BarIndicator tid mi
type SpinnerTheme = String
spinner :: SpinnerTheme -> Int -> String -> IO ProgressIndicator
spinner theme interval prompt = SpinnerIndicator <$> forkIO (setup $ loop 0)
where
setup = hWithBufferMode stdout NoBuffering
loop i = do
clearLine
setCursorColumn 0
putStr $ ' ' : spinnerState i : ' ' : prompt
threadDelay interval
loop $ i + 1
themeLen = length theme
spinnerState i = theme !! (i `mod` themeLen)
simple1SpinnerTheme, simple2SpinnerTheme, simple3SpinnerTheme,
simple4SpinnerTheme, simple5SpinnerTheme, simple6SpinnerTheme,
simple7SpinnerTheme, simple8SpinnerTheme, simple9SpinnerTheme,
dots1SpinnerTheme, dots2SpinnerTheme, dots3SpinnerTheme, dots4SpinnerTheme,
dots5SpinnerTheme, dots6SpinnerTheme, dots7SpinnerTheme :: SpinnerTheme
simple1Spinner, simple2Spinner, simple3Spinner, simple4Spinner, simple5Spinner,
simple6Spinner, simple7Spinner, simple8Spinner, simple9Spinner, dots1Spinner,
dots2Spinner, dots3Spinner, dots4Spinner, dots5Spinner, dots6Spinner,
dots7Spinner :: Int -> String -> IO ProgressIndicator
simple1SpinnerTheme = "|/-\\"
simple2SpinnerTheme = "◴◷◶◵"
simple3SpinnerTheme = "◰◳◲◱"
simple4SpinnerTheme = "◐◓◑◒"
simple5SpinnerTheme = "▉▊▋▌▍▎▏▎▍▌▋▊▉"
simple6SpinnerTheme = "▌▄▐▀"
simple7SpinnerTheme = "╫╪"
simple8SpinnerTheme = "■□▪▫"
simple9SpinnerTheme = "←↑→↓"
simple1Spinner = spinner simple1SpinnerTheme
simple2Spinner = spinner simple2SpinnerTheme
simple3Spinner = spinner simple3SpinnerTheme
simple4Spinner = spinner simple4SpinnerTheme
simple5Spinner = spinner simple5SpinnerTheme
simple6Spinner = spinner simple6SpinnerTheme
simple7Spinner = spinner simple7SpinnerTheme
simple8Spinner = spinner simple8SpinnerTheme
simple9Spinner = spinner simple9SpinnerTheme
dots1SpinnerTheme = "⠋⠙⠹⠸⠼⠴⠦⠧⠇⠏"
dots2SpinnerTheme = "⠋⠙⠹⠸⠼⠴⠦⠧⠇⠏"
dots3SpinnerTheme = "⠄⠆⠇⠋⠙⠸⠰⠠⠰⠸⠙⠋⠇⠆"
dots4SpinnerTheme = "⠋⠙⠚⠒⠂⠂⠒⠲⠴⠦⠖⠒⠐⠐⠒⠓⠋"
dots5SpinnerTheme = "⠁⠉⠙⠚⠒⠂⠂⠒⠲⠴⠤⠄⠄⠤⠴⠲⠒⠂⠂⠒⠚⠙⠉⠁"
dots6SpinnerTheme = "⠈⠉⠋⠓⠒⠐⠐⠒⠖⠦⠤⠠⠠⠤⠦⠖⠒⠐⠐⠒⠓⠋⠉⠈"
dots7SpinnerTheme = "⠁⠁⠉⠙⠚⠒⠂⠂⠒⠲⠴⠤⠄⠄⠤⠠⠠⠤⠦⠖⠒⠐⠐⠒⠓⠋⠉⠈⠈"
dots1Spinner = spinner dots1SpinnerTheme
dots2Spinner = spinner dots2SpinnerTheme
dots3Spinner = spinner dots3SpinnerTheme
dots4Spinner = spinner dots4SpinnerTheme
dots5Spinner = spinner dots5SpinnerTheme
dots6Spinner = spinner dots6SpinnerTheme
dots7Spinner = spinner dots7SpinnerTheme
simpleProgressBarTheme :: ProgressBarTheme
simpleProgressBarTheme = ProgressBarTheme $ \i -> do
w <- fromMaybe (45 :: Int) <$> (fmap width <$> size)
let blocks = floor ((fromIntegral w :: Double) * i) 3
putStr (replicate blocks '▉')
simpleProgressBar :: IO ProgressIndicator
simpleProgressBar = progressBar simpleProgressBarTheme