[commit: packages/haskeline] master: Extending concurrent print function to Win32 backend. (0640f91)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/haskeline

On branch  : master
Link       : http://git.haskell.org/packages/haskeline.git/commitdiff/0640f9125741368505ad58ec224d3fdc9a55d266

>---------------------------------------------------------------

commit 0640f9125741368505ad58ec224d3fdc9a55d266
Author: Bakhtiyar Neyman <b.neymanov at gmail.com>
Date:   Mon Feb 15 21:57:58 2016 -0800

    Extending concurrent print function to Win32 backend.


>---------------------------------------------------------------

0640f9125741368505ad58ec224d3fdc9a55d266
 System/Console/Haskeline/Backend/Posix.hsc | 18 +-----------------
 System/Console/Haskeline/Backend/Win32.hsc | 26 ++++++++++++++------------
 System/Console/Haskeline/Term.hs           | 18 +++++++++++++++++-
 3 files changed, 32 insertions(+), 30 deletions(-)

diff --git a/System/Console/Haskeline/Backend/Posix.hsc b/System/Console/Haskeline/Backend/Posix.hsc
index c8d7b14..11cbe2c 100644
--- a/System/Console/Haskeline/Backend/Posix.hsc
+++ b/System/Console/Haskeline/Backend/Posix.hsc
@@ -294,26 +294,10 @@ posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
                             , externalPrint = writeChan ch . ExternalPrint
                             }
                 , closeTerm = do
-                    -- This hack is needed to grab latest writes from some other thread.
-                    -- Without it, if you are using another thread to process the logging
-                    -- and write on screen via exposed externalPrint, latest writes from
-                    -- this thread are not able to cross the thread boundary in time.
-                    threadDelay 1
                     flushEventQueue (putStrOut fileRT) ch
-                    closeTerm fileRT
+                    closeHandles hs
                 }
 
-flushEventQueue :: (String -> IO ()) -> Chan Event -> IO ()
-flushEventQueue print' eventChan = loop
-  where loop = do
-            flushed <- isEmptyChan eventChan
-            if flushed then return () else do
-                event <- readChan eventChan
-                case event of
-                    ExternalPrint str -> do
-                        print' (str ++ "\n") >> loop
-                    _ -> do loop
-
 type PosixT m = ReaderT Encoder (ReaderT Handles m)
 
 runPosixT :: Monad m => Encoder -> Handles -> PosixT m a -> m a
diff --git a/System/Console/Haskeline/Backend/Win32.hsc b/System/Console/Haskeline/Backend/Win32.hsc
index d9c0934..95a7b5b 100644
--- a/System/Console/Haskeline/Backend/Win32.hsc
+++ b/System/Console/Haskeline/Backend/Win32.hsc
@@ -380,17 +380,20 @@ win32Term = do
     hs <- consoleHandles
     ch <- liftIO newChan
     fileRT <- liftIO $ fileRunTerm stdin
-    return fileRT {
-                            termOps = Left TermOps {
-                                getLayout = getBufferSize (hOut hs)
-                                , withGetEvent = withWindowMode hs
-                                                    . win32WithEvent hs ch
-                                , saveUnusedKeys = saveKeys ch
-                                , evalTerm = EvalTerm (runReaderT' hs . runDraw)
-                                                    (Draw . lift)
-                                },
-                            closeTerm = closeHandles hs
-                        }
+    return fileRT
+      { termOps = Left TermOps {
+          getLayout = getBufferSize (hOut hs)
+          , withGetEvent = withWindowMode hs
+                              . win32WithEvent hs ch
+          , saveUnusedKeys = saveKeys ch
+          , evalTerm = EvalTerm (runReaderT' hs . runDraw)
+                              (Draw . lift)
+          , externalPrint = writeChan ch . ExternalPrint
+          }
+      , closeTerm = do
+          flushEventQueue (putStrOut fileRT) ch
+          closeHandles hs
+      }
 
 win32WithEvent :: MonadException m => Handles -> Chan Event
                                         -> (m Event -> m a) -> m a
@@ -545,4 +548,3 @@ clearScreen = do
     liftIO $ fillConsoleChar h ' ' windowSize origin
     liftIO $ fillConsoleAttribute h attr windowSize origin
     setPos origin
-
diff --git a/System/Console/Haskeline/Term.hs b/System/Console/Haskeline/Term.hs
index 0e60278..5186a12 100644
--- a/System/Console/Haskeline/Term.hs
+++ b/System/Console/Haskeline/Term.hs
@@ -46,6 +46,23 @@ data TermOps = TermOps
     , externalPrint :: String -> IO ()
     }
 
+-- This hack is needed to grab latest writes from some other thread.
+-- Without it, if you are using another thread to process the logging
+-- and write on screen via exposed externalPrint, latest writes from
+-- this thread are not able to cross the thread boundary in time.
+flushEventQueue :: (String -> IO ()) -> Chan Event -> IO ()
+flushEventQueue print' eventChan = yield >> loopUntilFlushed
+    where loopUntilFlushed = do
+              flushed <- isEmptyChan eventChan
+              if flushed then return () else do
+                  event <- readChan eventChan
+                  case event of
+                      ExternalPrint str -> do
+                          print' (str ++ "\n") >> loopUntilFlushed
+                      ErrorEvent e -> throwIO e
+                      -- We don't want to raise exceptions when doing cleanup.
+                      _ -> do loopUntilFlushed
+
 -- | Operations needed for file-style interaction.
 --
 -- Backends can assume that getLocaleLine, getLocaleChar and maybeReadNewline
@@ -200,4 +217,3 @@ hGetLocaleLine = guardedEOF $ \h -> do
     liftIO $ if buff == NoBuffering
         then fmap BC.pack $ System.IO.hGetLine h
         else BC.hGetLine h
-