Commit 8e539a49 authored by Judah Jacobson's avatar Judah Jacobson Committed by GitHub
Browse files

Merge pull request #61 from bgamari/master

Move away from Chan to STM
parents f17e58f0 c534c657
......@@ -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
......
......@@ -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
......
......@@ -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)
......
......@@ -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,
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment