git.iko.soy/vty
on 4aceef7 help sign in
vty/src/Graphics/Vty/Input/Loop.hs
193 lines 6.9 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.
7--
8-- This is an example of an algorithm where code coverage could be high, even 100%, but the
9-- behavior is still under tested. I should collect more of these examples...
10module Graphics.Vty.Input.Loop where
12import Graphics.Vty.Config
13import Graphics.Vty.Input.Classify
14import Graphics.Vty.Input.Events
16import Control.Applicative
17import Control.Concurrent
18import Control.Lens
19import Control.Monad (when, mzero, forM_)
20import Control.Monad.IO.Class (liftIO)
21import Control.Monad.Trans.State (StateT(..), evalStateT)
22import Control.Monad.Trans.Reader (ReaderT(..))
24import Data.Char
25import Data.IORef
26import Data.Word (Word8)
28import Foreign ( allocaArray, peekArray, Ptr )
29import Foreign.C.Types (CInt(..))
31import System.IO
32import System.Posix.IO (fdReadBuf)
33import System.Posix.Terminal
34import System.Posix.Types (Fd(..))
36import Text.Printf (hPrintf)
38data Input = Input
39 { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh
40 -- the display if the next event is an 'EvResize'.
41 _eventChannel :: Chan Event
42 -- | Shuts down the input processing. This should return the terminal input state to before
43 -- the input initialized.
44 , shutdownInput :: IO ()
45 -- | Changes to this value are reflected after the next event.
46 , _configRef :: IORef Config
47 -- | File descriptor used for input.
48 , _inputFd :: Fd
49 -- | input debug log
50 , _inputDebug :: Maybe Handle
51 }
53makeLenses ''Input
55data InputBuffer = InputBuffer
56 { _ptr :: Ptr Word8
57 , _size :: Int
58 }
60makeLenses ''InputBuffer
62data InputState = InputState
63 { _unprocessedBytes :: String
64 , _appliedConfig :: Config
65 , _inputBuffer :: InputBuffer
66 , _stopRequestRef :: IORef Bool
67 , _classifier :: String -> KClass
68 }
70makeLenses ''InputState
72type InputM a = StateT InputState (ReaderT Input IO) a
74logMsg :: String -> InputM ()
75logMsg msg = do
76 d <- view inputDebug
77 case d of
78 Nothing -> return ()
79 Just h -> liftIO $ hPutStrLn h msg >> hFlush h
81-- this must be run on an OS thread dedicated to this input handling.
82-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
83loopInputProcessor :: InputM ()
84loopInputProcessor = do
85 readFromDevice >>= addBytesToProcess
86 validEvents <- many parseEvent
87 forM_ validEvents emit
88 dropInvalid
89 stopIfRequested <|> loopInputProcessor
91addBytesToProcess :: String -> InputM ()
92addBytesToProcess block = unprocessedBytes <>= block
94emit :: Event -> InputM ()
95emit event = do
96 logMsg $ "parsed event: " ++ show event
97 view eventChannel >>= liftIO . flip writeChan event
99-- The timing requirements are assured by the VMIN and VTIME set for the device.
100--
101-- Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case
102-- satisfies precondition.
103-- TODO: When under the non-threaded runtime emulate VMIN and VTIME
104readFromDevice :: InputM String
105readFromDevice = do
106 newConfig <- view configRef >>= liftIO . readIORef
107 oldConfig <- use appliedConfig
108 fd <- view inputFd
109 when (newConfig /= oldConfig) $ do
110 liftIO $ applyTimingConfig fd newConfig
111 appliedConfig .= newConfig
112 bufferPtr <- use $ inputBuffer.ptr
113 maxBytes <- use $ inputBuffer.size
114 stringRep <- liftIO $ do
115 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
116 if bytesRead > 0
117 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
118 else return []
119 logMsg $ "input bytes: " ++ show stringRep
120 return stringRep
122applyTimingConfig :: Fd -> Config -> IO ()
123applyTimingConfig fd config =
124 let vtime = min 255 $ singleEscPeriod config `div` 100000
125 in setTermTiming fd 1 vtime
127parseEvent :: InputM Event
128parseEvent = do
129 c <- use classifier
130 b <- use unprocessedBytes
131 case c b of
132 Valid e remaining -> do
133 unprocessedBytes .= remaining
134 return e
135 _ -> mzero
137dropInvalid :: InputM ()
138dropInvalid = do
139 c <- use classifier
140 b <- use unprocessedBytes
141 when (c b == Invalid) $ unprocessedBytes .= []
143stopIfRequested :: InputM ()
144stopIfRequested = do
145 True <- (liftIO . readIORef) =<< use stopRequestRef
146 return ()
148runInputProcessorLoop :: ClassifyTable -> Input -> IORef Bool -> IO ()
149runInputProcessorLoop classifyTable input stopFlag = do
150 let bufferSize = 1024
151 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
152 s0 <- InputState [] <$> readIORef (_configRef input)
153 <*> pure (InputBuffer bufferPtr bufferSize)
154 <*> pure stopFlag
155 <*> pure (classify classifyTable)
156 runReaderT (evalStateT loopInputProcessor s0) input
158attributeControl :: Fd -> IO (IO (), IO ())
159attributeControl fd = do
160 original <- getTerminalAttributes fd
161 let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
162 , EnableEcho, ProcessInput, ExtendedFunctions
163 ]
164 let setAttrs = setTerminalAttributes fd vtyMode Immediately
165 unsetAttrs = setTerminalAttributes fd original Immediately
166 return (setAttrs,unsetAttrs)
168logClassifyTable :: Input -> ClassifyTable -> IO()
169logClassifyTable input classifyTable = case _inputDebug input of
170 Nothing -> return ()
171 Just h -> do
172 forM_ classifyTable $ \i -> case i of
173 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s\n" (show inBytes)
174 (show k)
175 (show mods)
176 _ -> return ()
178initInputForFd :: Config -> ClassifyTable -> Fd -> IO Input
179initInputForFd config classifyTable inFd = do
180 applyTimingConfig inFd config
181 stopFlag <- newIORef False
182 input <- Input <$> newChan
183 <*> pure (writeIORef stopFlag True)
184 <*> newIORef config
185 <*> pure inFd
186 <*> maybe (return Nothing)
187 (\f -> Just <$> openFile f AppendMode)
188 (debugLog config)
189 logClassifyTable input classifyTable
190 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag
191 return input
193foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()