Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
tree: 29815fc4da
Fetching contributors…

Cannot retrieve contributors at this time

file 52 lines (42 sloc) 1.301 kb
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)
Something went wrong with that request. Please try again.