git.iko.soy/vty
on cae018f help sign in
vty/src/Graphics/Vty/LLInput.hs
197 lines 8.0 kB history raw
1-- Copyright 2009 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.Signals
30import System.Posix.Terminal
31import System.Posix.IO ( stdInput
32 ,fdRead
33 ,setFdOption
34 ,FdOption(..)
35 )
37-- |Representations of non-modifier keys.
38data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns
39 | KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu
40 | KLeft | KDown | KRight | KEnter
41 deriving (Eq,Show,Ord)
43-- |Modifier keys. Key codes are interpreted such that users are more likely to
44-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will
45-- generally correspond to the physical Alt key.
46data Modifier = MShift | MCtrl | MMeta | MAlt
47 deriving (Eq,Show,Ord)
49-- |Mouse buttons. Not yet used.
50data Button = BLeft | BMiddle | BRight
51 deriving (Eq,Show,Ord)
53-- |Generic events.
54data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier]
55 | EvResize Int Int
56 deriving (Eq,Show,Ord)
58data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char]
59 deriving(Show)
61-- | Set up the terminal for input. Returns a function which reads key
62-- events, and a function for shutting down the terminal access.
63initTermInput :: Int -> Terminal -> IO (IO Event, IO ())
64initTermInput escDelay terminal = do
65 eventChannel <- newChan
66 inputChannel <- newChan
67 hadInput <- newEmptyMVar
68 oattr <- getTerminalAttributes stdInput
69 let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts,
70 EnableEcho, ProcessInput]
71 setTerminalAttributes stdInput nattr Immediately
72 set_term_timing
73 let inputToEventThread :: IO ()
74 inputToEventThread = loop []
75 where loop kb = case (classify kb) of
76 Prefix -> do c <- readChan inputChannel
77 loop (kb ++ [c])
78 Invalid -> loop ""
79 MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s
80 Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""
82 finishAtomicInput = writeChan inputChannel '\xFFFE'
84 inputThread :: IO ()
85 inputThread = loop
86 where
87 loop = do
88 setFdOption stdInput NonBlockingRead False
89 threadWaitRead stdInput
90 setFdOption stdInput NonBlockingRead True
91 try readAll
92 when (escDelay == 0) finishAtomicInput
93 loop
94 readAll = do
95 (bytes, bytes_read) <- fdRead stdInput 1
96 when (bytes_read > 0) $ do
97 tryPutMVar hadInput () -- signal input
98 writeChan inputChannel (head bytes)
99 readAll
100 -- | If there is no input for some time, this thread puts '\xFFFE' in the
101 -- inputChannel.
102 noInputThread :: IO ()
103 noInputThread = when (escDelay > 0) loop
104 where loop = do
105 takeMVar hadInput -- wait for some input
106 threadDelay escDelay -- microseconds
107 hadNoInput <- isEmptyMVar hadInput -- no input yet?
108 when hadNoInput $ do
109 finishAtomicInput
110 loop
113 compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass
114 compile lst = cl' where
115 lst' = concat lst
116 pfx = S.fromList $ concatMap (init . inits . fst) $ lst'
117 mlst = M.fromList lst'
118 cl' str = case S.member str pfx of
119 True -> Prefix
120 False -> case M.lookup str mlst of
121 Just (k,m) -> Valid k m
122 Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of
123 (s,(k,m)) -> MisPfx k m (drop (length s) str)
125 -- ANSI specific bits
128 classify, classifyTab :: [Char] -> KClass
130 -- As soon as
131 classify "\xFFFE" = Invalid
132 classify s@(c:_) | ord c >= 0xC2 =
133 if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
134 classify other = classifyTab other
136 classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
137 Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []
138 _ -> Invalid -- something bad happened; just ignore and continue.
140 classifyTab = compile (caps_classify_table : ansi_classify_table)
142 caps_tabls = [("khome", (KHome, [])),
143 ("kend", (KEnd, [])),
145 ("kcud1", (KDown, [])),
146 ("kcuu1", (KUp, [])),
147 ("kcuf1", (KRight, [])),
148 ("kcub1", (KLeft, []))
149 ]
151 caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls]
153 ansi_classify_table :: [[([Char], (Key, [Modifier]))]]
154 ansi_classify_table =
155 [ let k c s = ("\ESC["++c,(s,[])) in
156 [ k "G" KNP5, k "P" KPause ],
157 let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [2::Int,3,5,6] [KIns,KDel,KPageUp,KPageDown],
158 [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],
159 [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ],
160 let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in
161 concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ],
162 [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ],
163 [ ([toEnum x],(KASCII y,[MCtrl]))
164 | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),
165 y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.
166 ],
167 [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],
168 [ ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])) , ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),
169 ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] ]
171 eventThreadId <- forkIO $ inputToEventThread
172 inputThreadId <- forkIO $ inputThread
173 noInputThreadId <- forkIO $ noInputThread
174 let pokeIO = (Catch $ do let e = error "(getsize in input layer)"
175 setTerminalAttributes stdInput nattr Immediately
176 writeChan eventChannel (EvResize e e))
177 installHandler windowChange pokeIO Nothing
178 installHandler continueProcess pokeIO Nothing
179 let uninit = do killThread eventThreadId
180 killThread inputThreadId
181 killThread noInputThreadId
182 installHandler windowChange Ignore Nothing
183 installHandler continueProcess Ignore Nothing
184 setTerminalAttributes stdInput oattr Immediately
185 return (readChan eventChannel, uninit)
187first f (x,y) = (f x, y)
190utf8Length c
191 | c < 0x80 = 1
192 | c < 0xE0 = 2
193 | c < 0xF0 = 3
194 | otherwise = 4
196foreign import ccall "set_term_timing" set_term_timing :: IO ()