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