Merge pull request #5 from MichaelXavier/auto-display

Auto display

example.hs

@@ -9,11 +9,13 @@ import "base" Data.Int ( Int )
 import "base" Prelude ( (+) )
 import "base" System.IO ( IO, hSetBuffering, BufferMode(NoBuffering), stdout, putStrLn )
 import "base-unicode-symbols" Prelude.Unicode ( ℤ )
-import "terminal-progress-bar" System.ProgressBar ( progressBar, percentage, exact )
+import "terminal-progress-bar" System.ProgressBar ( progressBar, percentage, exact, startProgress, incProgress )
 
 
 main ∷ IO ()
-main = example 60 (13 + 60) 25000
+main = do
+  example 60 (13 + 60) 25000
+  example' 60 (13 + 60) 25000
 
 example ∷ ℤ → ℤ → Int → IO ()
 example t w delay = do
@@ -23,3 +25,12 @@ example t w delay = do
       threadDelay delay
     putStrLn ""
 
+example' ∷ ℤ → ℤ → Int → IO ()
+example' t w delay = do
+    hSetBuffering stdout NoBuffering
+    (pr, _) <- startProgress percentage exact w t
+    forM_ [1..t] $ \d → do
+      incProgress pr 1
+      threadDelay delay
+    putStrLn ""
+

src/System/ProgressBar.hs

@@ -1,4 +1,4 @@
-{-# LANGUAGE NoImplicitPrelude, PackageImports, UnicodeSyntax #-}
+{-# LANGUAGE NoImplicitPrelude, PackageImports, NamedFieldPuns, RecordWildCards, UnicodeSyntax #-}
 
 module System.ProgressBar
     ( -- * Progress bars
@@ -10,18 +10,27 @@ module System.ProgressBar
     , msg
     , percentage
     , exact
+    -- * auto-printing
+    , ProgressRef
+    , startProgress
+    , incProgress
     ) where
 
+import "base" Control.Monad ( (=<<), (>>), return, when )
 import "base" Data.Bool     ( otherwise )
-import "base" Data.Function ( ($) )
+import "base" Data.Function ( ($), (.) )
 import "base" Data.List     ( null, length, genericLength, genericReplicate )
-import "base" Data.Ord      ( min, max )
+import "base" Data.Maybe    ( maybe )
+import "base" Data.Ord      ( min, max, (>=) )
 import "base" Data.Ratio    ( (%) )
 import "base" Data.String   ( String )
-import "base" Prelude       ( (+), (-), round, floor )
+import "base" Prelude       ( (+), (-), round, floor, Bool(..) )
 import "base" System.IO     ( IO, putStr, putChar )
 import "base" Text.Printf   ( printf )
 import "base" Text.Show     ( show )
+import "base"  Control.Concurrent ( ThreadId, forkIO )
+import "stm"  Control.Concurrent.STM ( TVar, readTVar, writeTVar, newTVar, atomically, STM )
+import "stm-chans"  Control.Concurrent.STM.TMQueue ( TMQueue, readTMQueue, closeTMQueue, writeTMQueue, newTMQueue )
 import "base-unicode-symbols" Data.Bool.Unicode ( (∧) )
 import "base-unicode-symbols" Data.Eq.Unicode   ( (≢) )
 import "base-unicode-symbols" Prelude.Unicode   ( ℤ, ℚ, (⋅) )
@@ -147,3 +156,64 @@ exact ∷ Label
 exact done total = printf "%*i/%s" (length totalStr) done totalStr
   where
     totalStr = show total
+
+-- * Auto-Printing Progress
+
+data ProgressRef = ProgressRef { prPrefix    ∷ Label
+                               , prPostfix   ∷ Label
+                               , prWidth     ∷ ℤ
+                               , prCompleted ∷ TVar ℤ
+                               , prTotal     ∷ ℤ
+                               , prQueue     ∷ TMQueue ℤ }
+
+-- | Start a thread to automatically display progress. Use incProgress to step
+-- the progress bar.
+startProgress ∷ Label -- ^ Prefixed label.
+              → Label -- ^ Postfixed label.
+              → ℤ     -- ^ Total progress bar width in characters.
+              → ℤ     -- ^ Total amount of work.
+              → IO (ProgressRef, ThreadId)
+startProgress mkPreLabel mkPostLabel width total = do
+    pr  <- buildProgressRef
+    tid <- forkIO $ reportProgress pr
+    return (pr, tid)
+    where
+      buildProgressRef = do
+        completed <- atomically $ newTVar 0
+        queue     <- atomically $ newTMQueue
+        return $ ProgressRef mkPreLabel mkPostLabel width completed total queue
+
+-- | Increment the progress bar. Negative values will reverse the progress.
+-- Progress will never be negative and will silently stop taking data when it
+-- completes.
+incProgress ∷ ProgressRef
+            → ℤ
+            → IO ()
+incProgress ProgressRef {prQueue} = atomically . writeTMQueue prQueue
+
+reportProgress ∷ ProgressRef
+               → IO ()
+reportProgress pr = do
+  continue <- atomically $ updateProgress pr
+  renderProgress pr
+  when continue $ reportProgress pr
+
+updateProgress ∷ ProgressRef
+               → STM Bool
+updateProgress ProgressRef {prCompleted, prQueue, prTotal} = do
+  maybe dontContinue doUpdate =<< readTMQueue prQueue
+  where
+    dontContinue = return False
+    doUpdate countDiff = do
+      count <- readTVar prCompleted
+      let newCount = min prTotal $ max 0 $ count + countDiff
+      writeTVar prCompleted newCount
+      if newCount >= prTotal
+        then closeTMQueue prQueue >> dontContinue
+        else return True
+
+renderProgress ∷ ProgressRef
+               → IO ()
+renderProgress ProgressRef {..} = do
+  completed <- atomically $ readTVar prCompleted
+  progressBar prPrefix prPostfix prWidth completed prTotal

terminal-progress-bar.cabal

@@ -43,6 +43,9 @@ library
     hs-source-dirs: src
     build-depends: base                 >= 3.0.3.1 && < 4.7
                  , base-unicode-symbols >= 0.2.2.3 && < 0.3
+                 , base-unicode-symbols >= 0.2.2.3 && < 0.3
+                 , stm                  >= 2.4     && < 3.0
+                 , stm-chans            >= 3.0.0   && < 4.0
     exposed-modules: System.ProgressBar
     ghc-options: -Wall
 
@@ -54,7 +57,7 @@ test-suite test-terminal-progress-bar
   build-depends: base                  >= 3.0.3.1 && < 4.7
                , base-unicode-symbols  >= 0.2.2.3 && < 0.3
                , HUnit                 >= 1.2.4.2 && < 1.3
-               , terminal-progress-bar == 0.0.1.1
+               , terminal-progress-bar
                , test-framework        >= 0.3.3   && < 0.9
                , test-framework-hunit  >= 0.2.6   && < 0.4