30fd552 · vty · git.iko.soy

src/Graphics/Vty/Debug.hs+2−27

compare with master

unifiedsplit

@@ -1,11 +1,12 @@

2{-# LANGUAGE ScopedTypeVariables #-}

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

4+ , module Graphics.Vty.Debug.Image

4 )

5 )

5where

6where

6

7

7import Graphics.Vty.Attributes

8import Graphics.Vty.Attributes

8−import Graphics.Vty.Image

9+import Graphics.Vty.Debug.Image

9import Graphics.Vty.Picture

10import Graphics.Vty.Picture

10import Graphics.Vty.Span

11import Graphics.Vty.Span

11import Graphics.Vty.DisplayRegion

12import Graphics.Vty.DisplayRegion

@@ -49,31 +50,5 @@ region_for_window (DebugWindow w h) = DisplayRegion w h

49

50

50type TestWindow = DebugWindow

51type TestWindow = DebugWindow

51

52

52−type ImageConstructLog = [ImageConstructEvent]

53−data ImageConstructEvent = ImageConstructEvent

54− deriving ( Show, Eq )

55−

56−forward_image_ops = map forward_transform debug_image_ops

57−

58−forward_transform, reverse_transform :: ImageOp -> (Image -> Image)

59−

60−forward_transform (ImageOp f _) = f

61−reverse_transform (ImageOp _ r) = r

62−

63−data ImageOp = ImageOp ImageEndo ImageEndo

64−type ImageEndo = Image -> Image

65−

66−debug_image_ops =

67− [ id_image_op

68− -- , render_single_column_char_op

69− -- , render_double_column_char_op

70− ]

71−

72−id_image_op :: ImageOp

73−id_image_op = ImageOp id id

74−

75−-- render_char_op :: ImageOp

76−-- render_char_op = ImageOp id id

77−

78instance Show Picture where

53instance Show Picture where

79 show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??"

54 show (Picture _ image _ ) = "Picture ?? " ++ show image ++ " ??"

src/Graphics/Vty/Debug/Image.hsnew file+30

@@ -0,0 +1,30 @@

