git.iko.soy/vty
on 4877aaa help sign in
vty/src/Graphics/Vty/Input/Loop.hs
213 lines 8.1 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.Exception (mask, try, SomeException)
23import Control.Lens
24import Control.Monad (when, mzero, forM_)
25import Control.Monad.IO.Class (liftIO)
26import Control.Monad.Trans.State (StateT(..), evalStateT)
27import Control.Monad.Trans.Reader (ReaderT(..))
29import Data.Char
30import Data.IORef
31import Data.Word (Word8)
33import Foreign ( allocaArray, peekArray, Ptr )
34import Foreign.C.Types (CInt(..))
36import System.IO
37import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
38import System.Posix.Terminal
39import System.Posix.Types (Fd(..))
41import Text.Printf (hPrintf)
43data Input = Input
44 { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh
45 -- the display if the next event is an 'EvResize'.
46 _eventChannel :: Chan Event
47 -- | Shuts down the input processing. This should return the terminal input state to before
48 -- the input initialized.
49 , shutdownInput :: IO ()
50 -- | Changes to this value are reflected after the next event.
51 , _configRef :: IORef Config
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 , _classifier :: String -> KClass
70 }
72makeLenses ''InputState
74type InputM a = StateT InputState (ReaderT Input IO) a
76logMsg :: String -> InputM ()
77logMsg msg = do
78 d <- view inputDebug
79 case d of
80 Nothing -> return ()
81 Just h -> liftIO $ hPutStrLn h msg >> hFlush h
83-- this must be run on an OS thread dedicated to this input handling.
84-- otherwise the terminal timing read behavior will block the execution of the lightweight threads.
85loopInputProcessor :: InputM ()
86loopInputProcessor = do
87 readFromDevice >>= addBytesToProcess
88 validEvents <- many parseEvent
89 forM_ validEvents emit
90 dropInvalid
91 loopInputProcessor
93addBytesToProcess :: String -> InputM ()
94addBytesToProcess block = unprocessedBytes <>= block
96emit :: Event -> InputM ()
97emit event = do
98 logMsg $ "parsed event: " ++ show event
99 view eventChannel >>= liftIO . flip writeChan event
101-- The timing requirements are assured by the VMIN and VTIME set for the device.
102--
103-- Precondition: Under the threaded runtime. Only current use is from a forkOS thread. That case
104-- satisfies precondition.
105-- TODO: When under the non-threaded runtime emulate VMIN and VTIME
106readFromDevice :: InputM String
107readFromDevice = do
108 newConfig <- view configRef >>= liftIO . readIORef
109 oldConfig <- use appliedConfig
110 let Just fd = inputFd newConfig
111 when (newConfig /= oldConfig) $ do
112 logMsg $ "new config: " ++ show newConfig
113 liftIO $ applyConfig fd newConfig
114 appliedConfig .= newConfig
115 bufferPtr <- use $ inputBuffer.ptr
116 maxBytes <- use $ inputBuffer.size
117 stringRep <- liftIO $ do
118 -- The killThread used in shutdownInput will not interrupt the foreign call fdReadBuf uses
119 -- this provides a location to be interrupted prior to the foreign call. If there is input
120 -- on the FD then the fdReadBuf will return in a finite amount of time due to the vtime
121 -- terminal setting.
122 threadWaitRead fd
123 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
124 if bytesRead > 0
125 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
126 else return []
127 when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
128 return stringRep
130applyConfig :: Fd -> Config -> IO ()
131applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime })
132 = setTermTiming fd theVmin (theVtime `div` 100)
133applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration"
135parseEvent :: InputM Event
136parseEvent = do
137 c <- use classifier
138 b <- use unprocessedBytes
139 case c b of
140 Valid e remaining -> do
141 logMsg $ "valid parse: " ++ show e
142 logMsg $ "remaining: " ++ show remaining
143 unprocessedBytes .= remaining
144 return e
145 _ -> mzero
147dropInvalid :: InputM ()
148dropInvalid = do
149 c <- use classifier
150 b <- use unprocessedBytes
151 when (c b == Invalid) $ do
152 logMsg "dropping input bytes"
153 unprocessedBytes .= []
155runInputProcessorLoop :: ClassifyMap -> Input -> IO ()
156runInputProcessorLoop classifyTable input = 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 (classify classifyTable)
162 runReaderT (evalStateT loopInputProcessor s0) input
164attributeControl :: Fd -> IO (IO (), IO ())
165attributeControl fd = do
166 original <- getTerminalAttributes fd
167 let vtyMode = foldl withoutMode original [ StartStopOutput, KeyboardInterrupts
168 , EnableEcho, ProcessInput, ExtendedFunctions
169 ]
170 let setAttrs = setTerminalAttributes fd vtyMode Immediately
171 unsetAttrs = setTerminalAttributes fd original Immediately
172 return (setAttrs,unsetAttrs)
174logInitialInputState :: Input -> ClassifyMap -> IO()
175logInitialInputState input classifyTable = case _inputDebug input of
176 Nothing -> return ()
177 Just h -> do
178 Config{ vmin = Just theVmin
179 , vtime = Just theVtime
180 , termName = Just theTerm, .. } <- readIORef $ _configRef input
181 _ <- hPrintf h "initial (vmin,vtime): %s\n" (show (theVmin, theVtime))
182 forM_ classifyTable $ \i -> case i of
183 (inBytes, EvKey k mods) -> hPrintf h "map %s %s %s %s\n" (show theTerm)
184 (show inBytes)
185 (show k)
186 (show mods)
187 _ -> return ()
189initInput :: Config -> ClassifyMap -> IO Input
190initInput config classifyTable = do
191 let Just fd = inputFd config
192 setFdOption fd NonBlockingRead False
193 applyConfig fd config
194 stopSync <- newEmptyMVar
195 input <- Input <$> newChan
196 <*> pure (return ())
197 <*> newIORef config
198 <*> maybe (return Nothing)
199 (\f -> Just <$> openFile f AppendMode)
200 (debugLog config)
201 logInitialInputState input classifyTable
202 inputThread <- forkOSFinally (runInputProcessorLoop classifyTable input)
203 (\_ -> putMVar stopSync ())
204 let killAndWait = do
205 killThread inputThread
206 takeMVar stopSync
207 return $ input { shutdownInput = killAndWait }
209foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()
211forkOSFinally :: IO a -> (Either SomeException a -> IO ()) -> IO ThreadId
212forkOSFinally action and_then =
213 mask $ \restore -> forkOS $ try (restore action) >>= and_then