git.iko.soy/vty
on ddd61dd help sign in
vty/src/Graphics/Vty/Input/Loop.hs
206 lines 7.6 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.Lens
23import Control.Monad (when, mzero, forM_)
24import Control.Monad.IO.Class (liftIO)
25import Control.Monad.Trans.State (StateT(..), evalStateT)
26import Control.Monad.Trans.Reader (ReaderT(..))
28import Data.Char
29import Data.IORef
30import Data.Word (Word8)
32import Foreign ( allocaArray, peekArray, Ptr )
33import Foreign.C.Types (CInt(..))
35import System.IO
36import System.Posix.IO (fdReadBuf, setFdOption, FdOption(..))
37import System.Posix.Terminal
38import System.Posix.Types (Fd(..))
40import Text.Printf (hPrintf)
42data Input = Input
43 { -- | Channel of events direct from input processing. Unlike 'nextEvent' this will not refresh
44 -- the display if the next event is an 'EvResize'.
45 _eventChannel :: Chan Event
46 -- | Shuts down the input processing. This should return the terminal input state to before
47 -- the input initialized.
48 , shutdownInput :: IO ()
49 -- | Changes to this value are reflected after the next event.
50 , _configRef :: IORef Config
51 -- | input debug log
52 , _inputDebug :: Maybe Handle
53 }
55makeLenses ''Input
57data InputBuffer = InputBuffer
58 { _ptr :: Ptr Word8
59 , _size :: Int
60 }
62makeLenses ''InputBuffer
64data InputState = InputState
65 { _unprocessedBytes :: String
66 , _appliedConfig :: Config
67 , _inputBuffer :: InputBuffer
68 , _stopRequestRef :: IORef Bool
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 stopIfRequested <|> 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 bytesRead <- fdReadBuf fd bufferPtr (fromIntegral maxBytes)
119 if bytesRead > 0
120 then fmap (map $ chr . fromIntegral) $ peekArray (fromIntegral bytesRead) bufferPtr
121 else return []
122 when (not $ null stringRep) $ logMsg $ "input bytes: " ++ show stringRep
123 return stringRep
125applyConfig :: Fd -> Config -> IO ()
126applyConfig fd (Config{ vmin = Just theVmin, vtime = Just theVtime })
127 = setTermTiming fd theVmin (theVtime `div` 100)
128applyConfig _ _ = fail "(vty) applyConfig was not provided a complete configuration"
130parseEvent :: InputM Event
131parseEvent = do
132 c <- use classifier
133 b <- use unprocessedBytes
134 case c b of
135 Valid e remaining -> do
136 logMsg $ "valid parse: " ++ show e
137 logMsg $ "remaining: " ++ show remaining
138 unprocessedBytes .= remaining
139 return e
140 _ -> mzero
142dropInvalid :: InputM ()
143dropInvalid = do
144 c <- use classifier
145 b <- use unprocessedBytes
146 when (c b == Invalid) $ do
147 logMsg "dropping input bytes"
148 unprocessedBytes .= []
150stopIfRequested :: InputM ()
151stopIfRequested = do
152 True <- (liftIO . readIORef) =<< use stopRequestRef
153 return ()
155runInputProcessorLoop :: ClassifyMap -> Input -> IORef Bool -> IO ()
156runInputProcessorLoop classifyTable input stopFlag = 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 stopFlag
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 stopFlag <- newIORef False
196 input <- Input <$> newChan
197 <*> pure (writeIORef stopFlag True)
198 <*> newIORef config
199 <*> maybe (return Nothing)
200 (\f -> Just <$> openFile f AppendMode)
201 (debugLog config)
202 logInitialInputState input classifyTable
203 _ <- forkOS $ runInputProcessorLoop classifyTable input stopFlag
204 return input
206foreign import ccall "vty_set_term_timing" setTermTiming :: Fd -> Int -> Int -> IO ()