Move away from Chan to STM

System/Console/Haskeline/Backend/Posix.hsc

@@ -18,6 +18,7 @@ import Foreign.C.Types
 import qualified Data.Map as Map
 import System.Posix.Terminal hiding (Interrupt)
 import Control.Monad
+import Control.Concurrent.STM
 import Control.Concurrent hiding (throwTo)
 import Data.Maybe (catMaybes)
 import System.Posix.Signals.Exts
@@ -201,16 +202,16 @@ lookupChars (TreeMap tm) (c:cs) = case Map.lookup c tm of
 -----------------------------
 
 withPosixGetEvent :: (MonadException m, MonadReader Prefs m)
-        => Chan Event -> Handles -> [(String,Key)]
+        => TChan Event -> Handles -> [(String,Key)]
                 -> (m Event -> m a) -> m a
 withPosixGetEvent eventChan h termKeys f = wrapTerminalOps h $ do
     baseMap <- getKeySequences (ehIn h) termKeys
     withWindowHandler eventChan
         $ f $ liftIO $ getEvent (ehIn h) baseMap eventChan
 
-withWindowHandler :: MonadException m => Chan Event -> m a -> m a
+withWindowHandler :: MonadException m => TChan Event -> m a -> m a
 withWindowHandler eventChan = withHandler windowChange $
-    Catch $ writeChan eventChan WindowResize
+    Catch $ atomically $ writeTChan eventChan WindowResize
 
 withSigIntHandler :: MonadException m => m a -> m a
 withSigIntHandler f = do
@@ -224,7 +225,7 @@ withHandler signal handler f = do
     old_handler <- liftIO $ installHandler signal handler Nothing
     f `finally` liftIO (installHandler signal old_handler Nothing)
 
-getEvent :: Handle -> TreeMap Char Key -> Chan Event -> IO Event
+getEvent :: Handle -> TreeMap Char Key -> TChan Event -> IO Event
 getEvent h baseMap = keyEventLoop $ do
         cs <- getBlockOfChars h
         return [KeyInput $ lexKeys baseMap cs]
@@ -282,7 +283,7 @@ posixRunTerm ::
     -> (forall m . (MonadException m, CommandMonad m) => EvalTerm (PosixT m))
     -> IO RunTerm
 posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
-    ch <- newChan
+    ch <- newTChanIO
     fileRT <- posixFileRunTerm hs
     return fileRT
                 { termOps = Left TermOps
@@ -293,7 +294,7 @@ posixRunTerm hs layoutGetters keys wrapGetEvent evalBackend = do
                             , saveUnusedKeys = saveKeys ch
                             , evalTerm = mapEvalTerm
                                             (runPosixT hs) lift evalBackend
-                            , externalPrint = writeChan ch . ExternalPrint
+                            , externalPrint = atomically . writeTChan ch . ExternalPrint
                             }
                 , closeTerm = do
                     flushEventQueue (putStrOut fileRT) ch

System/Console/Haskeline/Backend/Win32.hsc

@@ -45,7 +45,7 @@ getNumberOfEvents h = alloca $ \numEventsPtr -> do
         $ c_GetNumberOfConsoleInputEvents h numEventsPtr
     fmap fromEnum $ peek numEventsPtr
 
-getEvent :: HANDLE -> Chan Event -> IO Event
+getEvent :: HANDLE -> TChan Event -> IO Event
 getEvent h = keyEventLoop (eventReader h)
 
 eventReader :: HANDLE -> IO [Event]
@@ -377,7 +377,7 @@ win32TermStdin = do
 win32Term :: MaybeT IO RunTerm
 win32Term = do
     hs <- consoleHandles
