git.iko.soy/vty
on 522b740 help sign in
vty/src/Graphics/Vty/Input/Loop.hs
179 lines 6.4 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
74-- this must be run on an OS thread dedicated to this input handling.
75-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
76loopInputProcessor :: InputM ()
77loopInputProcessor = do
78 readFromDevice >>= addBytesToProcess
79 validEvents <- many parseEvent
80 forM_ validEvents emit
81 dropInvalid
82 stopIfRequested <|> loopInputProcessor
84addBytesToProcess :: String -> InputM ()
85addBytesToProcess block = unprocessedBytes <>= block
87emit :: Event -> InputM ()
88emit event = view eventChannel >>= liftIO . flip writeChan event
90-- There should be two versions of this method:
91-- 1. using VMIN and VTIME when under the threaded runtime
92-- 2. emulating VMIN and VTIME in userspace when under the non-threaded runtime.
93readFromDevice :: InputM String
94readFromDevice = do
95 newConfig <- view configRef >>= liftIO . readIORef
96 oldConfig <- use appliedConfig
97 fd <- view inputFd
98 when (newConfig /= oldConfig) $ do
99 liftIO $ applyTimingConfig fd newConfig
100 appliedConfig .= newConfig
101 bufferPtr <- use $ inputBuffer.ptr
102 maxBytes <- use $ inputBuffer.size
103 liftIO $ do
104 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
105 if bytesRead > 0
106 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
107 else return []
109applyTimingConfig :: Fd -> Config -> IO ()
110applyTimingConfig fd config =
111 let vtime = min 255 $ singleEscPeriod config `div` 100000
112 in setTermTiming fd 1 vtime
114parseEvent :: InputM Event
115parseEvent = do
116 c <- use classifier
117 b <- use unprocessedBytes
118 case c b of
119 Valid e remaining -> do
120 unprocessedBytes .= remaining
121 return e
122 _ -> mzero
124dropInvalid :: InputM ()
125dropInvalid = do
126 c <- use classifier
127 b <- use unprocessedBytes
128 when (c b == Invalid) $ unprocessedBytes .= []
130stopIfRequested :: InputM ()
131stopIfRequested = do
132 True <- (liftIO . readIORef) =<< use stopRequestRef
133 return ()
135runInputProcessorLoop :: ClassifyTable -> Input -> IORef Bool -> IO ()
136runInputProcessorLoop classifyTable input stopFlag = do
137 let bufferSize = 1024
138 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
139 s0 <- InputState [] <$> readIORef (_configRef input)
140 <*> pure (InputBuffer bufferPtr bufferSize)
141 <*> pure stopFlag
142 <*> pure (classify classifyTable)
143 runReaderT (evalStateT loopInputProcessor s0) input
145attributeControl :: Fd -> IO (IO (), IO ())
146attributeControl fd = do
147 original <- getTerminalAttributes fd
148 let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
149 , EnableEcho, ProcessInput, ExtendedFunctions
150 ]
151 let setAttrs = setTerminalAttributes fd vtyMode Immediately
152 unsetAttrs = setTerminalAttributes fd original Immediately
153 return (setAttrs,unsetAttrs)
155logClassifyTable :: Input -> ClassifyTable -> IO()
156logClassifyTable input classifyTable = case _inputDebug input of
157 Nothing -> return ()
158 Just h -> do
159 forM_ classifyTable $ \i -> case i of
160 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s\n" (show inBytes)
161 (show k)
162 (show mods)
163 _ -> return ()
165initInputForFd :: Config -> ClassifyTable -> Fd -> IO Input
166initInputForFd config classifyTable inFd = do
167 applyTimingConfig inFd config
168 stopFlag <- newIORef False
169 input <- Input <$> newChan
170 <*> pure (writeIORef stopFlag True)
171 <*> newIORef config
172 <*> pure inFd
173 <*> maybe Nothing (\f -> Just <$> openFile f AppendMode)
174 (debugLog config)
175 logClassifyTable classifyTable
176 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag
177 return input
179foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()