1+{-# LANGUAGE ScopedTypeVariables #-}

2+module Graphics.Vty.Debug.Image where

3+

4+import Graphics.Vty.Image

5+

6+type ImageConstructLog = [ImageConstructEvent]

7+data ImageConstructEvent = ImageConstructEvent

8+ deriving ( Show, Eq )

9+

10+forward_image_ops = map forward_transform debug_image_ops

11+

12+forward_transform, reverse_transform :: ImageOp -> (Image -> Image)

13+

14+forward_transform (ImageOp f _) = f

15+reverse_transform (ImageOp _ r) = r

16+

17+data ImageOp = ImageOp ImageEndo ImageEndo

18+type ImageEndo = Image -> Image

19+

20+debug_image_ops =

21+ [ id_image_op

22+ -- , render_single_column_char_op

23+ -- , render_double_column_char_op

24+ ]

25+

26+id_image_op :: ImageOp

27+id_image_op = ImageOp id id

28+

29+-- render_char_op :: ImageOp

30+-- render_char_op = ImageOp id id

src/Graphics/Vty/Image.hs+18−11

@@ -45,7 +45,10 @@ import Data.Word

45infixr 5 <|>

46infixr 4 <->

47

48+-- | We pair each character with it's display length. This way we only compute the length once per

49+-- character.

50+-- * Though currently the width of some strings is still compute multiple times.

48−type StringSeq = Seq.Seq Char

51+type DisplayString = Seq.Seq (Char, Word)

49

52

50-- | An image in VTY defines:

53-- | An image in VTY defines:

51--

54--

@@ -69,8 +72,7 @@ data Image =

69 HorizText

72 HorizText

70 { attr :: !Attr

73 { attr :: !Attr

71 -- All character data is stored as Char sequences with the ISO-10646 encoding.

74 -- All character data is stored as Char sequences with the ISO-10646 encoding.

72− , text :: StringSeq

75+ , text :: DisplayString

73− -- in columns

74 , output_width :: !Word -- >= 0

76 , output_width :: !Word -- >= 0

75 , char_width :: !Word -- >= 1

77 , char_width :: !Word -- >= 1

76 }

78 }

@@ -113,7 +115,7 @@ data Image =

113

115

114instance Show Image where

116instance Show Image where

115 show ( HorizText { output_width = ow, text = txt } )

117 show ( HorizText { output_width = ow, text = txt } )

116− = "HorizText [" ++ show ow ++ "] (" ++ show txt ++ ")"

118+ = "HorizText [" ++ show ow ++ "] (" ++ show (fmap fst txt) ++ ")"

117 show ( BGFill { output_width = c, output_height = r } )

119 show ( BGFill { output_width = c, output_height = r } )

118 = "BGFill (" ++ show c ++ "," ++ show r ++ ")"

120 = "BGFill (" ++ show c ++ "," ++ show r ++ ")"

119 show ( HorizJoin { part_left = l, part_right = r, output_width = c } )

121 show ( HorizJoin { part_left = l, part_right = r, output_width = c } )

@@ -128,14 +130,13 @@ instance Show Image where

128 = "ImagePad " ++ show size ++ " ( " ++ show i ++ " )"

130 = "ImagePad " ++ show size ++ " ( " ++ show i ++ " )"

129 show ( EmptyImage ) = "EmptyImage"

131 show ( EmptyImage ) = "EmptyImage"

130

132

131−-- | Currently append in the Monoid instance is equivalent to <->. Future versions will just stack

133+-- | Currently append in the Monoid instance is equivalent to <->.

132−-- the images.

133instance Monoid Image where

134instance Monoid Image where

134 mempty = empty_image

135 mempty = empty_image

135 mappend = (<->)

136 mappend = (<->)

136

137

137-- A horizontal text image of 0 characters in width simplifies to the EmptyImage

138-- A horizontal text image of 0 characters in width simplifies to the EmptyImage

138−horiz_text :: Attr -> StringSeq -> Word -> Image

139+horiz_text :: Attr -> DisplayString -> Word -> Image

139horiz_text a txt ow

140horiz_text a txt ow

140 | ow == 0 = EmptyImage

141 | ow == 0 = EmptyImage

141 | otherwise = HorizText a txt ow (toEnum $ Seq.length txt)

142 | otherwise = HorizText a txt ow (toEnum $ Seq.length txt)

@@ -288,7 +289,9 @@ vert_cat = foldr (<->) EmptyImage

288-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in

289-- | an image of a single character. This is a standard Haskell 31-bit character assumed to be in

289-- the ISO-10646 encoding.

290-- the ISO-10646 encoding.

290char :: Attr -> Char -> Image

291char :: Attr -> Char -> Image

292+char !a !c =

293+ let display_width = safe_wcwidth c

291−char !a !c = HorizText a (Seq.singleton c) (safe_wcwidth c) 1

294+ in HorizText a (Seq.singleton (c, display_width)) display_width 1

292

295

293-- | A string of characters layed out on a single row with the same display attribute. The string is

296-- | A string of characters layed out on a single row with the same display attribute. The string is

294-- assumed to be a sequence of ISO-10646 characters.

297-- assumed to be a sequence of ISO-10646 characters.

@@ -300,7 +303,9 @@ char !a !c = HorizText a (Seq.singleton c) (safe_wcwidth c) 1

300-- directly to iso_10646_string or string.

303-- directly to iso_10646_string or string.

301--

304--

302iso_10646_string :: Attr -> String -> Image

305iso_10646_string :: Attr -> String -> Image

303−iso_10646_string !a !str = horiz_text a (Seq.fromList str) (safe_wcswidth str)

306+iso_10646_string !a !str =

307+ let display_text = Seq.fromList $ map (\c -> (c, safe_wcwidth c)) str

308+ in horiz_text a display_text (safe_wcswidth str)

304

309

305-- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is

310-- | Alias for iso_10646_string. Since the usual case is that a literal string like "foo" is

306-- represented internally as a list of ISO 10646 31 bit characters.

311-- represented internally as a list of ISO 10646 31 bit characters.

@@ -316,14 +321,16 @@ string = iso_10646_string

316utf8_string :: Attr -> [Word8] -> Image

321utf8_string :: Attr -> [Word8] -> Image

317utf8_string !a !str = string a ( decode str )

322utf8_string !a !str = string a ( decode str )

318

323

324+-- | Returns the display width of a character. Assumes all characters with unknown widths are 0 width

319safe_wcwidth :: Char -> Word

325safe_wcwidth :: Char -> Word

320safe_wcwidth c = case wcwidth c of

326safe_wcwidth c = case wcwidth c of

321− i | i < 0 -> 0 -- error "negative wcwidth"

327+ i | i < 0 -> 0

322 | otherwise -> toEnum i

328 | otherwise -> toEnum i

323

329

330+-- | Returns the display width of a string. Assumes all characters with unknown widths are 0 width

324safe_wcswidth :: String -> Word

331safe_wcswidth :: String -> Word

325safe_wcswidth str = case wcswidth str of

332safe_wcswidth str = case wcswidth str of

326− i | i < 0 -> 0 -- error "negative wcswidth"

333+ i | i < 0 -> 0

327 | otherwise -> toEnum i

334 | otherwise -> toEnum i

328

335

329-- | Renders a UTF-8 encoded bytestring.

336-- | Renders a UTF-8 encoded bytestring.

test/Bench.hs+1−1

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

1module Main where

2

3−import Graphics.Vty

3+import Graphics.Vty hiding ( pad )

4

5import Control.Concurrent( threadDelay )

6import Control.Monad( liftM2 )

test/Makefile+11−1

@@ -26,7 +26,17 @@ $(VERIF_TESTS)

26$(shell mkdir -p objects )

27

28# TODO: Tests should also be buildable referencing the currently installed vty

29−GHC_ARGS=--make -i../src -package parallel -package deepseq-1.1.0.2 -hide-package transformers -hide-package monads-fd -hide-package monads-tf -package QuickCheck-2.4 -ignore-package vty ../cbits/gwinsz.c ../cbits/set_term_timing.c ../cbits/mk_wcwidth.c -O -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr -odir objects -hidir objects

29+GHC_ARGS=--make -i../src \

30+ -package parallel \

31+ -package deepseq-1.1.0.2 \

32+ -hide-package transformers \

33+ -hide-package monads-fd \

34+ -hide-package monads-tf \

35+ -package QuickCheck-2.4 \

36+ -ignore-package vty \

37+ ../cbits/gwinsz.c ../cbits/set_term_timing.c ../cbits/mk_wcwidth.c \

38+ -O -funbox-strict-fields -Wall -threaded -fno-full-laziness -fspec-constr -rtsopts \

39+ -odir objects -hidir objects

30

40

31GHC_PROF_ARGS=-prof -auto-all $(GHC_ARGS)

41GHC_PROF_ARGS=-prof -auto-all $(GHC_ARGS)

32

42

test/Verify.hs+3−4

@@ -11,8 +11,6 @@ module Verify ( module Verify

11 , Result(..)

12 , monadicIO

13 , liftIO

14− , liftIOResult

15− , liftResult

16 , liftBool

14 , liftBool

17 )

15 )

