git.iko.soy/vty
on 00a6a4f help sign in
vty/src/Graphics/Vty/Input/Internal.hs
222 lines 8.2 kB history raw
1{-# LANGUAGE NoMonomorphismRestriction #-}
2{-# LANGUAGE TemplateHaskell #-}
3{-# LANGUAGE CPP #-}
4-- | The input layer used to be a single function that correctly accounted for the non-threaded
5-- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with
6-- a more straightforward parser. The non-threaded runtime is no longer supported.
7module Graphics.Vty.Input.Internal where
9import Graphics.Vty.Input.Events
11import Codec.Binary.UTF8.Generic (decode)
12import Control.Applicative
13import Control.Concurrent
14import Control.Lens
15import Control.Exception (try, IOException)
16import Control.Monad (when, void, mzero, forM_)
17import Control.Monad.IO.Class (liftIO)
18import Control.Monad.Trans.State (StateT(..), evalStateT)
19import Control.Monad.Trans.Reader (ReaderT(..))
21import Data.Char
22import Data.Default
23import Data.IORef
24import Data.List( inits )
25import qualified Data.Map as M( fromList, lookup )
26import Data.Maybe ( mapMaybe )
27import qualified Data.Set as S( fromList, member )
28import Data.Word
30import Foreign ( allocaArray, peekArray, Ptr )
31import Foreign.C.Types (CInt(..))
33import System.Posix.IO ( fdReadBuf
34 , setFdOption
35 , FdOption(..)
36 )
37import System.Posix.Types (Fd(..))
39data Config = Config
40 { singleEscPeriod :: Int -- ^ AKA VTIME. The default is 100000 microseconds or 0.1 seconds.
41 } deriving (Show, Eq)
43instance Default Config where
44 def = Config
45 { singleEscPeriod = 100000
46 }
48data Input = Input
49 { -- | Channel of events direct from input processing. Unlike 'next_event' this will not refresh
50 -- the display if the next event is an 'EvResize'.
51 _event_channel :: Chan Event
52 -- | Shuts down the input processing. This should return the terminal input state to before
53 -- the input initialized.
54 , shutdown_input :: IO ()
55 -- | Changes to this value are reflected after the next event.
56 , _config_ref :: IORef Config
57 -- | File descriptor used for input.
58 , _input_fd :: Fd
59 }
61makeLenses ''Input
63data KClass
64 = Valid Key [Modifier] [Char]
65 | Invalid
66 | Prefix
67 deriving(Show, Eq)
69data InputBuffer = InputBuffer
70 { _ptr :: Ptr Word8
71 , _size :: Int
72 }
74makeLenses ''InputBuffer
76data InputState = InputState
77 { _unprocessed_bytes :: String
78 , _applied_config :: Config
79 , _input_buffer :: InputBuffer
80 , _stop_request_ref :: IORef Bool
81 , _classifier :: String -> KClass
82 }
84makeLenses ''InputState
86type InputM a = StateT InputState (ReaderT Input IO) a
88-- this must be run on an OS thread dedicated to this input handling.
89-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
90loop_input_processor :: InputM ()
91loop_input_processor = do
92 read_from_device >>= add_bytes_to_process
93 valid_events <- many parse_event
94 forM_ valid_events emit
95 drop_invalid
96 stop_if_requested <|> loop_input_processor
98add_bytes_to_process :: String -> InputM ()
99add_bytes_to_process block = unprocessed_bytes <>= block
101emit :: Event -> InputM ()
102emit event = view event_channel >>= liftIO . flip writeChan event
104-- There should be two versions of this method:
105-- 1. using VMIN and VTIME when under the threaded runtime
106-- 2. emulating VMIN and VTIME in userspace when under the non-threaded runtime.
107read_from_device :: InputM String
108read_from_device = do
109 new_config <- view config_ref >>= liftIO . readIORef
110 old_config <- use applied_config
111 fd <- view input_fd
112 when (new_config /= old_config) $ do
113 liftIO $ apply_timing_config fd new_config
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
121apply_timing_config :: Fd -> Config -> IO ()
122apply_timing_config fd config =
123 let vtime = min 255 $ singleEscPeriod config `div` 100000
124 in set_term_timing fd 1 vtime
126parse_event :: InputM Event
127parse_event = do
128 c <- use classifier
129 b <- use unprocessed_bytes
130 case c b of
131 Valid k m remaining -> do
132 unprocessed_bytes .= remaining
133 return $ EvKey k m
134 _ -> mzero
136drop_invalid :: InputM ()
137drop_invalid = do
138 c <- use classifier
139 b <- use unprocessed_bytes
140 when (c b == Invalid) $ unprocessed_bytes .= []
142stop_if_requested :: InputM ()
143stop_if_requested = do
144 True <- (liftIO . readIORef) =<< use stop_request_ref
145 return ()
147-- This makes a kind of tri. Has space efficiency issues with large input blocks.
148-- Likely building a parser and just applying that would be better.
149-- I did not write this so I might just rewrite it for better understanding. Not the best of
150-- reasons...
151-- TODO: measure and rewrite if required.
152compile :: ClassifyTable -> [Char] -> KClass
153compile table = cl' where
154 -- take all prefixes and create a set of these
155 prefix_set = S.fromList $ concatMap (init . inits . fst) $ table
156 -- create a map from strings to event
157 event_for_input = flip M.lookup (M.fromList table)
158 cl' [] = Prefix
159 cl' input_block = case event_for_input input_block of
160 Just (EvKey k m) -> Valid k m []
161 Nothing -> case S.member input_block prefix_set of
162 True -> Prefix
163 -- if the input_block is exactly what is expected for an event then consume the whole
164 -- block and return the event
165 -- look up progressively large prefixes of the input block until an event is found
166 -- H: There will always be one match. The prefix_set contains, by definition, all
167 -- prefixes of an event.
168 False ->
169 let input_prefixes = init $ inits input_block
170 in case mapMaybe (\s -> (,) s `fmap` event_for_input s) input_prefixes of
171 (s,EvKey k m) : _ -> Valid k m (drop (length s) input_block)
172 -- neither a prefix or a full event. Might be interesting to log.
173 [] -> Invalid
175classify, classifyTab :: ClassifyTable -> [Char] -> KClass
177-- As soon as
178classify _table s@(c:_) | ord c >= 0xC2
179 = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
180classify table other
181 = classifyTab table other
183classifyUtf8 :: [Char] -> KClass
184classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
185 Just (unicodeChar, _) -> Valid (KChar unicodeChar) [] []
186 _ -> Invalid -- something bad happened; just ignore and continue.
188classifyTab table = compile table
190first :: (a -> b) -> (a,c) -> (b,c)
191first f (x,y) = (f x, y)
193utf8Length :: (Num t, Ord a, Num a) => a -> t
194utf8Length c
195 | c < 0x80 = 1
196 | c < 0xE0 = 2
197 | c < 0xF0 = 3
198 | otherwise = 4
200run_input_processor_loop :: ClassifyTable -> Input -> IORef Bool -> IO ()
201run_input_processor_loop classify_table input stop_flag = do
202 let buffer_size = 1024
203 allocaArray buffer_size $ \(buffer_ptr :: Ptr Word8) -> do
204 s0 <- InputState [] <$> readIORef (_config_ref input)
205 <*> pure (InputBuffer buffer_ptr buffer_size)
206 <*> pure stop_flag
207 <*> pure (classify classify_table)
208 runReaderT (evalStateT loop_input_processor s0) input
210-- This is an example of an algorithm where code coverage could be high, even 100%, but the
211-- algorithm still under tested. I should collect more of these examples...
212initInputForFd :: IORef Config -> ClassifyTable -> Fd -> IO Input
213initInputForFd config_ref classify_table input_fd = do
214 stop_flag <- newIORef False
215 input <- Input <$> newChan
216 <*> pure (writeIORef stop_flag True)
217 <*> pure config_ref
218 <*> pure input_fd
219 _ <- forkOS $ run_input_processor_loop classify_table input stop_flag
220 return input
222foreign import ccall "vty_set_term_timing" set_term_timing :: Fd -> Int -> Int -> IO ()