-
Notifications
You must be signed in to change notification settings - Fork 21
/
BlingBling.hs
52 lines (42 loc) · 1.27 KB
/
BlingBling.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
module BlingBling where
import qualified Progress
import System.IO
import Control.Exception as Exception (bracket)
-- what nobody needs but everyone wants...
-- FIXME: do something more fun here
forMbling :: [a] -> (a -> IO b) -> IO [b]
forMbling lst f =
withBuffering stdout NoBuffering $ do
xs <- mapM (\x -> putStr "." >> f x) lst
putStrLn ""
return xs
blingProgress :: Progress.Progress s String a -> IO a
blingProgress progress = do
isTerm <- hIsTerminalDevice stdout
if isTerm
then canIHasTehBling
else boring
where
boring = Progress.fold (flip const) fail return progress
canIHasTehBling =
withBuffering stdout NoBuffering $ do
putChar (fst (char 0))
result <- spin 0 progress
putStr "\b \b"
return result
spin _ (Progress.Fail e) = fail e
spin _ (Progress.Done r) = return r
spin n (Progress.Step _ p) = do
putStr ['\b', c]
spin n' p
where (c, n') = char n
char :: Int -> (Char, Int)
char 0 = ('/', 1)
char 1 = ('-', 2)
char 2 = ('\\', 3)
char _ = ('|', 0)
withBuffering :: Handle -> BufferMode -> IO a -> IO a
withBuffering hnd mode action =
Exception.bracket
(hGetBuffering hnd) (hSetBuffering hnd)
(\_ -> hSetBuffering hnd mode >> action)