git.iko.soy/vty
on 07b7a89 help sign in
vty/src/Graphics/Vty/Input/Loop.hs
214 lines 8.2 kB history raw
1{-# LANGUAGE RecordWildCards #-}
2{-# OPTIONS_HADDOCK hide #-}
3{-# LANGUAGE NoMonomorphismRestriction #-}
4{-# LANGUAGE TemplateHaskell #-}
5{-# LANGUAGE CPP #-}
6-- | The input layer used to be a single function that correctly accounted for the non-threaded
7-- runtime by emulating the terminal VMIN adn VTIME handling. This has been removed and replace with
8-- a more straightforward parser. The non-threaded runtime is no longer supported.
9--
10-- This is an example of an algorithm where code coverage could be high, even 100%, but the
11-- behavior is still under tested. I should collect more of these examples...
12--
13-- reference: http://www.unixwiz.net/techtips/termios-vmin-vtime.html
14module Graphics.Vty.Input.Loop where
16import Graphics.Vty.Config
17import Graphics.Vty.Input.Classify
18import Graphics.Vty.Input.Events
20import Control.Applicative
21import Control.Concurrent
22import Control.Concurrent.MVar
23import Control.Exception (mask, try, SomeException)
24import Control.Lens
25import Control.Monad (when, mzero, forM_)
26import Control.Monad.IO.Class (liftIO)
27import Control.Monad.Trans.State (StateT(..), evalStateT)
28import Control.Monad.Trans.Reader (ReaderT(..))
30import Data.Char
31import Data.IORef
32import Data.Word (Word8)
34import Foreign ( allocaArray, peekArray, Ptr )
35import Foreign.C.Types (CInt(..))
37import System.IO
38import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
39import System.Posix.Terminal
40import System.Posix.Types (Fd(..))
42import Text.Printf (hPrintf)
44data Input = Input
45 { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh
46 -- the display if the next event is an 'EvResize'.
47 _eventChannel :: Chan Event
48 -- | Shuts down the input processing. This should return the terminal input state to before
49 -- the input initialized.
50 , shutdownInput :: IO ()
51 -- | Changes to this value are reflected after the next event.
52 , _configRef :: IORef Config
53 -- | input debug log
54 , _inputDebug :: Maybe Handle
55 }
57makeLenses ''Input
59data InputBuffer = InputBuffer
60 { _ptr :: Ptr Word8
61 , _size :: Int
62 }
64makeLenses ''InputBuffer
66data InputState = InputState
67 { _unprocessedBytes :: String
68 , _appliedConfig :: Config
69 , _inputBuffer :: InputBuffer
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 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 let Just fd = inputFd newConfig
112 when (newConfig /= oldConfig) $ do
113 logMsg $ "new config: " ++ show newConfig
114 liftIO $ applyConfig fd newConfig
115 appliedConfig .= newConfig
116 bufferPtr <- use $ inputBuffer.ptr
117 maxBytes <- use $ inputBuffer.size
118 stringRep <- liftIO $ do
119 -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses
120 -- this provides a location to be interrupted prior to the foreign call. If there is input
121 -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime
122 -- terminal setting.
123 threadWaitRead fd
124 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
125 if bytesRead > 0
126 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
127 else return []
128 when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
129 return stringRep
131applyConfig :: Fd -> Config -> IO ()
132applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime })
133 = setTermTiming fd theVmin (theVtime `div` 100)
134applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration"
136parseEvent :: InputM Event
137parseEvent = do
138 c <- use classifier
139 b <- use unprocessedBytes
140 case c b of
141 Valid e remaining -> do
142 logMsg $ "valid parse: " ++ show e
143 logMsg $ "remaining: " ++ show remaining
144 unprocessedBytes .= remaining
145 return e
146 _ -> mzero
148dropInvalid :: InputM ()
149dropInvalid = do
150 c <- use classifier
151 b <- use unprocessedBytes
152 when (c b == Invalid) $ do
153 logMsg "dropping input bytes"
154 unprocessedBytes .= []
156runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
157runInputProcessorLoop classifyTable input = do
158 let bufferSize = 1024
159 allocaArray bufferSize $ \(bufferPtr :: Ptr Word8) -> do
160 s0 <- InputState [] <$> readIORef (_configRef input)
161 <*> pure (InputBuffer bufferPtr bufferSize)
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 -> ClassifyMap -> IO()
176logInitialInputState input classifyTable = case _inputDebug input of
177 Nothing -> return ()
178 Just h -> do
179 Config{ vmin = Just theVmin
180 , vtime = Just theVtime
181 , termName = Just theTerm, .. } <- readIORef $ _configRef input
182 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
183 forM_ classifyTable $ \i -> case i of
184 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
185 (show inBytes)
186 (show k)
187 (show mods)
188 _ -> return ()
190initInput :: Config -> ClassifyMap -> IO Input
191initInput config classifyTable = do
192 let Just fd = inputFd config
193 setFdOption fd NonBlockingRead False
194 applyConfig fd config
195 stopSync <- newEmptyMVar
196 input <- Input <$> newChan
197 <*> pure (return ())
198 <*> newIORef config
199 <*> maybe (return Nothing)
200 (\f -> Just <$> openFile f AppendMode)
201 (debugLog config)
202 logInitialInputState input classifyTable
203 inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input)
204 (\_ -> putMVar stopSync ())
205 let killAndWait = do
206 killThread inputThread
207 takeMVar stopSync
208 return $ input { shutdownInput = killAndWait }
210foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()
212forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
213forkOSFinally action and_then =
214 mask $ \restore -> forkOS $ try (restore action) >>= and_then