Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 53 lines (42 sloc) 1.301 kb
f95167a Lennart Kolmodin Add missing BlingBling
kolmodin authored
1 module BlingBling where
2
29815fc Duncan Coutts can I has teh bling?
dcoutts authored
3 import qualified Progress
4
f95167a Lennart Kolmodin Add missing BlingBling
kolmodin authored
5 import System.IO
29815fc Duncan Coutts can I has teh bling?
dcoutts authored
6 import Control.Exception as Exception (bracket)
f95167a Lennart Kolmodin Add missing BlingBling
kolmodin authored
7
8 -- what nobody needs but everyone wants...
9
10 -- FIXME: do something more fun here
87d875b Lennart Kolmodin Wall police
kolmodin authored
11 forMbling :: [a] -> (a -> IO b) -> IO [b]
29815fc Duncan Coutts can I has teh bling?
dcoutts authored
12 forMbling lst f =
13 withBuffering stdout NoBuffering $ do
f95167a Lennart Kolmodin Add missing BlingBling
kolmodin authored
14 xs <- mapM (\x -> putStr "." >> f x) lst
15 putStrLn ""
16 return xs
29815fc Duncan Coutts can I has teh bling?
dcoutts authored
17
18 blingProgress :: Progress.Progress s String a -> IO a
19 blingProgress progress = do
20 isTerm <- hIsTerminalDevice stdout
21 if isTerm
22 then canIHasTehBling
23 else boring
24
25 where
26 boring = Progress.fold (flip const) fail return progress
27
28 canIHasTehBling =
29 withBuffering stdout NoBuffering $ do
30 putChar (fst (char 0))
31 result <- spin 0 progress
32 putStr "\b \b"
33 return result
34
35 spin _ (Progress.Fail e) = fail e
36 spin _ (Progress.Done r) = return r
37 spin n (Progress.Step _ p) = do
38 putStr ['\b', c]
39 spin n' p
40 where (c, n') = char n
41
42 char :: Int -> (Char, Int)
43 char 0 = ('/', 1)
44 char 1 = ('-', 2)
45 char 2 = ('\\', 3)
46 char _ = ('|', 0)
47
48 withBuffering :: Handle -> BufferMode -> IO a -> IO a
49 withBuffering hnd mode action =
50 Exception.bracket
51 (hGetBuffering hnd) (hSetBuffering hnd)
52 (\_ -> hSetBuffering hnd mode >> action)
Something went wrong with that request. Please try again.