@@ -19,6 +19,8 @@ import Graphics.Vty.Input.Events
1919
2020import Control.Applicative
2121import Control.Concurrent
22+import Control.Concurrent.MVar
23+import Control.Exception (mask, try, SomeException)
2224import Control.Lens
2325import Control.Monad (when, mzero, forM_)
2426import Control.Monad.IO.Class (liftIO)
@@ -65,7 +67,6 @@ data InputState = InputState
6567 { _unprocessedBytes :: String
6668 , _appliedConfig :: Config
6769 , _inputBuffer :: InputBuffer
68− , _stopRequestRef :: IORef Bool
6970 , _classifier :: String -> KClass
7071 }
7172
@@ -88,7 +89,7 @@ loopInputProcessor = do
8889 validEvents <- many parseEvent
8990 forM_ validEvents emit
9091 dropInvalid
91− stopIfRequested <|> loopInputProcessor
92+ loopInputProcessor
9293
9394addBytesToProcess :: String -> InputM ()
9495addBytesToProcess block = unprocessedBytes <>= block
@@ -115,6 +116,11 @@ readFromDevice = do
115116 bufferPtr <- use $ inputBuffer.ptr
116117 maxBytes <- use $ inputBuffer.size
117118 stringRep <- liftIO $ do
119+ -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses
120+ -- this provides a location to be interrupted prior to the foreign call. If there is input
121+ -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime
122+ -- terminal setting.
123+ threadWaitRead fd
118124 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
119125 if bytesRead > 0
120126 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
@@ -147,18 +153,12 @@ dropInvalid = do
147153 logMsg "dropping input bytes"
148154 unprocessedBytes .= []
149155
150−stopIfRequested :: InputM ()
151−stopIfRequested = do
152− True <- (liftIO . readIORef) =<< use stopRequestRef
153− return ()
154−
155−runInputProcessorLoop :: ClassifyMap -> Input -> IORef Bool -> IO ()
156−runInputProcessorLoop classifyTable input stopFlag = do
156+runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
157+runInputProcessorLoop classifyTable input = do
157158 let bufferSize = 1024
158159 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
159160 s0 <- InputState [] <$> readIORef (_configRef input)
160161 <*> pure (InputBuffer bufferPtr bufferSize)
161− <*> pure stopFlag
162162 <*> pure (classify classifyTable)
163163 runReaderT (evalStateT loopInputProcessor s0) input
164164
@@ -192,15 +192,23 @@ initInput config classifyTable = do
192192 let Just fd = inputFd config
193193 setFdOption fd NonBlockingRead False
194194 applyConfig fd config
195− stopFlag <- newIORef False
195+ stopSync <- newEmptyMVar
196196 input <- Input <$> newChan
197− <*> pure (writeIORef stopFlag True)
197+ <*> pure (return ())
198198 <*> newIORef config
199199 <*> maybe (return Nothing)
200200 (\f -> Just <$> openFile f AppendMode)
201201 (debugLog config)
202202 logInitialInputState input classifyTable
203− _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag
204− return input
203+ inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input)
204+ (\_ -> putMVar stopSync ())
205+ let killAndWait = do
206+ killThread inputThread
207+ takeMVar stopSync
208+ return $ input { shutdownInput = killAndWait }
205209
206210foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()
211+
212+forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
213+forkOSFinally action and_then =
214+ mask $ \restore -> forkOS $ try (restore action) >>= and_then