git.iko.soy/vty
on 021a059 help sign in
vty/src/Graphics/Vty/Input/Loop.hs
161 lines 5.7 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.Posix.IO (fdReadBuf)
32import System.Posix.Terminal
33import System.Posix.Types (Fd(..))
35data Input = Input
36 { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh
37 -- the display if the next event is an 'EvResize'.
38 _eventChannel :: Chan Event
39 -- | Shuts down the input processing. This should return the terminal input state to before
40 -- the input initialized.
41 , shutdownInput :: IO ()
42 -- | Changes to this value are reflected after the next event.
43 , _configRef :: IORef Config
44 -- | File descriptor used for input.
45 , _inputFd :: Fd
46 }
48makeLenses ''Input
50data InputBuffer = InputBuffer
51 { _ptr :: Ptr Word8
52 , _size :: Int
53 }
55makeLenses ''InputBuffer
57data InputState = InputState
58 { _unprocessedBytes :: String
59 , _appliedConfig :: Config
60 , _inputBuffer :: InputBuffer
61 , _stopRequestRef :: IORef Bool
62 , _classifier :: String -> KClass
63 }
65makeLenses ''InputState
67type InputM a = StateT InputState (ReaderT Input IO) a
69-- this must be run on an OS thread dedicated to this input handling.
70-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
71loopInputProcessor :: InputM ()
72loopInputProcessor = do
73 readFromDevice >>= addBytesToProcess
74 validEvents <- many parseEvent
75 forM_ validEvents emit
76 dropInvalid
77 stopIfRequested <|> loopInputProcessor
79addBytesToProcess :: String -> InputM ()
80addBytesToProcess block = unprocessedBytes <>= block
82emit :: Event -> InputM ()
83emit event = view eventChannel >>= liftIO . flip writeChan event
85-- There should be two versions of this method:
86-- 1. using VMIN and VTIME when under the threaded runtime
87-- 2. emulating VMIN and VTIME in userspace when under the non-threaded runtime.
88readFromDevice :: InputM String
89readFromDevice = do
90 newConfig <- view configRef >>= liftIO . readIORef
91 oldConfig <- use appliedConfig
92 fd <- view inputFd
93 when (newConfig /= oldConfig) $ do
94 liftIO $ applyTimingConfig fd newConfig
95 appliedConfig .= newConfig
96 bufferPtr <- use $ inputBuffer.ptr
97 maxBytes <- use $ inputBuffer.size
98 liftIO $ do
99 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
100 if bytesRead > 0
101 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
102 else return []
104applyTimingConfig :: Fd -> Config -> IO ()
105applyTimingConfig fd config =
106 let vtime = min 255 $ singleEscPeriod config `div` 100000
107 in setTermTiming fd 1 vtime
109parseEvent :: InputM Event
110parseEvent = do
111 c <- use classifier
112 b <- use unprocessedBytes
113 case c b of
114 Valid e remaining -> do
115 unprocessedBytes .= remaining
116 return e
117 _ -> mzero
119dropInvalid :: InputM ()
120dropInvalid = do
121 c <- use classifier
122 b <- use unprocessedBytes
123 when (c b == Invalid) $ unprocessedBytes .= []
125stopIfRequested :: InputM ()
126stopIfRequested = do
127 True <- (liftIO . readIORef) =<< use stopRequestRef
128 return ()
130runInputProcessorLoop :: ClassifyTable -> Input -> IORef Bool -> IO ()
131runInputProcessorLoop classifyTable input stopFlag = do
132 let bufferSize = 1024
133 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
134 s0 <- InputState [] <$> readIORef (_configRef input)
135 <*> pure (InputBuffer bufferPtr bufferSize)
136 <*> pure stopFlag
137 <*> pure (classify classifyTable)
138 runReaderT (evalStateT loopInputProcessor s0) input
140attributeControl :: Fd -> IO (IO (), IO ())
141attributeControl fd = do
142 original <- getTerminalAttributes fd
143 let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
144 , EnableEcho, ProcessInput, ExtendedFunctions
145 ]
146 let setAttrs = setTerminalAttributes fd vtyMode Immediately
147 unsetAttrs = setTerminalAttributes fd original Immediately
148 return (setAttrs,unsetAttrs)
150initInputForFd :: Config -> ClassifyTable -> Fd -> IO Input
151initInputForFd config classifyTable inFd = do
152 applyTimingConfig inFd config
153 stopFlag <- newIORef False
154 input <- Input <$> newChan
155 <*> pure (writeIORef stopFlag True)
156 <*> newIORef config
157 <*> pure inFd
158 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag
159 return input
161foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()