18 where

16 where

@@ -82,6 +80,7 @@ instance Arbitrary DoubleColumnChar where

82 [ toEnum 0x3040 .. toEnum 0x3098 ]

80 [ toEnum 0x3040 .. toEnum 0x3098 ]

83 ++ [ toEnum 0x309B .. toEnum 0xA4CF]

81 ++ [ toEnum 0x309B .. toEnum 0xA4CF]

84

82

85−instance Arbitrary Word where

83+

86− arbitrary = choose (0, 1024) >>= return . toEnum

84+liftIOResult :: Testable prop => IO prop -> Property

85+liftIOResult = morallyDubiousIOProperty

87

86

test/Verify/Graphics/Vty/DisplayRegion.hs+2−2

@@ -21,7 +21,7 @@ instance Show EmptyWindow where

21

22instance Arbitrary DebugWindow where

23 arbitrary = do

24− w <- suchThat arbitrary (/= 0)

24+ w <- choose (1,1024)

25− h <- suchThat arbitrary (/= 0)

25+ h <- choose (1,1024)

26 return $ DebugWindow w h

27

test/Verify/Graphics/Vty/Image.hs+4−5

@@ -5,12 +5,11 @@ module Verify.Graphics.Vty.Image ( module Verify.Graphics.Vty.Image

5 )

6 where

7

8+import Verify.Graphics.Vty.Attributes

8−import Graphics.Vty.Debug

9+import Graphics.Vty.Debug.Image

9import Graphics.Vty.Image

10import Graphics.Vty.Image

10−import Graphics.Vty.DisplayRegion

11

12import Verify

13−import Verify.Graphics.Vty.Attributes

14

13

15import Data.Word

14import Data.Word

16

15

@@ -51,7 +50,7 @@ instance Arbitrary SingleRowSingleAttrImage where

51 -- The text must contain at least one character. Otherwise the image simplifies to the

50 -- The text must contain at least one character. Otherwise the image simplifies to the

52 -- IdImage which has a height of 0. If this is to represent a single row then the height

51 -- IdImage which has a height of 0. If this is to represent a single row then the height

53 -- must be 1

52 -- must be 1

54− single_column_row_text <- listOf1 arbitrary

