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