Unnecessary concurrency and terminal silliness.

generation/Main.hs

@@ -5,11 +5,16 @@ import Add(safeAddOps,unsafeAddOps,safeSignedAddOps,unsafeSignedAddOps)
 import Base(base)
 import BinaryOps(binaryOps)
 import Compare(comparisons, signedComparisons)
+import Control.Concurrent(forkFinally)
+import Control.Concurrent.MVar(MVar, newEmptyMVar, newMVar, putMVar, takeMVar)
+import Control.Monad(replicateM, void)
 import Conversions(conversions, signedConversions)
 import CryptoNum(cryptoNum)
 import Control.Monad(forM_,unless)
+import Data.Text.Lazy(Text, pack)
 import Division(divisionOps)
 import File(File,Task(..),generateTasks)
+import GHC.Conc(getNumCapabilities)
 import ModInv(generateModInvOps)
 import ModOps(modulusOps)
 import Multiply(safeMultiplyOps, unsafeMultiplyOps)
@@ -22,6 +27,7 @@ import System.Environment(getArgs)
 import System.Exit(die)
 import System.FilePath(takeDirectory,(</>))
 import System.IO(IOMode(..),withFile)
+import System.ProgressBar(Label(..), Progress(..), ProgressBar, Timing, defStyle, newProgressBar, stylePrefix, updateProgress)
 import System.Random(getStdGen)
 
 lowestBitsize :: Word
@@ -69,17 +75,47 @@ signedFiles = [
 allFiles :: [File]
 allFiles = unsignedFiles ++ signedFiles
 
+printLast :: Progress String -> Timing -> Text
+printLast prog _ = pack (progressCustom prog)
+
+runThread :: ProgressBar String -> FilePath -> MVar [Task] -> IO (MVar ())
+runThread pb outputPath mtaskls =
+  do res <- newEmptyMVar
+     void $ forkFinally step (threadDie res)
+     return res
+ where
+   step =
+     do tasks <- takeMVar mtaskls
+        case tasks of
+          [] ->
+            putMVar mtaskls []
+          task : rest ->
+            do putMVar mtaskls rest
+               let target = outputPath </> outputFile task
+               createDirectoryIfMissing True (takeDirectory target)
+               withFile target WriteMode $ \ targetHandle ->
+                 writer task targetHandle
+               updateProgress pb (\ p -> p{ progressCustom = outputFile task,
+                                            progressDone   = progressDone p + 1 })
+               step
+   threadDie resmv thrRes =
+     do case thrRes of
+          Left se -> putStrLn ("Thread died: " ++ show se)
+          Right () -> return ()
+        putMVar resmv ()
+
 main :: IO ()
 main =
   do args <- getArgs
      unless (length args == 1) $
        die ("generation takes exactly one argument, the target directory")
      g <- getStdGen
-     let allTasks = generateTasks g allFiles bitsizes
+     let style = defStyle{ stylePrefix = Label printLast }
+         allTasks = generateTasks g allFiles bitsizes
+         progress = Progress 0 total "starting"
          total = length allTasks
-     forM_ (zip [(1::Word)..] allTasks) $ \ (i, task) ->
-       do putStrLn ("[" ++ show i ++ "/" ++ show total ++ "] " ++ outputFile task)
-          let target = head args </> outputFile task
-          createDirectoryIfMissing True (takeDirectory target)
-          withFile target WriteMode $ \ targetHandle ->
-            writer task targetHandle
+     pb <- newProgressBar style 60 progress
+     chan <- newMVar allTasks
+     count <- getNumCapabilities
+     threads <- replicateM count (runThread pb (head args) chan)
+     forM_ threads (\ m -> takeMVar m)

generation/generation.cabal

@@ -52,8 +52,8 @@ library
 executable generation
   main-is:             Main.hs
   default-language:    Haskell2010
-  ghc-options:         -Wall
-  build-depends:       base, directory, filepath, generation, random
+  ghc-options:         -Wall -threaded -with-rtsopts=-N
+  build-depends:       base, directory, filepath, generation, random, terminal-progress-bar, text
 
 test-suite test-generation
   type:                exitcode-stdio-1.0