@@ -1,7 +1,4 @@
1−{-# LANGUAGE ScopedTypeVariables #-}
21-- Copyright 2009-2010 Corey O'Connor
3−{-# OPTIONS_GHC -Wall #-}
4−{-# LANGUAGE ForeignFunctionInterface #-}
52module Graphics.Vty.Input ( Key(..)
63 , Modifier(..)
74 , Button(..)
@@ -42,52 +39,40 @@ import Foreign ( alloca, poke, peek, Ptr )
4239-- events, and a function for shutting down the terminal access.
4340initTermInput :: Int -> Terminal -> IO (IO Event, IO ())
4441initTermInput escDelay terminal = do
45− eventChannel <- newChan
46− inputChannel <- newChan
47− hadInput <- newEmptyMVar
48− oattr <- getTerminalAttributes stdInput
49− let nattr = foldl withoutMode oattr [ StartStopOutput, KeyboardInterrupts
42+ eventChannel <- newChan
43+ inputChannel <- newChan
44+ hadInput <- newEmptyMVar
45+ oattr <- getTerminalAttributes stdInput
46+ let nattr = foldl withoutMode oattr [ StartStopOutput, KeyboardInterrupts
5047 , EnableEcho, ProcessInput, ExtendedFunctions
5148 ]
52− setTerminalAttributes stdInput nattr Immediately
53− set_term_timing
54− let inputToEventThread :: IO ()
55− inputToEventThread = loop []
56− where loop kb = case (classify kb) of
57− Prefix -> do c <- readChan inputChannel
58− loop (kb ++ [c])
59− Invalid -> do c <- readChan inputChannel
60− loop [c]
61− MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s
62− Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""
63−
64− finishAtomicInput = writeChan inputChannel '\xFFFE'
65−
66− inputThread :: IO ()
67− inputThread = do
68− _ <- alloca $ \(input_buffer :: Ptr Word8) -> do
69− let loop = do
70− setFdOption stdInput NonBlockingRead False
71− threadWaitRead stdInput
72− setFdOption stdInput NonBlockingRead True
73− _ <- try readAll :: IO (Either IOException ())
74− when (escDelay == 0) finishAtomicInput
75− loop
76− readAll = do
77− poke input_buffer 0
78− bytes_read <- fdReadBuf stdInput input_buffer 1
79− input_char <- fmap (chr . fromIntegral) $ peek input_buffer
80− when (bytes_read > 0) $ do
81− _ <- tryPutMVar hadInput () -- signal input
82− writeChan inputChannel input_char
83− readAll
84− loop
85− return ()
86−
87− -- | If there is no input for some time, this thread puts '\xFFFE' in the
88− -- inputChannel.
89− noInputThread :: IO ()
90− noInputThread = when (escDelay > 0) loop
49+ setTerminalAttributes stdInput nattr Immediately
50+ set_term_timing
51+ let finishAtomicInput = writeChan inputChannel '\xFFFE'
52+ inputThread :: IO ()
53+ inputThread = do
54+ _ <- alloca $ \(input_buffer :: Ptr Word8) -> do
55+ let loop = do
56+ setFdOption stdInput NonBlockingRead False
57+ threadWaitRead stdInput
58+ setFdOption stdInput NonBlockingRead True
59+ _ <- try readAll :: IO (Either IOException ())
60+ when (escDelay == 0) finishAtomicInput
61+ loop
62+ readAll = do
63+ poke input_buffer 0
64+ bytes_read <- fdReadBuf stdInput input_buffer 1
65+ input_char <- fmap (chr . fromIntegral) $ peek input_buffer
66+ when (bytes_read > 0) $ do
67+ _ <- tryPutMVar hadInput () -- signal input
68+ writeChan inputChannel input_char
69+ readAll
70+ loop
71+ return ()
72+ -- | If there is no input for some time, this thread puts '\xFFFE' in the
73+ -- inputChannel.
74+ noInputThread :: IO ()
75+ noInputThread = when (escDelay > 0) loop
9176 where loop = do
9277 takeMVar hadInput -- wait for some input
9378 threadDelay escDelay -- microseconds
@@ -97,55 +82,65 @@ initTermInput escDelay terminal = do
9782 finishAtomicInput
9883 loop
9984
100−
101− compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass
102− compile lst = cl' where
103− lst' = concat lst
104− pfx = S.fromList $ concatMap (init . inits . fst) $ lst'
105− mlst = M.fromList lst'
106− cl' str = case S.member str pfx of
107− True -> Prefix
108− False -> case M.lookup str mlst of
109− Just (k,m) -> Valid k m
110− Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of
111− (s,(k,m)) -> MisPfx k m (drop (length s) str)
112−
113− -- ANSI specific bits
114−
115−
116− classify, classifyTab :: [Char] -> KClass
117−
118− -- As soon as
119− classify "\xFFFE" = Invalid
120− classify s@(c:_) | ord c >= 0xC2 =
121− if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
122− classify other = classifyTab other
123−
124− classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
125− Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []
126− _ -> Invalid -- something bad happened; just ignore and continue.
127−
128− classifyTab = compile (caps_classify_table : ansi_classify_table)
129−
130− caps_classify_table
131− = map_to_legacy_table [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_table]
132−
133− eventThreadId <- forkIO $ inputToEventThread
134− inputThreadId <- forkIO $ inputThread
135− noInputThreadId <- forkIO $ noInputThread
136− let pokeIO = (Catch $ do let e = error "(getsize in input layer)"
137− setTerminalAttributes stdInput nattr Immediately
138− writeChan eventChannel (EvResize e e))
139− _ <- installHandler windowChange pokeIO Nothing
140− _ <- installHandler continueProcess pokeIO Nothing
141− -- TODO(corey): killThread is a bit risky for my tastes.
142− let uninit = do killThread eventThreadId
143− killThread inputThreadId
144− killThread noInputThreadId
145− _ <- installHandler windowChange Ignore Nothing
146− _ <- installHandler continueProcess Ignore Nothing
147− setTerminalAttributes stdInput oattr Immediately
148− return (readChan eventChannel, uninit)
85+ extract_cap = first (getCapability terminal . tiGetStr)
86+ caps_classify_table = map_to_legacy_table [(x,y) | (Just x,y) <- map extract_cap caps_table]
87+ term_event_classify_table = concat $ caps_classify_table : ansi_classify_table
88+ term_event_classifier = classify term_event_classify_table
89+
90+ eventThreadId <- forkIO $ inputToEventThread term_event_classifier inputChannel eventChannel
91+ inputThreadId <- forkIO $ inputThread
92+ noInputThreadId <- forkIO $ noInputThread
93+ let pokeIO = Catch $ do
94+ let e = error "(getsize in input layer)"
95+ setTerminalAttributes stdInput nattr Immediately
96+ writeChan eventChannel (EvResize e e)
97+ _ <- installHandler windowChange pokeIO Nothing
98+ _ <- installHandler continueProcess pokeIO Nothing
99+ -- TODO(corey): killThread is a bit risky for my tastes.
100+ let uninit = do
101+ killThread eventThreadId
102+ killThread inputThreadId
103+ killThread noInputThreadId
104+ _ <- installHandler windowChange Ignore Nothing
105+ _ <- installHandler continueProcess Ignore Nothing
106+ setTerminalAttributes stdInput oattr Immediately
107+ return (readChan eventChannel, uninit)
108+
109+inputToEventThread :: (String -> KClass) -> Chan Char -> Chan Event -> IO ()
110+inputToEventThread classifier inputChannel eventChannel = loop []
111+ where loop kb = case (classifier kb) of
112+ Prefix -> do c <- readChan inputChannel
113+ loop (kb ++ [c])
114+ Invalid -> do c <- readChan inputChannel
115+ loop [c]
116+ MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s
117+ Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""
118+
119+compile :: ClassifyTable -> [Char] -> KClass
120+compile table = cl' where
121+ pfx = S.fromList $ concatMap (init . inits . fst) $ table
122+ mlst = M.fromList table
123+ cl' str = case S.member str pfx of
124+ True -> Prefix
125+ False -> case M.lookup str mlst of
126+ Just (k,m) -> Valid k m
127+ Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of
128+ (s,(k,m)) -> MisPfx k m (drop (length s) str)
129+
130+classify, classifyTab :: ClassifyTable -> [Char] -> KClass
131+
132+-- As soon as
133+classify _table "\xFFFE" = Invalid
134+classify _table s@(c:_) | ord c >= 0xC2
135+ = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence
136+classify table other
137+ = classifyTab table other
138+
139+classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of
140+ Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []
141+ _ -> Invalid -- something bad happened; just ignore and continue.
142+
143+classifyTab table = compile table
149144
150145first :: (a -> b) -> (a,c) -> (b,c)
151146first f (x,y) = (f x, y)