git.iko.soy/vty
on ebee723 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
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)