-    ch <- liftIO newChan
+    ch <- liftIO newTChanIO
     fileRT <- liftIO $ fileRunTerm stdin
     return fileRT
       { termOps = Left TermOps {
@@ -387,14 +387,14 @@ win32Term = do
           , saveUnusedKeys = saveKeys ch
           , evalTerm = EvalTerm (runReaderT' hs . runDraw)
                               (Draw . lift)
-          , externalPrint = writeChan ch . ExternalPrint
+          , externalPrint = atomically . writeTChan ch . ExternalPrint
           }
       , closeTerm = do
           flushEventQueue (putStrOut fileRT) ch
           closeHandles hs
       }
 
-win32WithEvent :: MonadException m => Handles -> Chan Event
+win32WithEvent :: MonadException m => Handles -> TChan Event
                                         -> (m Event -> m a) -> m a
 win32WithEvent h eventChan f = f $ liftIO $ getEvent (hIn h) eventChan
 

System/Console/Haskeline/Term.hs

@@ -7,6 +7,7 @@ import System.Console.Haskeline.Prefs(Prefs)
 import System.Console.Haskeline.Completion(Completion)
 
 import Control.Concurrent
+import Control.Concurrent.STM
 import Data.Word
 import Control.Exception (fromException, AsyncException(..),bracket_)
 import Data.Typeable
@@ -50,12 +51,12 @@ data TermOps = TermOps
 -- 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 :: (String -> IO ()) -> TChan Event -> IO ()
 flushEventQueue print' eventChan = yield >> loopUntilFlushed
     where loopUntilFlushed = do
-              flushed <- isEmptyChan eventChan
+              flushed <- atomically $ isEmptyTChan eventChan
               if flushed then return () else do
-                  event <- readChan eventChan
+                  event <- atomically $ readTChan eventChan
                   case event of
                       ExternalPrint str -> do
                           print' (str ++ "\n") >> loopUntilFlushed
@@ -121,36 +122,29 @@ data Event
   | ExternalPrint String
   deriving Show
 
-keyEventLoop :: IO [Event] -> Chan Event -> IO Event
+keyEventLoop :: IO [Event] -> TChan Event -> IO Event
 keyEventLoop readEvents eventChan = do
     -- first, see if any events are already queued up (from a key/ctrl-c
     -- event or from a previous call to getEvent where we read in multiple
     -- keys)
-    isEmpty <- isEmptyChan eventChan
+    isEmpty <- atomically $ isEmptyTChan eventChan
     if not isEmpty
-        then readChan eventChan
+        then atomically $ readTChan eventChan
         else do
-            lock <- newEmptyMVar
-            tid <- forkIO $ handleErrorEvent (readerLoop lock)
-            readChan eventChan `finally` do
-                            putMVar lock ()
-                            killThread tid
+            tid <- forkIO $ handleErrorEvent readerLoop
+            atomically (readTChan eventChan) `finally` killThread tid
   where
-    readerLoop lock = do
+    readerLoop = do
         es <- readEvents
         if null es
-            then readerLoop lock
-            else -- Use the lock to work around the fact that writeList2Chan
-                 -- isn't atomic.  Otherwise, some events could be ignored if
-                 -- the subthread is killed before it saves them in the chan.
-                 bracket_ (putMVar lock ()) (takeMVar lock) $
-                    writeList2Chan eventChan es
+            then readerLoop
+            else atomically $ mapM_ (writeTChan eventChan) es
     handleErrorEvent = handle $ \e -> case fromException e of
                                 Just ThreadKilled -> return ()
-                                _ -> writeChan eventChan (ErrorEvent e)
+                                _ -> atomically $ writeTChan eventChan (ErrorEvent e)
 
-saveKeys :: Chan Event -> [Key] -> IO ()
-saveKeys ch = writeChan ch . KeyInput
+saveKeys :: TChan Event -> [Key] -> IO ()
+saveKeys ch = atomically . writeTChan ch . KeyInput
 
 data Layout = Layout {width, height :: Int}
                     deriving (Show,Eq)

haskeline.cabal

@@ -43,10 +43,10 @@ Library
     -- We require ghc>=7.4.1 (base>=4.5) to use the base library encodings, even
     -- though it was implemented in earlier releases, due to GHC bug #5436 which
     -- wasn't fixed until 7.4.1
-    Build-depends: base >=4.5 && < 4.11, containers>=0.4 && < 0.6,
+    Build-depends: base >=4.5 && < 4.12, containers>=0.4 && < 0.6,
                    directory>=1.1 && < 1.4, bytestring>=0.9 && < 0.11,
                    filepath >= 1.2 && < 1.5, transformers >= 0.2 && < 0.6,
-                   process >= 1.0 && < 1.7
+                   process >= 1.0 && < 1.7, stm >= 2.4 && < 2.5
     Default-Language: Haskell98
     Default-Extensions:
                 ForeignFunctionInterface, Rank2Types, FlexibleInstances,