diff --git a/Graphics/Vty.hs b/Graphics/Vty.hs --- a/Graphics/Vty.hs +++ b/Graphics/Vty.hs @@ -41,8 +41,10 @@ ulift :: (TermState -> IO (a, TermState)) -> IO a ulift f = modifyMVar rstate (\(v,a,b,c) -> fmap (\(x,y) -> ((y,a,b,c),x)) (f v)) - rec = Vty { update = update' , getEvent = gkey , getSize = ulift getwinsize , - shutdown = fend } + rec = Vty { update = update' + , getEvent = gkey + , getSize = ulift getwinsize + , shutdown = fend } update' (Pic nc (T.Image wr w h)) = modifyMVar_ rstate $ \(ts0, fbw, fbh, oldptr) -> do (shd,ts1) <- case (fbw,fbh) == (w,h) of diff --git a/Graphics/Vty/Cursor.hs b/Graphics/Vty/Cursor.hs --- a/Graphics/Vty/Cursor.hs +++ b/Graphics/Vty/Cursor.hs @@ -130,6 +130,12 @@ reset = "\ESCc\ESC%G\ESC[1;1H\ESC[2J" -- | Make the terminal beep. beep :: IO () -beep = putStr "\BEL" ; cvis = "\ESC[?25h" ; civis = "\ESC[?25l" +beep = putStr "\BEL" +-- | Show the cursor +cvis = "\ESC[?25h" +civis = "\ESC[?25l" endterm :: Int -> [Char] -endterm sy = "\ESC[" ++ show sy ++ ";1H\ESC[0;39;49m\ESC%@\CR\ESC[?25h\ESC[K" +endterm sy = "\ESC[" ++ show sy ++ ";1H\ESC[0;39;49m" ++ + "\ESC%@\CR" ++ -- select default charset (\ESC%G would select UTF8) + cvis ++ + "\ESC[K" diff --git a/Graphics/Vty/LLInput.hs b/Graphics/Vty/LLInput.hs --- a/Graphics/Vty/LLInput.hs +++ b/Graphics/Vty/LLInput.hs @@ -2,20 +2,25 @@ module Graphics.Vty.LLInput ( Key(..), Modifier(..), Button(..), Event(..), initTermInput ) where +import Data.Char import Data.Maybe( mapMaybe ) import Data.List( inits ) +import Data.Word import qualified Data.Map as M( fromList, lookup ) import qualified Data.Set as S( fromList, member ) +import Codec.Binary.UTF8.Generic (decode) + import Control.Concurrent import System.Posix.Signals.Exts import System.Posix.Signals import System.Posix.Terminal +import System.Console.Terminfo import System.Posix.IO (stdInput, fdRead, setFdOption, FdOption(..)) -- |Representations of non-modifier keys. -data Key = KEsc | KFun Int | KPrtScr | KPause | KASCII Char | KBS | KIns +data Key = KEsc | KFun Int | KBackTab | KPrtScr | KPause | KASCII Char | KBS | KIns | KHome | KPageUp | KDel | KEnd | KPageDown | KNP5 | KUp | KMenu | KLeft | KDown | KRight | KEnter deriving (Eq,Show,Ord) -- |Modifier keys. Key codes are interpreted such that users are more likely to @@ -46,6 +51,115 @@ let nattr = foldl withoutMode oattr [StartStopOutput, KeyboardInterrupts, EnableEcho, ProcessInput] setTerminalAttributes stdInput nattr Immediately + terminal <- setupTermFromEnv + + let iothread :: MVar Event -> IO () + iothread chn = threadName "kbd" >> loop [] where + loop kb = case (classify kb) of + Prefix -> do ch <- getInput + loop (kb ++ [ch]) + Invalid -> loop "" + MisPfx k m s -> putMVar chn (EvKey k m) >> loop s + Valid k m -> putMVar chn (EvKey k m) >> loop "" + getInput = do + catch + (do + setFdOption stdInput NonBlockingRead True + (bytes, bytes_read) <- fdRead stdInput 1 + if (bytes_read > 0) + then return (head bytes) + else do + threadDelay 50000 + return '\xFFFE' + ) + (\_ -> do + threadDelay 50000 + return '\xFFFE') + + compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass + compile lst = cl' where + lst' = concat lst + pfx = S.fromList $ concatMap (init . inits . fst) $ lst' + mlst = M.fromList lst' + cl' str = case S.member str pfx of + True -> Prefix + False -> case M.lookup str mlst of + Just (k,m) -> Valid k m + Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of + (s,(k,m)) -> MisPfx k m (drop (length s) str) + + -- ANSI specific bits + + + classify, classifyTab :: [Char] -> KClass + + classify "\xFFFD" = Invalid + classify "\xFFFE" = Invalid + classify s@(c:_) | ord c >= 0xC2 = + if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence + classify other = classifyTab other + + classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of + Just (unicodeChar, _) -> Valid (KASCII unicodeChar) [] + _ -> Invalid -- something bad happened; just ignore and continue. + + classifyTab = compile (caps_classify_table : ansi_classify_table) + + caps_tabls = [("khome", (KHome, [])), + ("kend", (KEnd, [])), + ("cbt", (KBackTab, [])), + ("kcud1", (KDown, [])), + ("kcuu1", (KUp, [])), + ("kcuf1", (KRight, [])), + ("kcub1", (KLeft, [])), + + ("kLFT", (KLeft, [MShift])), + ("kRIT", (KRight, [MShift])) + ] + + caps_classify_table = [(x,y) | (Just x,y) <- map (first (getCapability terminal . tiGetStr)) $ caps_tabls] + + ansi_classify_table :: [[([Char], (Key, [Modifier]))]] + ansi_classify_table = + [ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5, k "P" KPause, k "A" KUp, k "B" KDown, k "C" KRight, k "D" KLeft ], + + -- Support for arrows + let k c s = [("\ESC[1;"++show mc++c,(s,m)) | (m,mc) <- + [([MShift],2::Int), ([MCtrl],5), ([MMeta],3), + ([MShift, MCtrl],6), ([MShift, MMeta],4)]] + in concat [ k "A" KUp, k "B" KDown, k "C" KRight, k "D" KLeft ], + + let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [2::Int,3,5,6] [KIns,KDel,KPageUp,KPageDown], + + -- Support for simple characters. + [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ], + + -- Support for function keys (should use terminfo) + [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ], + let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in + concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ], + [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ], + + -- Ctrl+Char + [ ([toEnum x],(KASCII y,[MCtrl])) + | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']), + y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB. + ], + + -- Ctrl+Meta+Char + [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ], + + -- Special support + [ -- special support for ESC + ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])), + + -- Special support for backspace + ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])), + + -- Special support for Enter + ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] + ] + iothr <- forkIO $ iothread kchan let pokeIO = (Catch $ do threadName "winch|cont" let e = error "(getsize in input layer)" @@ -59,60 +173,13 @@ setTerminalAttributes stdInput oattr Immediately return (takeMVar kchan, uninit) -iothread :: MVar Event -> IO () -iothread chn = threadName "kbd" >> loop [] where - loop kb = case (classify kb) of - Prefix -> do ch <- getInput - loop (kb ++ [ch]) - Invalid -> loop "" - MisPfx k m s -> putMVar chn (EvKey k m) >> loop s - Valid k m -> putMVar chn (EvKey k m) >> loop "" - getInput = do - catch - (do - setFdOption stdInput NonBlockingRead True - (bytes, bytes_read) <- fdRead stdInput 1 - if (bytes_read > 0) - then do - let out_byte = head bytes - return (head bytes) - else do - threadDelay 50000 - return '\xFFFE' - ) - (\_ -> do - threadDelay 50000 - return '\xFFFE') - -compile :: [[([Char],(Key,[Modifier]))]] -> [Char] -> KClass -compile lst = cl' where - lst' = concat lst - pfx = S.fromList $ concatMap (init . inits . fst) $ lst' - mlst = M.fromList lst' - cl' "\xFFFD" = Invalid ; cl' "\xFFFE" = Invalid - cl' str = case S.member str pfx of - True -> Prefix - False -> case M.lookup str mlst of - Just (k,m) -> Valid k m - Nothing -> case head $ mapMaybe (\s -> (,) s `fmap` M.lookup s mlst) $ init $ inits str of - (s,(k,m)) -> MisPfx k m (drop (length s) str) - --- ANSI specific bits - -classify :: [Char] -> KClass -classify = compile ansi_classify_table +first :: (a -> b) -> (a,c) -> (b,c) +first f (x,y) = (f x, y) -ansi_classify_table = - [ let k c s = ("\ESC["++c,(s,[])) in - [ k "A" KUp, k "B" KDown, k "C" KRight, k "D" KLeft, k "G" KNP5, k "P" KPause ], - let k n s = ("\ESC["++show n++"~",(s,[])) in zipWith k [1::Int ..6] [KHome,KIns,KDel,KEnd,KPageUp,KPageDown], - [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ], - [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ], - let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in - concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ], - [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ], - [ ([toEnum x],(KASCII y,[MCtrl])) | (x,y) <- zip ([0..8] ++ [10..31]) ('@':['a'..'h'] ++ ['j'..'z']++['['..'_']) ], - [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ], - [ ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])) , ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])), - ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ] ] +utf8Length :: (Num t, Ord a, Num a) => a -> t +utf8Length c + | c < 0x80 = 1 + | c < 0xE0 = 2 + | c < 0xF0 = 3 + | otherwise = 4 diff --git a/vty.cabal b/vty.cabal --- a/vty.cabal +++ b/vty.cabal @@ -1,9 +1,10 @@ Name: vty -Version: 3.0.2 +Version: 3.0.4 License: BSD3 License-file: LICENSE Author: Stefan O'Rear Maintainer: Corey O'Connor (coreyoconnor@gmail.com) +Homepage: http://trac.haskell.org/vty/ Category: User Interfaces Synopsis: A simple terminal access library Description: @@ -17,9 +18,12 @@ requires Linux\/xterm style UTF8 support. . You can 'darcs get' it from + ' © 2006-2007 Stefan O'Rear; BSD3 license. Build-Depends: base>3, bytestring, containers, unix +Build-Depends: terminfo >= 0.2 && < 0.3 +Build-Depends: utf8-string >= 0.3 && < 0.4 Build-Type: Simple Data-Files: README, TODO Extra-Source-Files: test/Test.hs, cbits/gwinsz.h, test/Bench.hs