git.iko.soy/vty
on fd3df90 help sign in
vty/src/Graphics/Vty/LLInput.hs
250 lines 10 kB history raw
1{-# LANGUAGE ScopedTypeVariables #-}
2-- Copyright 2009-2010 Corey O'Connor
3{-# OPTIONS_GHC -Wall #-}
4{-# LANGUAGE ForeignFunctionInterface #-}
5module Graphics.Vty.LLInput ( Key(..)
6 , Modifier(..)
7 , Button(..)
8 , Event(..)
9 , initTermInput
10 )
11 where
13import Data.Char
14import Data.Maybe ( mapMaybe
15 )
16import Data.List( inits )
17import Data.Word
18import qualified Data.Map as M( fromList, lookup )
19import qualified Data.Set as S( fromList, member )
21import Codec.Binary.UTF8.Generic (decode)
23import Control.Monad (when)
24import Control.Concurrent
25import Control.Exception
27import System.Console.Terminfo
29import System.Posix.Signals.Exts
30import System.Posix.Terminal
31import System.Posix.IO ( stdInput
32 ,fdReadBuf
33 ,setFdOption
34 ,FdOption(..)
35 )
37import Foreign ( alloca, poke, peek, Ptr )
39-- |Representations of non-modifier keys.
40data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns
41 | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KNP5 | KUp | KMenu
42 | KLeft | KDown | KRight | KEnter
43 deriving (Eq,Show,Ord)
45-- |Modifier keys. Key codes are interpreted such that users are more likely to
46-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will
47-- generally correspond to the physical Alt key.
48data Modifier = MShift | MCtrl | MMeta | MAlt
49 deriving (Eq,Show,Ord)
51-- |Mouse buttons. Not yet used.
52data Button = BLeft | BMiddle | BRight
53 deriving (Eq,Show,Ord)
55-- |Generic events.
56data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier]
57 | EvResize Int Int
58 deriving (Eq,Show,Ord)
60data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char]
61 deriving(Show)
63-- | Set up the terminal for input. Returns a function which reads key
64-- events, and a function for shutting down the terminal access.
65initTermInput :: Int -> Terminal -> IO (IO Event, IO ())
66initTermInput escDelay terminal = do
67 eventChannel <- newChan
68 inputChannel <- newChan
69 hadInput <- newEmptyMVar
70 oattr <- getTerminalAttributes stdInput
71 let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts,
72 EnableEcho, ProcessInput, ExtendedFunctions]
73 setTerminalAttributes stdInput nattr Immediately
74 set_term_timing
75 let inputToEventThread :: IO ()
76 inputToEventThread = loop []
77 where loop kb = case (classify kb) of
78 Prefix -> do c <- readChan inputChannel
79 loop (kb ++ [c])
80 Invalid -> do c <- readChan inputChannel
81 loop [c]
82 MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s
83 Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""
85 finishAtomicInput = writeChan inputChannel '\xFFFE'
87 inputThread :: IO ()
88 inputThread = do
89 _ <- alloca $ \(input_buffer :: Ptr Word8) -> do
90 let loop = do
91 setFdOption stdInput NonBlockingRead False
92 threadWaitRead stdInput
93 setFdOption stdInput NonBlockingRead True
94 _ <- try readAll :: IO (Either IOException ())
95 when (escDelay == 0) finishAtomicInput
96 loop
97 readAll = do
98 poke input_buffer 0
99 bytes_read <- fdReadBuf stdInput input_buffer 1
100 input_char <- fmap (chr . fromIntegral) $ peek input_buffer
101 when (bytes_read > 0) $ do
102 _ <- tryPutMVar hadInput () -- signal input
103 writeChan inputChannel input_char
104 readAll
105 loop
106 return ()
108 -- | If there is no input for some time, this thread puts '\xFFFE' in the
109 -- inputChannel.
110 noInputThread :: IO ()
111 noInputThread = when (escDelay > 0) loop
112 where loop = do
113 takeMVar hadInput -- wait for some input
114 threadDelay escDelay -- microseconds
115 hadNoInput <- isEmptyMVar hadInput -- no input yet?
116 -- TODO(corey): there is a race between here and the inputThread.
117 when hadNoInput $ do
118 finishAtomicInput
119 loop
122 compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass
123 compile lst = cl' where
124 lst' = concat lst
125 pfx = S.fromList $ concatMap (init . inits . fst) $ lst'
126 mlst = M.fromList lst'
127 cl' str = case S.member str pfx of
128 True -> Prefix
129 False -> case M.lookup str mlst of
130 Just (k,m) -> Valid k m
131 Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of
132 (s,(k,m)) -> MisPfx k m (drop (length s) str)
134 -- ANSI specific bits
137 classify, classifyTab :: [Char] -> KClass
139 -- As soon as
140 classify "\xFFFE" = Invalid
141 classify s@(c:_) | ord c >= 0xC2 =
142 if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
143 classify other = classifyTab other
145 classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
146 Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []
147 _ -> Invalid -- something bad happened; just ignore and continue.
149 classifyTab = compile (caps_classify_table : ansi_classify_table)
151 caps_tabls = [("khome", (KHome, [])),
152 ("kend", (KEnd, [])),
153 ("cbt", (KBackTab, [])),
154 ("kcud1", (KDown, [])),
155 ("kcuu1", (KUp, [])),
156 ("kcuf1", (KRight, [])),
157 ("kcub1", (KLeft, [])),
159 ("kLFT", (KLeft, [MShift])),
160 ("kRIT", (KRight, [MShift]))
161 ]
163 caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls]
165 ansi_classify_table :: [[([Char], (Key, [Modifier]))]]
166 ansi_classify_table =
167 [ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5
168 , k "P" KPause
169 , k "A" KUp
170 , k "B" KDown
171 , k "C" KRight
172 , k "D" KLeft
173 , k "H" KHome
174 , k "F" KEnd
175 , k "E" KBegin
176 ],
178 -- Support for arrows and KHome/KEnd
179 [("\ESC[" ++ charCnt ++ show mc++c,(s,m))
180 | charCnt <- ["1;", ""], -- we can have a count or not
181 (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),
182 ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes
183 (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes
184 ],
186 let k n s = ("\ESC["++show n++"~",(s,[]))
187 in zipWith k [2::Int,3,5,6,1,4]
188 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd],
190 let k n s = ("\ESC["++show n++";5~",(s,[MCtrl]))
191 in zipWith k [2::Int,3,5,6,1,4]
192 [KIns,KDel,KPageUp,KPageDown,KHome,KEnd],
194 -- Support for simple characters.
195 [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],
197 -- Support for function keys (should use terminfo)
198 [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ],
199 let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in
200 concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ],
201 [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ],
203 -- Ctrl+Char
204 [ ([toEnum x],(KASCII y,[MCtrl]))
205 | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),
206 y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
207 ],
209 -- Ctrl+Meta+Char
210 [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],
212 -- Special support
213 [ -- special support for ESC
214 ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])),
216 -- Special support for backspace
217 ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),
219 -- Special support for Enter
220 ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ]
221 ]
223 eventThreadId <- forkIO $ inputToEventThread
224 inputThreadId <- forkIO $ inputThread
225 noInputThreadId <- forkIO $ noInputThread
226 let pokeIO = (Catch $ do let e = error "(getsize in input layer)"
227 setTerminalAttributes stdInput nattr Immediately
228 writeChan eventChannel (EvResize e e))
229 _ <- installHandler windowChange pokeIO Nothing
230 _ <- installHandler continueProcess pokeIO Nothing
231 -- TODO(corey): killThread is a bit risky for my tastes.
232 let uninit = do killThread eventThreadId
233 killThread inputThreadId
234 killThread noInputThreadId
235 _ <- installHandler windowChange Ignore Nothing
236 _ <- installHandler continueProcess Ignore Nothing
237 setTerminalAttributes stdInput oattr Immediately
238 return (readChan eventChannel, uninit)
240first :: (a -> b) -> (a,c) -> (b,c)
241first f (x,y) = (f x, y)
243utf8Length :: (Num t, Ord a, Num a) => a -> t
244utf8Length c
245 | c < 0x80 = 1
246 | c < 0xE0 = 2
247 | c < 0xF0 = 3
248 | otherwise = 4
250foreign import ccall "vty_set_term_timing" set_term_timing :: IO ()