@@ -1,3 +1,6 @@
1+{-# LANGUAGE NoMonomorphismRestriction #-}
2+{-# LANGUAGE TemplateHaskell #-}
3+{-# LANGUAGE CPP #-}
14-- Much of the input layer used to be in a single module with a few large functions. I've refactored
25-- the input layer into many small bits. Now, I think, the code is a better position to be
36-- incrementally refined. Still, until there are proper tests in place much of the refinement must
@@ -7,18 +10,25 @@ module Graphics.Vty.Input.Internal where
710import Graphics.Vty.Input.Events
811
912import Codec.Binary.UTF8.Generic (decode)
13+import Control.Applicative
1014import Control.Concurrent
15+import Control.Lens
1116import Control.Exception (try, IOException)
12−import Control.Monad (when, void)
17+import Control.Monad (when, void, mzero)
18+import Control.Monad.IO.Class (liftIO)
19+import Control.Monad.Trans.State (StateT(..))
20+import Control.Monad.Trans.Reader (ReaderT(..))
1321
1422import Data.Char
23+import Data.Default
24+import Data.IORef
1525import Data.List( inits )
1626import qualified Data.Map as M( fromList, lookup )
1727import Data.Maybe ( mapMaybe )
1828import qualified Data.Set as S( fromList, member )
1929import Data.Word
2030
21−import Foreign ( alloca, poke, peek, Ptr )
31+import Foreign ( alloca, poke, peek, peekArray, Ptr )
2232import Foreign.C.Types (CInt(..))
2333
2434import System.Posix.IO ( fdReadBuf
@@ -27,48 +37,164 @@ import System.Posix.IO ( fdReadBuf
2737 )
2838import System.Posix.Types (Fd(..))
2939
40+data 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.
45+ } deriving (Show, Eq)
46+
47+instance Default Config where
48+ def = Config
49+ { controlSeqPeriod = 10000
50+ , metaComboPeriod = 100000
51+ }
52+
3053data Input = Input
3154 { -- | Channel of events direct from input processing. Unlike 'next_event' this will not refresh
3255 -- the display if the next event is an 'EvResize'.
33− event_channel :: Chan Event
56+ _event_channel :: Chan Event
3457 -- | Shuts down the input processing. This should return the terminal input state to before
3558 -- the input initialized.
3659 , shutdown_input :: IO ()
60+ -- | Changes to this value are reflected after the next event.
61+ , _config_ref :: IORef Config
62+ -- | File descriptor used for input.
63+ , _input_fd :: Fd
3764 }
3865
66+makeLenses ''Input
67+
3968data KClass
40− = Valid Key [Modifier]
69+ = Valid Key [Modifier] [Char]
4170 | Invalid
42− | EndLoop
4371 | Prefix
44− | MisPfx Key [Modifier] [Char]
45− deriving(Show)
72+ deriving(Show, Eq)
73+
74+data InputBuffer = InputBuffer
75+ { _ptr :: Ptr Word8
76+ , _size :: Int
77+ }
78+
79+makeLenses ''InputBuffer
80+
81+data InputState = InputState
82+ { _unprocessed_bytes :: String
83+ , _applied_config :: Config
84+ , _input_buffer :: InputBuffer
85+ , _stop_request_ref :: IORef Bool
86+ , _classifier :: String -> KClass
87+ }
88+
89+makeLenses ''InputState
90+
91+type InputM a = StateT InputState (ReaderT Input IO) a
92+
93+loop_input_processor :: InputM ()
94+loop_input_processor = do
95+ read_from_device >>= add_bytes_to_process
96+ _ <- many $ parse_event >>= emit
97+ drop_invalid
98+ stop_requested <|> loop_input_processor
99+
100+add_bytes_to_process :: String -> InputM ()
101+add_bytes_to_process block = unprocessed_bytes <>= block
102+
103+emit :: Event -> InputM ()
104+emit event = view event_channel >>= liftIO . flip writeChan event
105+
106+read_from_device :: InputM String
107+read_from_device = do
108+ new_config <- view config_ref >>= liftIO . readIORef
109+ old_config <- use applied_config
110+ fd <- view input_fd
111+ when (new_config /= old_config) $ do
112+ let vtime = min 255 $ metaComboPeriod new_config `div` 100000
113+ liftIO $ set_term_timing fd 0 vtime
114+ applied_config .= new_config
115+ buffer_ptr <- use $ input_buffer.ptr
116+ max_bytes <- use $ input_buffer.size
117+ liftIO $ do
118+ bytes_read <- fdReadBuf fd buffer_ptr (fromIntegral max_bytes)
119+ fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytes_read) buffer_ptr
120+
121+parse_event :: InputM Event
122+parse_event = do
123+ c <- use classifier
124+ b <- use unprocessed_bytes
125+ case c b of
126+ Valid k m remaining -> do
127+ unprocessed_bytes .= remaining
128+ return $ EvKey k m
129+ _ -> mzero
130+
131+drop_invalid :: InputM ()
132+drop_invalid = do
133+ c <- use classifier
134+ b <- use unprocessed_bytes
135+ when (c b == Invalid) $ unprocessed_bytes .= []
136+
137+stop_requested :: InputM ()
138+stop_requested = do
139+ True <- (liftIO . readIORef) =<< use stop_request_ref
140+ return ()
141+
142+#if 0
143+data InputChunk
144+ = StopInput
145+ | InputChunk String
146+ | InputBreak
46147
47148-- The input uses two magic character:
48149--
49150-- * '\xFFFD' for "stop processing"
50151-- * '\xFFFE' for "previous input chunk is complete" Which is used to differentiate a single ESC
51152-- from using ESC as meta or to indicate a control sequence.
52−inputToEventThread :: (String -> KClass) -> Chan Char -> Chan Event -> IO ()
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 ()
53160inputToEventThread classifier inputChannel eventChannel = loop []
54− where loop kb = case classifier kb of
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+
55179 Prefix -> do
56180 c <- readChan inputChannel
57− if c == '\xFFFD'
58− then return ()
59− else loop (kb ++ [c])
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
60187 -- drop the entirety of invalid sequences. Probably better to drop only the first
61188 -- character. However, the read behavior of terminals (a single read corresponds to the
62189 -- bytes of a single event) might mean this results in quicker error recovery from a
63190 -- users perspective.
64191 Invalid -> do
65192 c <- readChan inputChannel
66− if c == '\xFFFD'
67− then return ()
68− else loop [c]
69− EndLoop -> return ()
70− MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s
71− Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""
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
72198
73199-- This makes a kind of tri. Has space efficiency issues with large input blocks.
74200-- Likely building a parser and just applying that would be better.
@@ -87,22 +213,20 @@ compile table = cl' where
87213 -- if the input_block is exactly what is expected for an event then consume the whole
88214 -- block and return the event
89215 False -> case event_for_input input_block of
90− Just (EvKey k m) -> Valid k m
216+ Just (EvKey k m) -> Valid k m []
91217 -- look up progressively large prefixes of the input block until an event is found
92218 -- H: There will always be one match. The prefix_set contains, by definition, all
93219 -- prefixes of an event.
94220 Nothing ->
95221 let input_prefixes = init $ inits input_block
96222 in case mapMaybe (\s -> (,) s `fmap` event_for_input s) input_prefixes of
97− (s,EvKey k m) : _ -> MisPfx k m (drop (length s) input_block)
223+ (s,EvKey k m) : _ -> Valid k m (drop (length s) input_block)
98224 -- neither a prefix or a full event. Might be interesting to log.
99− [] -> error $ show input_block
225+ [] -> Invalid
100226
101227classify, classifyTab :: ClassifyTable -> [Char] -> KClass
102228
103229-- As soon as
104−classify _table "\xFFFD" = EndLoop
105−classify _table "\xFFFE" = Invalid
106230classify _table s@(c:_) | ord c >= 0xC2
107231 = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
108232classify table other
@@ -110,7 +234,7 @@ classify table other
110234
111235classifyUtf8 :: [Char] -> KClass
112236classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
113− Just (unicodeChar, _) -> Valid (KChar unicodeChar) []
237+ Just (unicodeChar, _) -> Valid (KChar unicodeChar) [] []
114238 _ -> Invalid -- something bad happened; just ignore and continue.
115239
116240classifyTab table = compile table
@@ -133,15 +257,20 @@ utf8Length c
133257--
134258-- This is an example of an algorithm where code coverage could be high, even 100%, but the
135259-- algorithm still under tested. I should collect more of these examples...
136−initInputForFd :: Int -> ClassifyTable -> Fd -> IO (Chan Event, IO ())
137−initInputForFd escDelay classify_table input_fd = do
138− inputChannel <- newChan
260+initInputForFd :: IORef Config -> ClassifyTable -> Fd -> IO (Chan Event, IO ())
261+initInputForFd config_ref classify_table input_fd = do
139262 eventChannel <- newChan
140− hadInput <- newEmptyMVar
141− let finishAtomicInput = writeChan inputChannel '\xFFFE'
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.
142270 inputThread :: IO ()
143271 inputThread = do
144− _ <- alloca $ \(input_buffer :: Ptr Word8) -> do
272+ let k = 1024
273+ _ <- allocaArray k $ \(input_buffer :: Ptr Word8) -> do
145274 let loop = do
146275 setFdOption input_fd NonBlockingRead False
147276 threadWaitRead input_fd
@@ -172,15 +301,16 @@ initInputForFd escDelay classify_table input_fd = do
172301 loop
173302 classifier = classify classify_table
174303 eventThreadId <- forkIO $ void $ inputToEventThread classifier inputChannel eventChannel
175− inputThreadId <- forkIO $ inputThread
304+ inputThreadId <- forkIO $ input_thread
176305 noInputThreadId <- forkIO $ noInputThread
177306 -- TODO(corey): killThread is a bit risky for my tastes.
178307 -- H - somewhat mitigated by sending a magic terminate character?
179308 let shutdown_event_processing = do
180− writeChan inputChannel '\xFFFD'
181− killThread noInputThreadId
182309 killThread eventThreadId
183310 killThread inputThreadId
311+#endif
312+ let shutdown_event_processing = return ()
313+
184314 return (eventChannel, shutdown_event_processing)
185315
186−foreign import ccall "vty_set_term_timing" set_term_timing :: Fd -> IO ()
316+foreign import ccall "vty_set_term_timing" set_term_timing :: Fd -> Int -> Int -> IO ()