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