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