ce5b5f4 · vty · git.iko.soy

.travis.ymlnew file+3

compare with master

unifiedsplit

@@ -0,0 +1,3 @@

1+language: haskell

2+notifications:

3+ email: false

src/Data/Terminfo/Eval.hs−1

@@ -1,6 +1,5 @@

1{-# LANGUAGE MagicHash #-}

2{-# LANGUAGE BangPatterns #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

5{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE FlexibleContexts #-}

6{-# LANGUAGE NoMonomorphismRestriction #-}

5{-# LANGUAGE NoMonomorphismRestriction #-}

src/Data/Terminfo/Parse.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE BangPatterns #-}

1{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE FlexibleContexts #-}

2{-# LANGUAGE FlexibleContexts #-}

4{-# LANGUAGE NoMonomorphismRestriction #-}

3{-# LANGUAGE NoMonomorphismRestriction #-}

src/Graphics/Vty.hs+1−1

@@ -73,7 +73,7 @@ data Vty = Vty

73-- | Set up the state object for using vty. At most one state object should be

74-- created at a time.

75mkVty :: IO Vty

76−mkVty = mkVtyEscDelay 0

76+mkVty = mkVtyEscDelay defaultEscDelay

77

78-- | Set up the state object for using vty. At most one state object should be

79-- created at a time. The delay, in microseconds, specifies the period of time to wait for a key

src/Graphics/Vty/Debug.hs−1

@@ -1,5 +1,4 @@

2−{-# LANGUAGE ScopedTypeVariables #-}

3module Graphics.Vty.Debug ( module Graphics.Vty.Debug

2module Graphics.Vty.Debug ( module Graphics.Vty.Debug

4 , module Graphics.Vty.Debug.Image

3 , module Graphics.Vty.Debug.Image

5 )

4 )

src/Graphics/Vty/Debug/Image.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module Graphics.Vty.Debug.Image where

1module Graphics.Vty.Debug.Image where

3

2

4import Graphics.Vty.Image

3import Graphics.Vty.Image

src/Graphics/Vty/Input.hs+64−118

@@ -1,28 +1,21 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

3−{-# OPTIONS_GHC -Wall #-}

4−{-# LANGUAGE ForeignFunctionInterface #-}

5module Graphics.Vty.Input ( Key(..)

2module Graphics.Vty.Input ( Key(..)

6 , Modifier(..)

3 , Modifier(..)

7 , Button(..)

4 , Button(..)

8 , Event(..)

5 , Event(..)

9 , initTermInput

6 , initTermInput

7+ , defaultEscDelay

10 )

8 )

11 where

9 where

12

10

13import Graphics.Vty.Input.Data

11import Graphics.Vty.Input.Data

12+import Graphics.Vty.Input.Internal

13+import Graphics.Vty.Input.Terminfo

14

15import Data.Char

16−import Data.Maybe ( mapMaybe

17− )

18−import Data.List( inits )

19import Data.Word

16import Data.Word

20−import qualified Data.Map as M( fromList, lookup )

21−import qualified Data.Set as S( fromList, member )

22

17

23−import Codec.Binary.UTF8.Generic (decode)

24−

25−import Control.Monad (when)

18+import Control.Monad (when, void)

26import Control.Concurrent

19import Control.Concurrent

27import Control.Exception

20import Control.Exception

28

21

@@ -31,63 +24,54 @@ import System.Console.Terminfo

31import System.Posix.Signals.Exts

24import System.Posix.Signals.Exts

32import System.Posix.Terminal

25import System.Posix.Terminal

33import System.Posix.IO ( stdInput

26import System.Posix.IO ( stdInput

34− ,fdReadBuf

27+ , fdReadBuf

35− ,setFdOption

28+ , setFdOption

36− ,FdOption(..)

29+ , FdOption(..)

37 )

30 )

38

31

39import Foreign ( alloca, poke, peek, Ptr )

32import Foreign ( alloca, poke, peek, Ptr )

40

33

34+defaultEscDelay :: Int

35+defaultEscDelay = 0

36+

41-- | Set up the terminal for input. Returns a function which reads key

37-- | Set up the terminal for input. Returns a function which reads key

42-- events, and a function for shutting down the terminal access.

38-- events, and a function for shutting down the terminal access.

43initTermInput :: Int -> Terminal -> IO (IO Event, IO ())

39initTermInput :: Int -> Terminal -> IO (IO Event, IO ())

44initTermInput escDelay terminal = do

40initTermInput escDelay terminal = do

45− eventChannel <- newChan

41+ eventChannel <- newChan

46− inputChannel <- newChan

42+ inputChannel <- newChan

47− hadInput <- newEmptyMVar

43+ hadInput <- newEmptyMVar

48− oattr <- getTerminalAttributes stdInput

44+ oattr <- getTerminalAttributes stdInput

49− let nattr = foldl withoutMode oattr [ StartStopOutput, KeyboardInterrupts

45+ let nattr = foldl withoutMode oattr [ StartStopOutput, KeyboardInterrupts

50 , EnableEcho, ProcessInput, ExtendedFunctions

46 , EnableEcho, ProcessInput, ExtendedFunctions

51 ]

47 ]

52− setTerminalAttributes stdInput nattr Immediately

48+ setTerminalAttributes stdInput nattr Immediately

53− set_term_timing

49+ 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'

50+ let finishAtomicInput = writeChan inputChannel '\xFFFE'

65−

66− inputThread :: IO ()

51+ inputThread :: IO ()

67− inputThread = do

52+ inputThread = do

68− _ <- alloca $ \(input_buffer :: Ptr Word8) -> do

53+ _ <- alloca $ \(input_buffer :: Ptr Word8) -> do

69− let loop = do

54+ let loop = do

70− setFdOption stdInput NonBlockingRead False

55+ setFdOption stdInput NonBlockingRead False

71− threadWaitRead stdInput

56+ threadWaitRead stdInput

72− setFdOption stdInput NonBlockingRead True

57+ setFdOption stdInput NonBlockingRead True

73− _ <- try readAll :: IO (Either IOException ())

58+ _ <- try readAll :: IO (Either IOException ())

74− when (escDelay == 0) finishAtomicInput

59+ when (escDelay == 0) finishAtomicInput

75− loop

60+ loop

76− readAll = do

61+ readAll = do

77− poke input_buffer 0

62+ poke input_buffer 0

78− bytes_read <- fdReadBuf stdInput input_buffer 1

63+ bytes_read <- fdReadBuf stdInput input_buffer 1

79− input_char <- fmap (chr . fromIntegral) $ peek input_buffer

64+ input_char <- fmap (chr . fromIntegral) $ peek input_buffer

80− when (bytes_read > 0) $ do

65+ when (bytes_read > 0) $ do

81− _ <- tryPutMVar hadInput () -- signal input

66+ _ <- tryPutMVar hadInput () -- signal input

82− writeChan inputChannel input_char

67+ writeChan inputChannel input_char

83− readAll

68+ readAll

84− loop

69+ loop

85− return ()

70+ return ()

86−

87− -- | If there is no input for some time, this thread puts '\xFFFE' in the

71+ -- | If there is no input for some time, this thread puts '\xFFFE' in the

88− -- inputChannel.

72+ -- inputChannel.

89− noInputThread :: IO ()

73+ noInputThread :: IO ()

90− noInputThread = when (escDelay > 0) loop

74+ noInputThread = when (escDelay > 0) loop

91 where loop = do

75 where loop = do

92 takeMVar hadInput -- wait for some input

76 takeMVar hadInput -- wait for some input

93 threadDelay escDelay -- microseconds

77 threadDelay escDelay -- microseconds

@@ -97,64 +81,26 @@ initTermInput escDelay terminal = do

97 finishAtomicInput

81 finishAtomicInput

98 loop

82 loop

99

83

84+ caps_legacy_table = map_to_legacy_table $ caps_classify_table terminal keys_from_caps_table

85+ term_event_classify_table = concat $ caps_legacy_table : ansi_classify_table

86+ term_event_classifier = classify term_event_classify_table

87+

88+ eventThreadId <- forkIO $ void $ inputToEventThread term_event_classifier inputChannel eventChannel

89+ inputThreadId <- forkIO $ inputThread

90+ noInputThreadId <- forkIO $ noInputThread

91+ let pokeIO = Catch $ do

92+ let e = error "(getsize in input layer)"

93+ setTerminalAttributes stdInput nattr Immediately

94+ writeChan eventChannel (EvResize e e)

95+ _ <- installHandler windowChange pokeIO Nothing

96+ _ <- installHandler continueProcess pokeIO Nothing

97+ -- TODO(corey): killThread is a bit risky for my tastes.

98+ let uninit = do

99+ killThread eventThreadId

100+ killThread inputThreadId

101+ killThread noInputThreadId

102+ _ <- installHandler windowChange Ignore Nothing

103+ _ <- installHandler continueProcess Ignore Nothing

104+ setTerminalAttributes stdInput oattr Immediately

105+ return (readChan eventChannel, uninit)

100

106

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)

149−

150−first :: (a -> b) -> (a,c) -> (b,c)

151−first f (x,y) = (f x, y)

152−

153−utf8Length :: (Num t, Ord a, Num a) => a -> t

154−utf8Length c

155− | c < 0x80 = 1

156− | c < 0xE0 = 2

157− | c < 0xF0 = 3

158− | otherwise = 4

159−

160−foreign import ccall "vty_set_term_timing" set_term_timing :: IO ()

src/Graphics/Vty/Input/Data.hs+98−58

@@ -1,15 +1,13 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2−{-# LANGUAGE ForeignFunctionInterface #-}

3-- Copyright Corey O'Connor

1-- Copyright Corey O'Connor

4module Graphics.Vty.Input.Data where

2module Graphics.Vty.Input.Data where

5

3

6−-- |Representations of non-modifier keys.

4+-- | Representations of non-modifier keys.

9 | KLeft | KDown | KRight | KEnter

7 | KLeft | KDown | KRight | KEnter

10 deriving (Eq,Show,Ord)

8 deriving (Eq,Show,Ord)

11

9

12−-- |Modifier keys. Key codes are interpreted such that users are more likely to

10+-- | Modifier keys. Key codes are interpreted such that users are more likely to

13-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will

11-- have Meta than Alt; for instance on the PC Linux console, 'MMeta' will

14-- generally correspond to the physical Alt key.

12-- generally correspond to the physical Alt key.

15data Modifier = MShift | MCtrl | MMeta | MAlt

13data Modifier = MShift | MCtrl | MMeta | MAlt

@@ -24,17 +22,24 @@ data Event = EvKey Key [Modifier] | EvMouse Int Int Button [Modifier]

24 | EvResize Int Int

22 | EvResize Int Int

25 deriving (Eq,Show,Ord)

23 deriving (Eq,Show,Ord)

26

24

25+data KClass

26+ = Valid Key [Modifier]

27+ | Invalid

28+ | EndLoop

29+ | Prefix

27−data KClass = Valid Key [Modifier] | Invalid | Prefix | MisPfx Key [Modifier] [Char]

30+ | MisPfx Key [Modifier] [Char]

28 deriving(Show)

31 deriving(Show)

29

32

33+type ClassifyTable = [(String, (Key, [Modifier]))]

34+

30−map_to_legacy_table :: [(String, Event)] -> [(String, (Key, [Modifier]))]

35+map_to_legacy_table :: [(String, Event)] -> ClassifyTable

31map_to_legacy_table = map f

36map_to_legacy_table = map f

32 where f (s, EvKey k mods) = (s, (k, mods))

37 where f (s, EvKey k mods) = (s, (k, mods))

33 f _ = error "no mapping for mouse or resize events"

38 f _ = error "no mapping for mouse or resize events"

34

39

35-- | classify table directly generated from terminfo cap strings

40-- | classify table directly generated from terminfo cap strings

36−caps_table :: [(String, Event)]

41+keys_from_caps_table :: [(String, Event)]

37−caps_table =

42+keys_from_caps_table =

38 [ ("khome", EvKey KHome [])

43 [ ("khome", EvKey KHome [])

39 , ("kend", EvKey KEnd [])

44 , ("kend", EvKey KEnd [])

40 , ("cbt", EvKey KBackTab [])

45 , ("cbt", EvKey KBackTab [])

@@ -46,62 +51,97 @@ caps_table =

46 , ("kRIT", EvKey KRight [MShift])

51 , ("kRIT", EvKey KRight [MShift])

47 ]

52 ]

48

53

54+nav_keys_0 :: ClassifyTable

55+nav_keys_0 =

56+ [ k "G" KNP5

57+ , k "P" KPause

58+ , k "A" KUp

59+ , k "B" KDown

60+ , k "C" KRight

61+ , k "D" KLeft

62+ , k "H" KHome

63+ , k "F" KEnd

64+ , k "E" KBegin

65+ ]

66+ where k c s = ("\ESC["++c,(s,[]))

49

67

50−-- | classify table for ANSI terminals

51−ansi_classify_table :: [[([Char], (Key, [Modifier]))]]

52−ansi_classify_table =

53− [ let k c s = ("\ESC["++c,(s,[])) in [ k "G" KNP5

54− , k "P" KPause

55− , k "A" KUp

56− , k "B" KDown

57− , k "C" KRight

58− , k "D" KLeft

59− , k "H" KHome

60− , k "F" KEnd

61− , k "E" KBegin

62− ],

63−

64− -- Support for arrows and KHome/KEnd

68+-- Support for arrows and KHome/KEnd

69+nav_keys_1 :: ClassifyTable

70+nav_keys_1 =

65 [("\ESC[" ++ charCnt ++ show mc++c,(s,m))

71 [("\ESC[" ++ charCnt ++ show mc++c,(s,m))

66 | charCnt <- ["1;", ""], -- we can have a count or not

72 | charCnt <- ["1;", ""], -- we can have a count or not

67 (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),

73 (m,mc) <- [([MShift],2::Int), ([MCtrl],5), ([MMeta],3),

68 ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes

74 ([MShift, MCtrl],6), ([MShift, MMeta],4)], -- modifiers and their codes

69 (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes

75 (c,s) <- [("A", KUp), ("B", KDown), ("C", KRight), ("D", KLeft), ("H", KHome), ("F", KEnd)] -- directions and their codes

70− ],

76+ ]

71−

77+

78+nav_keys_2 :: ClassifyTable

79+nav_keys_2 =

72− let k n s = ("\ESC["++show n++"~",(s,[]))

80+ let k n s = ("\ESC["++show n++"~",(s,[]))

73− in zipWith k [2::Int,3,5,6,1,4]

81+ in zipWith k [2::Int,3,5,6,1,4]

74− [KIns,KDel,KPageUp,KPageDown,KHome,KEnd],

82+ [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]

75−

83+

84+nav_keys_3 :: ClassifyTable

85+nav_keys_3 =

76− let k n s = ("\ESC["++show n++";5~",(s,[MCtrl]))

86+ let k n s = ("\ESC["++show n++";5~",(s,[MCtrl]))

77− in zipWith k [2::Int,3,5,6,1,4]

87+ in zipWith k [2::Int,3,5,6,1,4]

78− [KIns,KDel,KPageUp,KPageDown,KHome,KEnd],

88+ [KIns,KDel,KPageUp,KPageDown,KHome,KEnd]

79−

89+

80− -- Support for simple characters.

90+-- Support for simple characters.

91+-- we limit to < 0xC1. The UTF8 sequence detector will catch all values 0xC2 and above before this

92+-- classify table is reached.

93+simple_chars :: ClassifyTable

81− [ (x:[],(KASCII x,[])) | x <- map toEnum [0..255] ],

94+simple_chars = [ (x:[],(KASCII x,[])) | x <- map toEnum [0..0xC1] ]

82−

95+

83− -- Support for function keys (should use terminfo)

96+-- Support for function keys (should use terminfo)

97+function_keys_0 :: ClassifyTable

84− [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ],

98+function_keys_0 = [ ("\ESC[["++[toEnum(64+i)],(KFun i,[])) | i <- [1..5] ]

99+

100+function_keys_1 :: ClassifyTable

101+function_keys_1 =

85− let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in

102+ let f ff nrs m = [ ("\ESC["++show n++"~",(KFun (n-(nrs!!0)+ff), m)) | n <- nrs ] in

86− concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ],

103+ concat [ f 6 [17..21] [], f 11 [23,24] [], f 1 [25,26] [MShift], f 3 [28,29] [MShift], f 5 [31..34] [MShift] ]

104+

105+function_keys_2 :: ClassifyTable

87− [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ],

106+function_keys_2 = [ ('\ESC':[x],(KASCII x,[MMeta])) | x <- '\ESC':'\t':[' ' .. '\DEL'] ]

88−

107+

89− -- Ctrl+Char

108+-- Ctrl+Char

109+ctrl_char_keys :: ClassifyTable

110+ctrl_char_keys =

90− [ ([toEnum x],(KASCII y,[MCtrl]))

111+ [ ([toEnum x],(KASCII y,[MCtrl]))

91− | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),

112+ | (x,y) <- zip ([0..31]) ('@':['a'..'z']++['['..'_']),

92− y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.

113+ y /= 'i' -- Resolve issue #3 where CTRL-i hides TAB.

93− ],

114+ ]

94−

95− -- Ctrl+Meta+Char

96− [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ],

97

115

116+-- Ctrl+Meta+Char

117+ctrl_meta_keys :: ClassifyTable

118+ctrl_meta_keys =

119+ [ ('\ESC':[toEnum x],(KASCII y,[MMeta,MCtrl])) | (x,y) <- zip [0..31] ('@':['a'..'z']++['['..'_']) ]

120+

98− -- Special support

121+-- Special support

122+special_support_keys :: ClassifyTable

123+special_support_keys =

99− [ -- special support for ESC

124+ [ -- special support for ESC

100− ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta])),

125+ ("\ESC",(KEsc,[])) , ("\ESC\ESC",(KEsc,[MMeta]))

126+ -- Special support for backspace

127+ , ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta]))

128+ -- Special support for Enter

129+ , ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[]))

130+ ]

101

131

102− -- Special support for backspace

132+-- | classify table for ANSI terminals

103− ("\DEL",(KBS,[])), ("\ESC\DEL",(KBS,[MMeta])),

133+ansi_classify_table :: [ClassifyTable]

134+ansi_classify_table =

135+ [ nav_keys_0

136+ , nav_keys_1

137+ , nav_keys_2

138+ , nav_keys_3

139+ , simple_chars

140+ , function_keys_0

141+ , function_keys_1

142+ , function_keys_2

143+ , ctrl_char_keys

144+ , ctrl_meta_keys

145+ , special_support_keys

146+ ]

104

147

105− -- Special support for Enter

106− ("\ESC\^J",(KEnter,[MMeta])), ("\^J",(KEnter,[])) ]

107− ]

src/Graphics/Vty/Input/Internal.hsnew file+83

@@ -0,0 +1,83 @@

1+module Graphics.Vty.Input.Internal where

2+

3+import Graphics.Vty.Input.Data

4+

5+import Codec.Binary.UTF8.Generic (decode)

6+import Control.Concurrent

7+

8+import Data.Char

9+import Data.List( inits )

10+import qualified Data.Map as M( fromList, lookup )

11+import Data.Maybe ( mapMaybe )

12+import qualified Data.Set as S( fromList, member )

13+import Data.Word

14+

15+inputToEventThread :: (String -> KClass) -> Chan Char -> Chan Event -> IO ()

16+inputToEventThread classifier inputChannel eventChannel = loop []

17+ where loop kb = case (classifier kb) of

18+ Prefix -> do

19+ c <- readChan inputChannel

20+ if c == '\xFFFD'

21+ then return ()

22+ else loop (kb ++ [c])

23+ Invalid -> do

24+ c <- readChan inputChannel

25+ if c == '\xFFFD'

26+ then return ()

27+ else loop [c]

28+ EndLoop -> return ()

29+ MisPfx k m s -> writeChan eventChannel (EvKey k m) >> loop s

30+ Valid k m -> writeChan eventChannel (EvKey k m) >> loop ""

31+

32+compile :: ClassifyTable -> [Char] -> KClass

33+compile table = cl' where

34+ -- take all prefixes and create a set of these

35+ prefix_set = S.fromList $ concatMap (init . inits . fst) $ table

36+ -- create a map from strings to event

37+ event_for_input = flip M.lookup (M.fromList table)

38+ cl' [] = Prefix

39+ cl' input_block = case S.member input_block prefix_set of

40+ True -> Prefix

41+ -- if the input_block is exactly what is expected for an event then consume the whole

42+ -- block and return the event

43+ False -> case event_for_input input_block of

44+ Just (k,m) -> Valid k m

45+ -- look up progressively large prefixes of the input block until an event is found

46+ -- H: There will always be one match. The prefix_set contains, by definition, all

47+ -- prefixes of an event.

48+ Nothing ->

49+ let input_prefixes = init $ inits input_block

50+ in case mapMaybe (\s -> (,) s `fmap` event_for_input s) input_prefixes of

51+ (s,(k,m)) : _ -> MisPfx k m (drop (length s) input_block)

52+ [] -> error $ "vty internal inconsistency - "

53+ ++ "input not a prefix nor contains any event data "

54+ ++ show input_block

55+

56+classify, classifyTab :: ClassifyTable -> [Char] -> KClass

57+

58+-- As soon as

59+classify _table "\xFFFD" = EndLoop

60+classify _table "\xFFFE" = Invalid

61+classify _table s@(c:_) | ord c >= 0xC2

62+ = if utf8Length (ord c) > length s then Prefix else classifyUtf8 s -- beginning of an utf8 sequence

63+classify table other

64+ = classifyTab table other

65+

66+classifyUtf8 :: [Char] -> KClass

67+classifyUtf8 s = case decode ((map (fromIntegral . ord) s) :: [Word8]) of

68+ Just (unicodeChar, _) -> Valid (KASCII unicodeChar) []

69+ _ -> Invalid -- something bad happened; just ignore and continue.

70+

71+classifyTab table = compile table

72+

73+first :: (a -> b) -> (a,c) -> (b,c)

74+first f (x,y) = (f x, y)

75+

76+utf8Length :: (Num t, Ord a, Num a) => a -> t

77+utf8Length c

78+ | c < 0x80 = 1

79+ | c < 0xE0 = 2

80+ | c < 0xF0 = 3

81+ | otherwise = 4

82+

83+foreign import ccall "vty_set_term_timing" set_term_timing :: IO ()

src/Graphics/Vty/PictureToSpans.hs−1

@@ -3,7 +3,6 @@

3{-# LANGUAGE TemplateHaskell #-}

4{-# LANGUAGE BangPatterns #-}

5{-# LANGUAGE ExistentialQuantification #-}

6−{-# LANGUAGE ScopedTypeVariables #-}

7{-# LANGUAGE NamedFieldPuns #-}

6{-# LANGUAGE NamedFieldPuns #-}

8{- | Transforms an image into rows of operations.

7{- | Transforms an image into rows of operations.

9 -}

8 -}

src/Graphics/Vty/Span.hs−1

@@ -2,7 +2,6 @@

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE NamedFieldPuns #-}

4{-# LANGUAGE GADTs #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6{- | A picture is translated into a sequences of state changes and character spans.

5{- | A picture is translated into a sequences of state changes and character spans.

7 - State changes are currently limited to new attribute values. The attribute is applied to all

6 - State changes are currently limited to new attribute values. The attribute is applied to all

8 - following spans. Including spans of the next row. The nth element of the sequence represents the

7 - following spans. Including spans of the next row. The nth element of the sequence represents the

src/Graphics/Vty/Terminal.hs−1

@@ -18,7 +18,6 @@

18-- control codes as possible.

19--

21−{-# LANGUAGE ScopedTypeVariables #-}

22module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal

21module Graphics.Vty.Terminal ( module Graphics.Vty.Terminal

23 , Terminal(..) -- \todo hide constructors

22 , Terminal(..) -- \todo hide constructors

24 , AssumedState(..)

23 , AssumedState(..)

src/Graphics/Vty/Terminal/Interface.hs−1

@@ -2,7 +2,6 @@

2-- General philosophy is: MonadIO is for equations exposed to clients.

3{-# LANGUAGE BangPatterns #-}

4{-# LANGUAGE RankNTypes #-}

5−{-# LANGUAGE ScopedTypeVariables #-}

6{-# LANGUAGE ExistentialQuantification #-}

5{-# LANGUAGE ExistentialQuantification #-}

7{-# LANGUAGE GADTs #-}

6{-# LANGUAGE GADTs #-}

8{-# LANGUAGE FlexibleContexts #-}

7{-# LANGUAGE FlexibleContexts #-}

src/Graphics/Vty/Terminal/MacOSX.hs−2

@@ -5,8 +5,6 @@

5--

6-- This terminal implementation modifies the standard terminfo terminal as required for complete OS

7-- X support.

8−{-# LANGUAGE ForeignFunctionInterface #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE MagicHash #-}

8{-# LANGUAGE MagicHash #-}

11{-# LANGUAGE FlexibleInstances #-}

9{-# LANGUAGE FlexibleInstances #-}

12{-# LANGUAGE TypeFamilies #-}

10{-# LANGUAGE TypeFamilies #-}

src/Graphics/Vty/Terminal/TerminfoBased.hs−2

@@ -5,8 +5,6 @@

5-- assumptions mixed in.

6--

7-- Copyright Corey O'Connor (coreyoconnor@gmail.com)

8−{-# LANGUAGE ForeignFunctionInterface #-}

9−{-# LANGUAGE ScopedTypeVariables #-}

10{-# LANGUAGE FlexibleInstances #-}

8{-# LANGUAGE FlexibleInstances #-}

11{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}

9{-# OPTIONS_GHC -D_XOPEN_SOURCE=500 #-}

12module Graphics.Vty.Terminal.TerminfoBased ( reserve_terminal )

10module Graphics.Vty.Terminal.TerminfoBased ( reserve_terminal )

src/Graphics/Vty/Terminal/XTermColor.hs−5

@@ -1,9 +1,4 @@

2−{-# LANGUAGE ForeignFunctionInterface #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4−{-# LANGUAGE MagicHash #-}

5−{-# LANGUAGE FlexibleInstances #-}

6−{-# LANGUAGE TypeFamilies #-}

7module Graphics.Vty.Terminal.XTermColor ( reserve_terminal )

2module Graphics.Vty.Terminal.XTermColor ( reserve_terminal )

8 where

3 where

9

4

test/Rouge.hsnew file+108

@@ -0,0 +1,108 @@

1+module Main where

2+

3+import Graphics.Vty

4+

5+import Data.Array

6+import qualified Data.ByteString as B

7+import Data.Word

8+

9+import Control.Applicative

10+import Control.Monad

11+import Control.Monad.RWS

12+import Control.Monad.Writer

13+

14+import System.IO

15+import System.Random

16+

17+data Dude = Dude Int Int

18+ deriving (Show,Eq)

19+

20+data World = World

21+ { dude :: Dude

22+ , level :: Level

23+ }

24+ deriving (Show,Eq)

25+

26+data Level = Level

27+ { start :: (Int, Int)

28+ , end :: (Int, Int)

29+ , geo :: Array (Int, Int) LevelPiece

30+ }

31+ deriving (Show,Eq)

32+

33+data LevelPiece

34+ = EmptySpace

35+ | Rock

36+ deriving (Show, Eq)

37+

38+type Game = RWST Vty () World IO

39+

40+main = do

41+ vty <- mkVty

42+ level_0 <- mkLevel 0

43+ let world_0 = World (Dude (fst $ start level_0) (snd $ start level_0)) level_0

44+ (_final_world, ()) <- execRWST (play >> view_world) vty world_0

45+ shutdown vty

46+

47+mkLevel _difficulty = do

48+ level_width <- randomRIO (10,15)

49+ level_height <- randomRIO (10,15)

50+ start <- (,) <$> randomRIO (2, level_width-3) <*> randomRIO (2, level_height-3)

51+ end <- (,) <$> randomRIO (2, level_width-3) <*> randomRIO (2, level_height-3)

52+ let geo = array ((0,0), (level_width, level_height))

53+ [((x,y),p) | x <- [0..level_width-1], y <- [0..level_height-1],

54+ let p = if (x == 0 || x == level_width-1) || (y==0 || y==level_height-1)

55+ then Rock

56+ else EmptySpace

57+ ]

58+ return $ Level start end geo

59+

60+image_for_geo EmptySpace = char (def_attr `with_back_color` green) ' '

61+image_for_geo Rock = char (def_attr `with_fore_color` white) 'X'

62+

63+pieceA = def_attr `with_fore_color` red

64+dumpA = def_attr `with_style` reverse_video

65+

66+play = do

67+ view_world

68+ done <- process_event

69+ unless done play

70+

71+process_event = do

72+ k <- ask >>= liftIO . next_event

73+ if k == EvKey KEsc []

74+ then return True

75+ else do

76+ case k of

77+ EvKey (KASCII 'r') [MCtrl] -> ask >>= liftIO . refresh

78+ EvKey KLeft [] -> move_dude (-1) 0

79+ EvKey KRight [] -> move_dude 1 0

80+ EvKey KUp [] -> move_dude 0 (-1)

81+ EvKey KDown [] -> move_dude 0 1

82+ _ -> return ()

83+ return False

84+

85+move_dude dx dy = do

86+ vty <- ask

87+ world <- get

88+ let Dude x y = dude world

89+ (w, h) <- gets (snd . bounds . geo . level)

90+ put $ world { dude = Dude (min (w - 2) $ max 1 (x + dx))

91+ (min (h - 2) $ max 1 (y + dy))

92+ }

93+

94+view_world :: Game ()

95+view_world = do

96+ Dude x y <- gets dude

97+ the_level <- gets level

98+ let dude_image = translate x y (char pieceA '@')

99+ let (geo_width, geo_height) = snd $ bounds (geo the_level)

100+ geo_image = vert_cat [ geo_row | y <- [0..geo_height-1],

101+ let geo_row = horiz_cat [ i | x <- [0..geo_width-1],

102+ let i = image_for_geo (geo the_level ! (x,y))

103+ ]

104+ ]

105+ info = string def_attr "Move with the arrows keys. Press ESC to exit."

106+ let pic = pic_for_layers [info, translate 0 1 dude_image,translate 0 1 geo_image]

107+ vty <- ask

108+ liftIO $ update vty pic

test/Test.hsdeleted−44

@@ -1,44 +0,0 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2−module Main where

3−

4−import Graphics.Vty

5−

6−import qualified Data.ByteString as B

7−import Data.Word

8−

9−import System.IO

10−

11−

12−main = do

13− vt <- mkVty

14− DisplayRegion w h <- display_bounds $ terminal vt

15− putStrLn $ show $ DisplayRegion w h

16− play vt 0 1 w h ""

17−

18−pieceA = def_attr `with_fore_color` red

19−dumpA = def_attr `with_style` reverse_video

20−

21−play :: Vty -> Word -> Word -> Word -> Word -> String -> IO ()

22−play vt x y sx sy btl = do update vt (current_pic x y sx sy btl)

23− k <- next_event vt

24− case k of EvKey (KASCII 'r') [MCtrl] -> refresh vt >> play vt x y sx sy btl

25− EvKey KLeft [] | x /= 0 -> play vt (x-1) y sx sy btl

26− EvKey KRight [] | x /= (sx-1) -> play vt (x+1) y sx sy btl

27− EvKey KUp [] | y /= 1 -> play vt x (y-1) sx sy btl

28− EvKey KDown [] | y /= (sy-2) -> play vt x (y+1) sx sy btl

29− EvKey KEsc [] -> shutdown vt >> return ()

30− EvResize nx ny -> play vt (min x (toEnum nx - 1))

31− (min y (toEnum ny - 2))

32− (toEnum nx)

33− (toEnum ny)

34− btl

35− _ -> play vt x y sx sy (take (fromEnum sx) (show k ++ btl))

36−

37−

38−current_pic :: Word -> Word -> Word -> Word -> String -> Picture

39−current_pic x y sx sy btl = pic_for_image i

40− where i = string def_attr "Move the @ character around with the arrow keys. Escape exits."

41− <-> char_fill pieceA ' ' sx (y - 1)

42− <-> char_fill pieceA ' ' x 1 <|> char pieceA '@' <|> char_fill pieceA ' ' (sx - x - 1) 1

43− <-> char_fill pieceA ' ' sx (sy - y - 2)

44− <-> iso_10646_string dumpA btl

test/Verify.hs+4−1

@@ -1,6 +1,6 @@

1+{-# LANGUAGE RankNTypes #-}

1{-# LANGUAGE GADTs #-}

2{-# LANGUAGE GADTs #-}

2{-# LANGUAGE RecordWildCards #-}

3{-# LANGUAGE RecordWildCards #-}

3−{-# LANGUAGE ScopedTypeVariables #-}

4{-# LANGUAGE CPP #-}

5{-# LANGUAGE TypeSynonymInstances #-}

6{-# LANGUAGE FlexibleInstances #-}

@@ -14,6 +14,7 @@ module Verify ( module Verify

14 , module Control.Monad

15 , module Test.QuickCheck

16 , module Test.QuickCheck.Modifiers

17+ , module Text.Printf

17 , succeeded

18 , succeeded

18 , failed

19 , failed

19 , result

20 , result

@@ -37,6 +38,8 @@ import Test.QuickCheck.Property hiding ( Result(..) )

37import qualified Test.QuickCheck.Property as Prop

38import qualified Test.QuickCheck.Property as Prop

38import Test.QuickCheck.Monadic ( monadicIO )

39import Test.QuickCheck.Monadic ( monadicIO )

39

40

41+import Text.Printf

42+

40import qualified Codec.Binary.UTF8.String as UTF8

43import qualified Codec.Binary.UTF8.String as UTF8

41

44

42import Control.Applicative hiding ( (<|>) )

45import Control.Applicative hiding ( (<|>) )

test/Verify/Data/Terminfo/Parse.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse

1module Verify.Data.Terminfo.Parse ( module Verify.Data.Terminfo.Parse

3 , module Data.Terminfo.Parse

2 , module Data.Terminfo.Parse

4 )

3 )

test/Verify/Graphics/Vty/DisplayRegion.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module Verify.Graphics.Vty.DisplayRegion ( module Verify.Graphics.Vty.DisplayRegion

1module Verify.Graphics.Vty.DisplayRegion ( module Verify.Graphics.Vty.DisplayRegion

3 , module Graphics.Vty.DisplayRegion

2 , module Graphics.Vty.DisplayRegion

4 , MockWindow(..)

3 , MockWindow(..)

test/Verify/Graphics/Vty/Terminal.hs+4−2

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module Verify.Graphics.Vty.Terminal where

1module Verify.Graphics.Vty.Terminal where

3

2

4import Graphics.Vty.Terminal.Mock

3import Graphics.Vty.Terminal.Mock

@@ -9,9 +8,12 @@ import qualified Data.String.UTF8 as UTF8

9

8

10import Test.QuickCheck.Property

9import Test.QuickCheck.Property

11

10

11+import Verify

12+

12-- A list of terminals that should be supported.

13-- A list of terminals that should be supported.

13-- This started with a list of terminals ubuntu supported. Then those terminals that really could

14-- This started with a list of terminals ubuntu supported. Then those terminals that really could

14−-- not be supported were removed.

15+-- not be supported were removed. Then a few more were pruned until a reasonable looking set was

16+-- made.

15terminals_of_interest =

17terminals_of_interest =

16 [ "vt100"

18 [ "vt100"

17 , "vt220"

19 , "vt220"

test/VerifyEmptyImageProps.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module VerifyEmptyImageProps where

1module VerifyEmptyImageProps where

3

2

4import Verify

3import Verify

test/VerifyEvalTerminfoCaps.hs+1−42

@@ -1,5 +1,4 @@

1{-# LANGUAGE BangPatterns #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3{-# LANGUAGE NamedFieldPuns #-}

2{-# LANGUAGE NamedFieldPuns #-}

4module VerifyEvalTerminfoCaps where

3module VerifyEvalTerminfoCaps where

5

4

@@ -12,6 +11,7 @@ import Control.DeepSeq

12import qualified System.Console.Terminfo as Terminfo

11import qualified System.Console.Terminfo as Terminfo

13

12

14import Verify

13import Verify

14+import Verify.Graphics.Vty.Terminal

15

16import Control.Applicative ( (<$>) )

17import Control.Exception ( try, SomeException(..) )

@@ -23,47 +23,6 @@ import Data.Word

23

24import Numeric

25

26−-- A list of terminals that ubuntu includes a terminfo cap file for.

27−-- Assuming that is a good place to start.

28−terminals_of_interest =

29− [ "wsvt25"

30− , "wsvt25m"

31− , "vt52"

32− , "vt100"

33− , "vt220"

34− , "vt102"

35− , "xterm-r5"

36− , "xterm-xfree86"

37− , "xterm-r6"

38− , "xterm-256color"

39− , "xterm-vt220"

40− , "xterm-debian"

41− , "xterm-mono"

42− , "xterm-color"

43− , "xterm"

44− , "mach"

45− , "mach-bold"

46− , "mach-color"

47− , "linux"

48− , "ansi"

49− , "hurd"

50− , "Eterm"

51− , "pcansi"

52− , "screen-256color"

53− , "screen-bce"

54− , "screen-s"

55− , "screen-w"

56− , "screen"

57− , "screen-256color-bce"

58− , "sun"

59− , "rxvt"

60− , "rxvt-unicode"

61− , "rxvt-basic"

62− , "cygwin"

63− , "cons25"

64− , "dumb"

65− ]

66−

67-- If a terminal defines one of the caps then it's expected to be parsable.

26-- If a terminal defines one of the caps then it's expected to be parsable.

68caps_of_interest =

27caps_of_interest =

69 [ "cup"

28 [ "cup"

test/VerifyImageOps.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module VerifyImageOps where

1module VerifyImageOps where

3

2

4import Graphics.Vty.Attributes

3import Graphics.Vty.Attributes

test/VerifyParseTerminfoCaps.hs+2−43

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2{-# LANGUAGE NamedFieldPuns #-}

1{-# LANGUAGE NamedFieldPuns #-}

3module VerifyParseTerminfoCaps where

2module VerifyParseTerminfoCaps where

4

3

@@ -7,6 +6,7 @@ import Prelude hiding ( catch )

7import qualified System.Console.Terminfo as Terminfo

6import qualified System.Console.Terminfo as Terminfo

8

7

9import Verify.Data.Terminfo.Parse

8import Verify.Data.Terminfo.Parse

9+import Verify.Graphics.Vty.Terminal

10import Verify

11

12import Data.Maybe ( catMaybes, fromJust )

@@ -14,48 +14,8 @@ import Data.Word

14

15import Numeric

16

17−-- A list of terminals that ubuntu includes a terminfo cap file for.

18−-- Assuming that is a good place to start.

19−terminals_of_interest =

20− [ "wsvt25"

21− , "wsvt25m"

22− , "vt52"

23− , "vt100"

24− , "vt220"

25− , "vt102"

26− , "xterm-r5"

27− , "xterm-xfree86"

28− , "xterm-r6"

29− , "xterm-256color"

30− , "xterm-vt220"

31− , "xterm-debian"

32− , "xterm-mono"

33− , "xterm-color"

34− , "xterm"

35− , "mach"

36− , "mach-bold"

37− , "mach-color"

38− , "linux"

39− , "ansi"

40− , "hurd"

41− , "Eterm"

42− , "pcansi"

43− , "screen-256color"

44− , "screen-bce"

45− , "screen-s"

46− , "screen-w"

47− , "screen"

48− , "screen-256color-bce"

49− , "sun"

50− , "rxvt"

51− , "rxvt-unicode"

52− , "rxvt-basic"

53− , "cygwin"

54− , "cons25"

55− , "dumb"

56− ]

57−

58-- If a terminal defines one of the caps then it's expected to be parsable.

17-- If a terminal defines one of the caps then it's expected to be parsable.

18+-- TODO: reduce duplication with terminfo terminal implementation.

59caps_of_interest =

19caps_of_interest =

60 [ "cup"

20 [ "cup"

61 , "sc"

21 , "sc"

@@ -81,7 +41,6 @@ from_capname ti name = fromJust $ Terminfo.getCapability ti (Terminfo.tiGetStr n

81tests :: IO [Test]

41tests :: IO [Test]

82tests = do

42tests = do

83 parse_tests <- concat <$> forM terminals_of_interest ( \term_name -> do

43 parse_tests <- concat <$> forM terminals_of_interest ( \term_name -> do

84− putStrLn $ "testing parsing of caps for terminal: " ++ term_name

85 mti <- liftIO $ try $ Terminfo.setupTerm term_name

44 mti <- liftIO $ try $ Terminfo.setupTerm term_name

86 case mti of

45 case mti of

87 Left (_e :: SomeException)

46 Left (_e :: SomeException)

test/VerifyTerminal.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2{- We setup the environment to envoke certain terminals of interest.

1{- We setup the environment to envoke certain terminals of interest.

3 - This assumes appropriate definitions exist in the current environment for the terminals of

2 - This assumes appropriate definitions exist in the current environment for the terminals of

4 - interest.

3 - interest.

test/VerifyUsingMockInput.hs+106−10

@@ -1,24 +1,120 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

1+{-# LANGUAGE MultiParamTypeClasses #-}

2+{-# LANGUAGE FlexibleInstances #-}

2{- We setup the environment to envoke certain terminals of interest.

3{- We setup the environment to envoke certain terminals of interest.

3 - This assumes appropriate definitions exist in the current environment for the terminals of

4 - This assumes appropriate definitions exist in the current environment for the terminals of

4 - interest.

5 - interest.

5 -}

6 -}

6−module VerifyUsingMockInput where

7+module Main where

7−import Verify

8

9−import Graphics.Vty

9+import Verify.Graphics.Vty.Terminal

10

11+import Data.List (intersperse, permutations)

12+

13+import Graphics.Vty hiding (resize)

14+import Graphics.Vty.Input

15+import Graphics.Vty.Input.Data

16+import Graphics.Vty.Input.Internal

17+import Graphics.Vty.Input.Terminfo

18+

19+import Control.Applicative

20+import Control.Concurrent

21+import Control.Exception

11import Control.Monad

22import Control.Monad

12

23

13−import System.Posix.Env

24+import System.Console.Terminfo

14import System.IO

25import System.IO

15

26

16−data InputSpec

27+import Test.Framework.Providers.SmallCheck

28+import Test.Framework

29+import Test.SmallCheck

30+import Test.SmallCheck.Series

31+

32+-- processing a block of 16 chars is the largest I can do without taking too long to run the test.

33+max_block_size :: Int

34+max_block_size = 16

35+

36+forEachOf :: (Show a, Testable m b) => [a] -> (a -> b) -> Property m

37+forEachOf l = over (generate (\n -> take n l))

38+

39+data InputEvent

17− = KeySeq String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.

40+ = Bytes String -- | input sequence encoded as a string. Regardless, the input is read a byte at a time.

18− | Delay Int -- | millisecond delay

41+ | Delay Int -- | millisecond delay

42+ deriving Show

43+

44+type InputSpec = [InputEvent]

19

45

20type ExpectedSpec = [Event]

46type ExpectedSpec = [Event]

21

47

22−tests :: IO [Test]

48+exec_input_spec :: InputSpec -> Handle -> IO ()

23−tests = return []

49+exec_input_spec input out_handle = forM_ input f

50+ where

51+ f (Bytes str) = hPutStr out_handle str >> hFlush out_handle

52+ f (Delay t) = threadDelay (t*1000)

53+

54+assert_events_from_input_block :: ClassifyTable -> InputSpec -> ExpectedSpec -> IO Bool

55+assert_events_from_input_block table input_spec expected_events = do

56+ print input_spec

57+ let classifier = classify table

58+ input <- newChan

59+ output <- newChan

60+ read_complete <- newEmptyMVar

61+ write_complete <- newEmptyMVar

62+ _ <- forkIO $ write_input_spec_to_chan input input_spec

63+ `finally` putMVar write_complete ()

64+ _ <- forkIO $ inputToEventThread classifier input output

65+ `finally` putMVar read_complete ()

66+ () <- takeMVar write_complete

67+ () <- takeMVar read_complete

68+ -- TODO: use STM channel

69+ -- assures the next line does not block.

70+ writeList2Chan output $ replicate (length expected_events) undefined

71+ out_events <- take (length expected_events) <$> getChanContents output

72+ return $ out_events == expected_events

73+

74+write_input_spec_to_chan :: Chan Char -> InputSpec -> IO ()

75+write_input_spec_to_chan chan [] = do

76+ writeChan chan '\xFFFD'

77+write_input_spec_to_chan chan (Bytes str : input_spec') = do

78+ writeList2Chan chan str

79+ write_input_spec_to_chan chan input_spec'

80+write_input_spec_to_chan chan (Delay _t : input_spec') = do

81+ writeChan chan '\xFFFE'

82+ write_input_spec_to_chan chan input_spec'

83+

84+newtype InputBlocksUsingTable event

85+ = InputBlocksUsingTable ([(String,event)] -> [(String, event)])

86+

87+instance Show (InputBlocksUsingTable event) where

88+ show (InputBlocksUsingTable _g) = "InputBlocksUsingTable"

89+

90+instance Monad m => Serial m (InputBlocksUsingTable event) where

91+ series = do

92+ n :: Int <- localDepth (max max_block_size) series -- what elements to select from the table

93+ return $ InputBlocksUsingTable $ \table -> concat (take n (permutations table))

94+

95+verify_simple_input_block_to_event :: Property IO

96+verify_simple_input_block_to_event = forAll $ \(InputBlocksUsingTable gen) -> do

97+ let input_seq = gen simple_chars

98+ input = Bytes $ concat [s | (s,_) <- input_seq]

99+ events = [e | (_,(k,ms)) <- input_seq, let e = EvKey k ms]

100+ monadic $ assert_events_from_input_block simple_chars [input] events

101+

102+verify_keys_from_caps_table_block_to_event :: Property IO

103+verify_keys_from_caps_table_block_to_event = forAll $ \(InputBlocksUsingTable gen) ->

104+ forEachOf terminals_of_interest $ \term_name -> monadic $ do

105+ term <- setupTerm term_name

106+ let table = caps_classify_table term keys_from_caps_table

107+ input_seq = gen table

108+ events = [e | (_,e) <- input_seq]

109+ keydowns = [Bytes s | (s,_) <- input_seq]

110+ input = intersperse (Delay defaultEscDelay) keydowns

111+ assert_events_from_input_block (map_to_legacy_table table) input events

112+

113+main :: IO ()

114+main = defaultMain

115+ [ testProperty "basic block generated from a single ansi chars to event translation"

116+ verify_simple_input_block_to_event

117+ , testProperty "key sequences read from caps table map to expected events"

118+ verify_keys_from_caps_table_block_to_event

119+ ]

24

120

test/VerifyUsingMockTerminal.hs−1

@@ -1,4 +1,3 @@

1−{-# LANGUAGE ScopedTypeVariables #-}

2module VerifyUsingMockTerminal where

1module VerifyUsingMockTerminal where

3

2

4import Verify.Graphics.Vty.DisplayRegion

3import Verify.Graphics.Vty.DisplayRegion

test/benchmark.hs−1

@@ -1,5 +1,4 @@

1{-# LANGUAGE QuasiQuotes #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3module Main where

2module Main where

4

3

5import Graphics.Vty

4import Graphics.Vty

test/interactive_terminal_test.hs−1

@@ -1,5 +1,4 @@

1{-# LANGUAGE QuasiQuotes #-}

2−{-# LANGUAGE ScopedTypeVariables #-}

3module Main where

2module Main where

4

3

5import Graphics.Vty

4import Graphics.Vty

vty.cabal+57−8

@@ -27,8 +27,7 @@ description:

28 .

30−-- the test suites require >= 1.17.0

31−cabal-version: >= 1.14.0

30+cabal-version: >= 1.18.0

32build-type: Simple

31build-type: Simple

33data-files: README.md,

32data-files: README.md,

34 TODO,

33 TODO,

@@ -38,6 +37,7 @@ data-files: README.md,

38

37

39library

38library

40 default-language: Haskell2010

39 default-language: Haskell2010

40+ default-extensions: ScopedTypeVariables

41 build-depends: base >= 4 && < 5,

42 bytestring,

43 containers,

@@ -61,6 +61,8 @@ library

61 Graphics.Vty.Inline.Unsafe

62 Graphics.Vty.Input

63 Graphics.Vty.Input.Data

64+ Graphics.Vty.Input.Internal

65+ Graphics.Vty.Input.Terminfo

64 Graphics.Vty.Picture

66 Graphics.Vty.Picture

65 Graphics.Vty.Terminal

67 Graphics.Vty.Terminal

66 Graphics.Text.Width

68 Graphics.Text.Width

@@ -90,14 +92,18 @@ library

90

92

91 hs-source-dirs: src

93 hs-source-dirs: src

92

94

93− ghc-options: -O2 -funbox-strict-fields -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10

95+ default-extensions: ScopedTypeVariables

96+ ForeignFunctionInterface

94

97

98+ ghc-options: -O2 -funbox-strict-fields -threaded -Wall -fspec-constr -fspec-constr-count=10

99+

95− ghc-prof-options: -O2 -funbox-strict-fields -caf-all -Wall -fno-full-laziness -fspec-constr -fspec-constr-count=10

100+ ghc-prof-options: -O2 -funbox-strict-fields -threaded -caf-all -Wall -fspec-constr -fspec-constr-count=10

96

101

97 cc-options: -O2

102 cc-options: -O2

98

103

99test-suite verify-attribute-ops

104test-suite verify-attribute-ops

100 default-language: Haskell2010

105 default-language: Haskell2010

106+ default-extensions: ScopedTypeVariables

101 type: detailed-0.9

107 type: detailed-0.9

102 hs-source-dirs: test

108 hs-source-dirs: test

103 test-module: VerifyAttributeOps

109 test-module: VerifyAttributeOps

@@ -117,6 +123,7 @@ test-suite verify-attribute-ops

117

123

118test-suite verify-using-mock-terminal

124test-suite verify-using-mock-terminal

119 default-language: Haskell2010

125 default-language: Haskell2010

126+ default-extensions: ScopedTypeVariables

120

127

121 type: detailed-0.9

128 type: detailed-0.9

122

129

@@ -142,12 +149,14 @@ test-suite verify-using-mock-terminal

142 deepseq >= 1.1 && < 1.4,

149 deepseq >= 1.1 && < 1.4,

143 mtl >= 1.1.1.0 && < 2.2,

150 mtl >= 1.1.1.0 && < 2.2,

144 text >= 0.11.3,

151 text >= 0.11.3,

152+ terminfo,

145 unix,

153 unix,

146 utf8-string >= 0.3 && < 0.4,

154 utf8-string >= 0.3 && < 0.4,

147 vector >= 0.7

155 vector >= 0.7

148

156

149test-suite verify-terminal

157test-suite verify-terminal

150 default-language: Haskell2010

158 default-language: Haskell2010

159+ default-extensions: ScopedTypeVariables

151

160

152 type: detailed-0.9

161 type: detailed-0.9

153

162

@@ -180,6 +189,7 @@ test-suite verify-terminal

180

189

181test-suite verify-display-attributes

190test-suite verify-display-attributes

182 default-language: Haskell2010

191 default-language: Haskell2010

192+ default-extensions: ScopedTypeVariables

183

193

184 type: detailed-0.9

194 type: detailed-0.9

185

195

@@ -210,6 +220,7 @@ test-suite verify-display-attributes

210

220

211test-suite verify-empty-image-props

221test-suite verify-empty-image-props

212 default-language: Haskell2010

222 default-language: Haskell2010

223+ default-extensions: ScopedTypeVariables

213

224

214 type: detailed-0.9

225 type: detailed-0.9

215

226

@@ -235,6 +246,7 @@ test-suite verify-empty-image-props

235

246

236test-suite verify-eval-terminfo-caps

247test-suite verify-eval-terminfo-caps

237 default-language: Haskell2010

248 default-language: Haskell2010

249+ default-extensions: ScopedTypeVariables

238

250

239 type: detailed-0.9

251 type: detailed-0.9

240

252

@@ -243,6 +255,7 @@ test-suite verify-eval-terminfo-caps

243 test-module: VerifyEvalTerminfoCaps

255 test-module: VerifyEvalTerminfoCaps

244

256

245 other-modules: Verify

257 other-modules: Verify

258+ Verify.Graphics.Vty.Terminal

246

259

247 build-depends: vty,

260 build-depends: vty,

248 Cabal == 1.18.*,

261 Cabal == 1.18.*,

@@ -261,6 +274,7 @@ test-suite verify-eval-terminfo-caps

261

274

262test-suite verify-image-ops

275test-suite verify-image-ops

263 default-language: Haskell2010

276 default-language: Haskell2010

277+ default-extensions: ScopedTypeVariables

264

278

265 type: detailed-0.9

279 type: detailed-0.9

266

280

@@ -288,6 +302,7 @@ test-suite verify-image-ops

288

302

289test-suite verify-image-trans

303test-suite verify-image-trans

290 default-language: Haskell2010

304 default-language: Haskell2010

305+ default-extensions: ScopedTypeVariables

291

306

292 type: detailed-0.9

307 type: detailed-0.9

293

308

@@ -315,6 +330,7 @@ test-suite verify-image-trans

315

330

316test-suite verify-inline

331test-suite verify-inline

317 default-language: Haskell2010

332 default-language: Haskell2010

333+ default-extensions: ScopedTypeVariables

318

334

319 type: detailed-0.9

335 type: detailed-0.9

320

336

@@ -341,6 +357,7 @@ test-suite verify-inline

341

357

342test-suite verify-parse-terminfo-caps

358test-suite verify-parse-terminfo-caps

343 default-language: Haskell2010

359 default-language: Haskell2010

360+ default-extensions: ScopedTypeVariables

344

361

345 type: detailed-0.9

362 type: detailed-0.9

346

363

@@ -350,6 +367,7 @@ test-suite verify-parse-terminfo-caps

350

367

351 other-modules: Verify

368 other-modules: Verify

352 Verify.Data.Terminfo.Parse

369 Verify.Data.Terminfo.Parse

370+ Verify.Graphics.Vty.Terminal

353

371

354 build-depends: vty,

372 build-depends: vty,

355 Cabal == 1.18.*,

373 Cabal == 1.18.*,

@@ -368,6 +386,7 @@ test-suite verify-parse-terminfo-caps

368

386

369test-suite verify-simple-span-generation

387test-suite verify-simple-span-generation

370 default-language: Haskell2010

388 default-language: Haskell2010

389+ default-extensions: ScopedTypeVariables

371

390

372 type: detailed-0.9

391 type: detailed-0.9

373

392

@@ -399,6 +418,7 @@ test-suite verify-simple-span-generation

399

418

400test-suite verify-crop-span-generation

419test-suite verify-crop-span-generation

401 default-language: Haskell2010

420 default-language: Haskell2010

421+ default-extensions: ScopedTypeVariables

402

422

403 type: detailed-0.9

423 type: detailed-0.9

404

424

@@ -430,6 +450,7 @@ test-suite verify-crop-span-generation

430

450

431test-suite verify-layers-span-generation

451test-suite verify-layers-span-generation

432 default-language: Haskell2010

452 default-language: Haskell2010

453+ default-extensions: ScopedTypeVariables

433

454

434 type: detailed-0.9

455 type: detailed-0.9

435

456

@@ -460,6 +481,7 @@ test-suite verify-layers-span-generation

460

481

461test-suite verify-utf8-width

482test-suite verify-utf8-width

462 default-language: Haskell2010

483 default-language: Haskell2010

484+ default-extensions: ScopedTypeVariables

463

485

464 type: detailed-0.9

486 type: detailed-0.9

465

487

@@ -485,34 +507,40 @@ test-suite verify-utf8-width

485

507

486test-suite verify-using-mock-input

508test-suite verify-using-mock-input

487 default-language: Haskell2010

509 default-language: Haskell2010

510+ default-extensions: ScopedTypeVariables

488

511

489− type: detailed-0.9

512+ type: exitcode-stdio-1.0

490

513

491 hs-source-dirs: test

514 hs-source-dirs: test

492

515

493− test-module: VerifyUsingMockInput

516+ main-is: VerifyUsingMockInput.hs

494−

495− other-modules: Verify

496

517

497 build-depends: vty,

518 build-depends: vty,

498 Cabal == 1.18.*,

519 Cabal == 1.18.*,

499 QuickCheck >= 2.4,

520 QuickCheck >= 2.4,

521+ smallcheck == 1.*,

522+ quickcheck-assertions >= 0.1.1,

523+ test-framework == 0.8.*,

524+ test-framework-smallcheck == 0.2.*,

500 random == 1.0.*,

525 random == 1.0.*,

501 base >= 4 && < 5,

526 base >= 4 && < 5,

502 bytestring,

527 bytestring,

503 containers,

528 containers,

504 deepseq >= 1.1 && < 1.4,

529 deepseq >= 1.1 && < 1.4,

505 mtl >= 1.1.1.0 && < 2.2,

530 mtl >= 1.1.1.0 && < 2.2,

531+ terminfo >= 0.3 && < 0.4,

506 text >= 0.11.3,

532 text >= 0.11.3,

507 unix,

533 unix,

508 utf8-string >= 0.3 && < 0.4,

534 utf8-string >= 0.3 && < 0.4,

509 vector >= 0.7

535 vector >= 0.7

510

536

537+ ghc-options: -threaded -Wall

511

538

512executable vty-interactive-terminal-test

539executable vty-interactive-terminal-test

513 main-is: interactive_terminal_test.hs

540 main-is: interactive_terminal_test.hs

514

541

515 default-language: Haskell2010

542 default-language: Haskell2010

543+ default-extensions: ScopedTypeVariables

516

544

517 hs-source-dirs: test

545 hs-source-dirs: test

518

546

@@ -533,10 +561,31 @@ executable vty-interactive-terminal-test

533 utf8-string >= 0.3 && < 0.4,

561 utf8-string >= 0.3 && < 0.4,

534 vector >= 0.7

562 vector >= 0.7

535

563

564+executable vty-rouge

565+ main-is: Rouge.hs

566+ hs-source-dirs: test

567+

568+ default-language: Haskell2010

569+ default-extensions: ScopedTypeVariables

570+

571+ build-depends: vty,

572+ base >= 4 && < 5,

573+ array >= 0.4 && < 2.0,

574+ bytestring,

575+ containers,

576+ lens,

577+ mtl >= 1.1.1.0 && < 2.2,

578+ parallel >= 2.2 && < 3.3,

579+ random >= 1.0 && < 2.0,

580+ text >= 0.11.3,

581+ utf8-string >= 0.3 && < 0.4,

582+ vector >= 0.7

583+

536executable vty-benchmark

584executable vty-benchmark

537 main-is: benchmark.hs

585 main-is: benchmark.hs

538

586

539 default-language: Haskell2010

587 default-language: Haskell2010

588+ default-extensions: ScopedTypeVariables

540

589

541 hs-source-dirs: test

590 hs-source-dirs: test

542

591