git.iko.soy/vty
on da216cb help sign in
vty/src/Graphics/Vty/Input/Loop.hs
204 lines 7.6 kB history raw
1{-# OPTIONS_HADDOCK hide #-}
2{-# LANGUAGE NoMonomorphismRestriction #-}
3{-# LANGUAGE TemplateHaskell #-}
4{-# LANGUAGE CPP #-}
5-- | The input layer used to be a single function that correctly accounted for the non-threaded
6-- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with
7-- a more straightforward parser. The non-threaded runtime is no longer supported.
8--
9-- This is an example of an algorithm where code coverage could be high, even 100%, but the
10-- behavior is still under tested. I should collect more of these examples...
11--
12-- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html
13module Graphics.Vty.Input.Loop where
15import Graphics.Vty.Config
16import Graphics.Vty.Input.Classify
17import Graphics.Vty.Input.Events
19import Control.Applicative
20import Control.Concurrent
21import Control.Lens
22import Control.Monad (when, mzero, forM_)
23import Control.Monad.IO.Class (liftIO)
24import Control.Monad.Trans.State (StateT(..), evalStateT)
25import Control.Monad.Trans.Reader (ReaderT(..))
27import Data.Char
28import Data.IORef
29import Data.Word (Word8)
31import Foreign ( allocaArray, peekArray, Ptr )
32import Foreign.C.Types (CInt(..))
34import System.IO
35import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
36import System.Posix.Terminal
37import System.Posix.Types (Fd(..))
39import Text.Printf (hPrintf)
41data Input = Input
42 { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh
43 -- the display if the next event is an 'EvResize'.
44 _eventChannel :: Chan Event
45 -- | Shuts down the input processing. This should return the terminal input state to before
46 -- the input initialized.
47 , shutdownInput :: IO ()
48 -- | Changes to this value are reflected after the next event.
49 , _configRef :: IORef Config
50 -- | File descriptor used for input.
51 , _inputFd :: Fd
52 -- | input debug log
53 , _inputDebug :: Maybe Handle
54 }
56makeLenses ''Input
58data InputBuffer = InputBuffer
59 { _ptr :: Ptr Word8
60 , _size :: Int
61 }
63makeLenses ''InputBuffer
65data InputState = InputState
66 { _unprocessedBytes :: String
67 , _appliedConfig :: Config
68 , _inputBuffer :: InputBuffer
69 , _stopRequestRef :: IORef Bool
70 , _classifier :: String -> KClass
71 }
73makeLenses ''InputState
75type InputM a = StateT InputState (ReaderT Input IO) a
77logMsg :: String -> InputM ()
78logMsg msg = do
79 d <- view inputDebug
80 case d of
81 Nothing -> return ()
82 Just h -> liftIO $ hPutStrLn h msg >> hFlush h
84-- this must be run on an OS thread dedicated to this input handling.
85-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
86loopInputProcessor :: InputM ()
87loopInputProcessor = do
88 readFromDevice >>= addBytesToProcess
89 validEvents <- many parseEvent
90 forM_ validEvents emit
91 dropInvalid
92 stopIfRequested <|> loopInputProcessor
94addBytesToProcess :: String -> InputM ()
95addBytesToProcess block = unprocessedBytes <>= block
97emit :: Event -> InputM ()
98emit event = do
99 logMsg $ "parsed event: " ++ show event
100 view eventChannel >>= liftIO . flip writeChan event
102-- The timing requirements are assured by the VMIN and VTIME set for the device.
103--
104-- Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case
105-- satisfies precondition.
106-- TODO: When under the non-threaded runtime emulate VMIN and VTIME
107readFromDevice :: InputM String
108readFromDevice = do
109 newConfig <- view configRef >>= liftIO . readIORef
110 oldConfig <- use appliedConfig
111 fd <- view inputFd
112 when (newConfig /= oldConfig) $ do
113 logMsg $ "new config: " ++ show newConfig
114 liftIO $ applyTimingConfig fd newConfig
115 appliedConfig .= newConfig
116 bufferPtr <- use $ inputBuffer.ptr
117 maxBytes <- use $ inputBuffer.size
118 stringRep <- liftIO $ do
119 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
120 if bytesRead > 0
121 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
122 else return []
123 when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
124 return stringRep
126applyTimingConfig :: Fd -> Config -> IO ()
127applyTimingConfig fd config = setTermTiming fd (derivedVmin config)
128 (derivedVtime config `div` 100)
130parseEvent :: InputM Event
131parseEvent = do
132 c <- use classifier
133 b <- use unprocessedBytes
134 case c b of
135 Valid e remaining -> do
136 logMsg $ "valid parse: " ++ show e
137 logMsg $ "remaining: " ++ show remaining
138 unprocessedBytes .= remaining
139 return e
140 _ -> mzero
142dropInvalid :: InputM ()
143dropInvalid = do
144 c <- use classifier
145 b <- use unprocessedBytes
146 when (c b == Invalid) $ do
147 logMsg "dropping input bytes"
148 unprocessedBytes .= []
150stopIfRequested :: InputM ()
151stopIfRequested = do
152 True <- (liftIO . readIORef) =<< use stopRequestRef
153 return ()
155runInputProcessorLoop :: ClassifyMap -> Input -> IORef Bool -> IO ()
156runInputProcessorLoop classifyTable input stopFlag = do
157 let bufferSize = 1024
158 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
159 s0 <- InputState [] <$> readIORef (_configRef input)
160 <*> pure (InputBuffer bufferPtr bufferSize)
161 <*> pure stopFlag
162 <*> pure (classify classifyTable)
163 runReaderT (evalStateT loopInputProcessor s0) input
165attributeControl :: Fd -> IO (IO (), IO ())
166attributeControl fd = do
167 original <- getTerminalAttributes fd
168 let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
169 , EnableEcho, ProcessInput, ExtendedFunctions
170 ]
171 let setAttrs = setTerminalAttributes fd vtyMode Immediately
172 unsetAttrs = setTerminalAttributes fd original Immediately
173 return (setAttrs,unsetAttrs)
175logInitialInputState :: Input -> String -> ClassifyMap -> IO()
176logInitialInputState input termName classifyTable = case _inputDebug input of
177 Nothing -> return ()
178 Just h -> do
179 config <- readIORef $ _configRef input
180 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (vmin config, vtime config))
181 forM_ classifyTable $ \i -> case i of
182 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show termName)
183 (show inBytes)
184 (show k)
185 (show mods)
186 _ -> return ()
188initInputForFd :: Config -> String -> ClassifyMap -> Fd -> IO Input
189initInputForFd config termName classifyTable inFd = do
190 setFdOption inFd NonBlockingRead False
191 applyTimingConfig inFd config
192 stopFlag <- newIORef False
193 input <- Input <$> newChan
194 <*> pure (writeIORef stopFlag True)
195 <*> newIORef config
196 <*> pure inFd
197 <*> maybe (return Nothing)
198 (\f -> Just <$> openFile f AppendMode)
199 (debugLog config)
200 logInitialInputState input termName classifyTable
201 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag
202 return input
204foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()