53+ single_column_row_text <- resize 512 (listOf1 arbitrary)

55 attr <- arbitrary

54 attr <- arbitrary

56 return $ SingleRowSingleAttrImage

55 return $ SingleRowSingleAttrImage

57 attr

56 attr

@@ -81,7 +80,7 @@ data SingleAttrSingleSpanStack = SingleAttrSingleSpanStack

81

80

82instance Arbitrary SingleAttrSingleSpanStack where

81instance Arbitrary SingleAttrSingleSpanStack where

83 arbitrary = do

82 arbitrary = do

84− NonEmpty image_list <- arbitrary

83+ image_list <- resize 512 (listOf1 arbitrary)

85 let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ]

84 let image = vert_cat [ i | SingleRowSingleAttrImage { row_image = i } <- image_list ]

86 return $ SingleAttrSingleSpanStack

85 return $ SingleAttrSingleSpanStack

87 image

86 image

test/verify_image_ops.hs+13−13

@@ -106,19 +106,19 @@ disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =

106 _ -> True

107

108main = run_test $ do

109− verify "two_sw_horiz_concat" two_sw_horiz_concat

109+ _ <- verify "two_sw_horiz_concat" two_sw_horiz_concat

110− verify "many_sw_horiz_concat" many_sw_horiz_concat

110+ _ <- verify "many_sw_horiz_concat" many_sw_horiz_concat

111− verify "two_sw_vert_concat" two_sw_vert_concat

111+ _ <- verify "two_sw_vert_concat" two_sw_vert_concat

112− verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc

112+ _ <- verify "horiz_concat_sw_assoc" horiz_concat_sw_assoc

113− verify "many_dw_horiz_concat" many_dw_horiz_concat

113+ _ <- verify "many_dw_horiz_concat" many_dw_horiz_concat

114− verify "two_dw_horiz_concat" two_dw_horiz_concat

114+ _ <- verify "two_dw_horiz_concat" two_dw_horiz_concat

115− verify "two_dw_vert_concat" two_dw_vert_concat

115+ _ <- verify "two_dw_vert_concat" two_dw_vert_concat

116− verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc

116+ _ <- verify "horiz_concat_dw_assoc" horiz_concat_dw_assoc

117 liftIO $ putStrLn $ replicate 80 '-'

118− verify "single row vert concats to correct height" vert_contat_single_row

118+ _ <- verify "single row vert concats to correct height" vert_contat_single_row

119− verify "disjoint_height_horiz_join" disjoint_height_horiz_join

119+ _ <- verify "disjoint_height_horiz_join" disjoint_height_horiz_join

120− verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill

120+ _ <- verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill

121− verify "disjoint_width_vert_join" disjoint_width_vert_join

121+ _ <- verify "disjoint_width_vert_join" disjoint_width_vert_join

122− verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill

122+ _ <- verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill

123 return ()

124

test/verify_image_trans.hs+5−5

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

2module Main where

3

4import Verify.Graphics.Vty.Image

5−import Graphics.Vty.Debug

6

5

7import Verify

6import Verify

8

7

@@ -18,14 +17,15 @@ verify_horiz_contat_wo_attr_change_simplifies (SingleRowSingleAttrImage _attr ch

18 is_horiz_text_of_columns image char_count

17 is_horiz_text_of_columns image char_count

19

18

20verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool

19verify_horiz_contat_w_attr_change_simplifies :: SingleRowTwoAttrImage -> Bool

21−verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 image0)

20+verify_horiz_contat_w_attr_change_simplifies ( SingleRowTwoAttrImage (SingleRowSingleAttrImage attr0 char_count0 _image0)

22− (SingleRowSingleAttrImage attr1 char_count1 image1)

21+ (SingleRowSingleAttrImage attr1 char_count1 _image1)

23 i

22 i

24 )

23 )

25 | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1)

24 | char_count0 == 0 || char_count1 == 0 || attr0 == attr1 = is_horiz_text_of_columns i (char_count0 + char_count1)

26 | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1)

25 | otherwise = False == is_horiz_text_of_columns i (char_count0 + char_count1)

27

26

27+main :: IO ()

28main = run_test $ do

29− verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies

29+ _ <- verify "verify_horiz_contat_wo_attr_change_simplifies" verify_horiz_contat_wo_attr_change_simplifies

30− verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies

30+ _ <- verify "verify_horiz_contat_w_attr_change_simplifies" verify_horiz_contat_w_attr_change_simplifies

31 return ()