@@ -16,7 +16,7 @@ import Control.Lens
1616import Control.Exception (try, IOException)
1717import Control.Monad (when, void, mzero)
1818import Control.Monad.IO.Class (liftIO)
19−import Control.Monad.Trans.State (StateT(..))
19+import Control.Monad.Trans.State (StateT(..), evalStateT)
2020import Control.Monad.Trans.Reader (ReaderT(..))
2121
2222import Data.Char
@@ -28,7 +28,7 @@ import Data.Maybe ( mapMaybe )
2828import qualified Data.Set as S( fromList, member )
2929import Data.Word
3030
31−import Foreign ( alloca, poke, peek, peekArray, Ptr )
31+import Foreign ( allocaArray, peekArray, Ptr )
3232import Foreign.C.Types (CInt(..))
3333
3434import System.Posix.IO ( fdReadBuf
@@ -38,16 +38,12 @@ import System.Posix.IO ( fdReadBuf
3838import System.Posix.Types (Fd(..))
3939
4040data Config = Config
41− { controlSeqPeriod :: Int -- ^ default control sequence period is 10000 microseconds. Which is
42− -- assumed to be well above the sampling rate required to detect a
43− -- keyup for a person typing 200 wpm.
44− , metaComboPeriod :: Int -- ^ The default meta combo period is 100000 microseconds.
41+ { singleEscPeriod :: Int -- ^ The default is 100000 microseconds or 0.1 seconds.
4542 } deriving (Show, Eq)
4643
4744instance Default Config where
4845 def = Config
49− { controlSeqPeriod = 10000
50− , metaComboPeriod = 100000
46+ { singleEscPeriod = 100000
5147 }
5248
5349data Input = Input
@@ -95,7 +91,7 @@ loop_input_processor = do
9591 read_from_device >>= add_bytes_to_process
9692 _ <- many $ parse_event >>= emit
9793 drop_invalid
98− stop_requested <|> loop_input_processor
94+ stop_if_requested <|> loop_input_processor
9995
10096add_bytes_to_process :: String -> InputM ()
10197add_bytes_to_process block = unprocessed_bytes <>= block
@@ -109,8 +105,7 @@ read_from_device = do
109105 old_config <- use applied_config
110106 fd <- view input_fd
111107 when (new_config /= old_config) $ do
112− let vtime = min 255 $ metaComboPeriod new_config `div` 100000
113− liftIO $ set_term_timing fd 0 vtime
108+ liftIO $ apply_timing_config fd new_config
114109 applied_config .= new_config
115110 buffer_ptr <- use $ input_buffer.ptr
116111 max_bytes <- use $ input_buffer.size
@@ -118,6 +113,11 @@ read_from_device = do
118113 bytes_read <- fdReadBuf fd buffer_ptr (fromIntegral max_bytes)
119114 fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytes_read) buffer_ptr
120115
116+apply_timing_config :: Fd -> Config -> IO ()
117+apply_timing_config fd config =
118+ let vtime = min 255 $ singleEscPeriod config `div` 100000
119+ in set_term_timing fd 1 vtime
120+
121121parse_event :: InputM Event
122122parse_event = do
123123 c <- use classifier
@@ -134,68 +134,11 @@ drop_invalid = do
134134 b <- use unprocessed_bytes
135135 when (c b == Invalid) $ unprocessed_bytes .= []
136136
137−stop_requested :: InputM ()
138−stop_requested = do
137+stop_if_requested :: InputM ()
138+stop_if_requested = do
139139 True <- (liftIO . readIORef) =<< use stop_request_ref
140140 return ()
141141
142−#if 0
143−data InputChunk
144− = StopInput
145− | InputChunk String
146− | InputBreak
147−
148−-- The input uses two magic character:
149−--
150−-- * '\xFFFD' for "stop processing"
151−-- * '\xFFFE' for "previous input chunk is complete" Which is used to differentiate a single ESC
152−-- from using ESC as meta or to indicate a control sequence.
153−--
154−-- | Read 'InputChunk' from the input channel, parse into one or more 'Event's, output to event
155−-- channel.
156−--
157−-- Each input chunk is added to the current chunk being processed. The current chunk is processed
158−-- with the provided function to determine events.
159−inputToEventThread :: (String -> KClass) -> Chan InputChunk -> Chan Event -> IO ()
160−inputToEventThread classifier inputChannel eventChannel = loop []
161− where
162− loop current =
163− c <- readChan inputChannel
164− case c of
165− StopInput -> return ()
166− -- the prefix is missing bytes and there are bytes available.
167− InputChunk chunk -> parse_until_prefix (current ++ chunk)
168− >>= loop
169− -- if there are bytes remaining after all events are parsed then the spacing after
170− InputBreak -> parse_until_prefix current
171− >> loop []
172− parse_until_prefix current = case classifier current of
173− Prefix -> return current
174− Invalid -> return []
175− Valid k m remaining -> do
176− writeChan eventChannel (EvKey k m)
177− parse_until_prefix remaining
178−
179− Prefix -> do
180− c <- readChan inputChannel
181− case c of
182− StopInput -> return ()
183− -- the prefix is missing bytes and there are bytes available.
184− InputChunk chunk -> loop (current ++ chunk)
185− -- the prefix is a control sequence that is unknown. Drop and move on to the next
186− MetaShiftChunk chunk -> loop chunk
187− -- drop the entirety of invalid sequences. Probably better to drop only the first
188− -- character. However, the read behavior of terminals (a single read corresponds to the
189− -- bytes of a single event) might mean this results in quicker error recovery from a
190− -- users perspective.
191− Invalid -> do
192− c <- readChan inputChannel
193− case c of
194− EndChunk -> return ()
195− InputChunk chunk -> loop chunk
196− Valid k m remaining -> writeChan eventChannel (EvKey k m) >> loop remaining
197−#endif
198−
199142-- This makes a kind of tri. Has space efficiency issues with large input blocks.
200143-- Likely building a parser and just applying that would be better.
201144-- I did not write this so I might just rewrite it for better understanding. Not the best of
@@ -249,6 +192,16 @@ utf8Length c
249192 | c < 0xF0 = 3
250193 | otherwise = 4
251194
195+run_input_processor_loop :: ClassifyTable -> Input -> IORef Bool -> IO ()
196+run_input_processor_loop classify_table input stop_flag = do
197+ let buffer_size = 1024
198+ allocaArray buffer_size $ \(buffer_ptr :: Ptr Word8) -> do
199+ s0 <- InputState [] <$> readIORef (_config_ref input)
200+ <*> pure (InputBuffer buffer_ptr buffer_size)
201+ <*> pure stop_flag
202+ <*> pure (classify classify_table)
203+ runReaderT (evalStateT loop_input_processor s0) input
204+
252205-- I gave a quick shot at replacing this code with some that removed the "odd" bits. The "obvious"
253206-- changes all failed testing. This is timing sensitive code.
254207-- I now think I can replace this wil code that makes the time sensitivity explicit. I am waiting
@@ -257,60 +210,14 @@ utf8Length c
257210--
258211-- This is an example of an algorithm where code coverage could be high, even 100%, but the
259212-- algorithm still under tested. I should collect more of these examples...
260−initInputForFd :: IORef Config -> ClassifyTable -> Fd -> IO (Chan Event, IO ())
213+initInputForFd :: IORef Config -> ClassifyTable -> Fd -> IO Input
261214initInputForFd config_ref classify_table input_fd = do
262− eventChannel <- newChan
263−#if 0
264− should_exit <- newIORef False
265− let -- initial state: read bytes until a ESC. Emit bytes. Go to possible-control-seq state.
266− -- possible-control-seq: read available bytes.
267− -- If time is < controlSeqPeriod then emit as chunk with ESC prefix.
268− -- If time is < metaComboPeriod then emit chunk with Meta shift.
269− -- If time is > metaComboPeriod then emit ESC event then chunk of bytes.
270− inputThread :: IO ()
271− inputThread = do
272− let k = 1024
273− _ <- allocaArray k $ \(input_buffer :: Ptr Word8) -> do
274− let loop = do
275− setFdOption input_fd NonBlockingRead False
276− threadWaitRead input_fd
277− setFdOption input_fd NonBlockingRead True
278− _ <- try readAll :: IO (Either IOException ())
279− when (escDelay == 0) finishAtomicInput
280− loop
281− readAll = do
282− poke input_buffer 0
283− bytes_read <- fdReadBuf input_fd input_buffer 1
284− input_char <- fmap (chr . fromIntegral) $ peek input_buffer
285− when (bytes_read > 0) $ do
286− _ <- tryPutMVar hadInput () -- signal input
287− writeChan inputChannel input_char
288− readAll
289− loop
290− return ()
291− -- If there is no input for some time, this thread puts '\xFFFE' in the
292− -- inputChannel.
293− noInputThread :: IO ()
294− noInputThread = when (escDelay > 0) loop
295− where loop = do
296− takeMVar hadInput -- wait for some input
297− threadDelay escDelay -- microseconds
298− hadNoInput <- isEmptyMVar hadInput -- no input yet?
299− -- TODO(corey): there is a race between here and the inputThread.
300− when hadNoInput finishAtomicInput
301− loop
302− classifier = classify classify_table
303− eventThreadId <- forkIO $ void $ inputToEventThread classifier inputChannel eventChannel
304− inputThreadId <- forkIO $ input_thread
305− noInputThreadId <- forkIO $ noInputThread
306− -- TODO(corey): killThread is a bit risky for my tastes.
307− -- H - somewhat mitigated by sending a magic terminate character?
308− let shutdown_event_processing = do
309− killThread eventThreadId
310− killThread inputThreadId
311−#endif
312− let shutdown_event_processing = return ()
313−
314− return (eventChannel, shutdown_event_processing)
215+ stop_flag <- newIORef False
216+ input <- Input <$> newChan
217+ <*> pure (writeIORef stop_flag True)
218+ <*> pure config_ref
219+ <*> pure input_fd
220+ _ <- forkIO $ run_input_processor_loop classify_table input stop_flag
221+ return input
315222
316223foreign import ccall "vty_set_term_timing" set_term_timing :: Fd -> Int -> Int -> IO ()