9748c1d · vty · git.iko.soy

src/Graphics/Vty/Image.hs−2

compare with master

unifiedsplit

@@ -213,8 +213,6 @@ utf8_strict_bytestring a bs = strict_text a (T.decodeUtf8 bs)

213

214-- | creates a fill of the specified character. The dimensions are in number of characters wide and

215-- number of rows high.

216−--

217−-- Unlike the Background fill character this character can have double column display width.

218char_fill :: Integral d => Attr -> Char -> d -> d -> Image

216char_fill :: Integral d => Attr -> Char -> d -> d -> Image

219char_fill _a _c 0 _h = EmptyImage

217char_fill _a _c 0 _h = EmptyImage

220char_fill _a _c _w 0 = EmptyImage

218char_fill _a _c _w 0 = EmptyImage

src/Graphics/Vty/Terminal/Interface.hs+7−5

@@ -20,7 +20,6 @@ import Graphics.Vty.DisplayRegion

20

21import Graphics.Vty.DisplayAttributes

22

23−import Control.Monad.Fix

24import Control.Monad.Trans

23import Control.Monad.Trans

25

24

26import qualified Data.ByteString.Internal as BS

25import qualified Data.ByteString.Internal as BS

@@ -59,9 +58,12 @@ data Terminal = Terminal

59 -- | Acquire display access to the given region of the display.

58 -- | Acquire display access to the given region of the display.

60 -- Currently all regions have the upper left corner of (0,0) and the lower right corner at

59 -- Currently all regions have the upper left corner of (0,0) and the lower right corner at

61 -- (max display_width provided_width, max display_height provided_height)

60 -- (max display_width provided_width, max display_height provided_height)

62− , display_context :: MonadIO m => DisplayRegion -> m DisplayContext

61+ , mk_display_context :: MonadIO m => Terminal -> DisplayRegion -> m DisplayContext

63 }

62 }

64

63

64+display_context :: MonadIO m => Terminal -> DisplayRegion -> m DisplayContext

65+display_context t = liftIO . mk_display_context t t

66+

65data AssumedState = AssumedState

67data AssumedState = AssumedState

66 { prev_fattr :: Maybe FixedAttr

68 { prev_fattr :: Maybe FixedAttr

67 , prev_output_ops :: Maybe DisplayOps

69 , prev_output_ops :: Maybe DisplayOps

@@ -71,9 +73,9 @@ initial_assumed_state :: AssumedState

71initial_assumed_state = AssumedState Nothing Nothing

73initial_assumed_state = AssumedState Nothing Nothing

72

74

73data DisplayContext = DisplayContext

75data DisplayContext = DisplayContext

76+ { context_device :: Terminal

74− { -- | Provide the bounds of the display context.

77+ -- | Provide the bounds of the display context.

75− context_region :: DisplayRegion

78+ , context_region :: DisplayRegion

76− , context_device :: Terminal

77 -- | sets the output position to the specified row and column. Where the number of bytes

79 -- | sets the output position to the specified row and column. Where the number of bytes

78 -- required for the control codes can be specified seperate from the actual byte sequence.

80 -- required for the control codes can be specified seperate from the actual byte sequence.

79 , move_cursor_required_bytes :: Int -> Int -> Int

81 , move_cursor_required_bytes :: Int -> Int -> Int

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

@@ -38,9 +38,6 @@ reserve_terminal v out_handle = do

38 { terminal_ID = terminal_ID t ++ " (Mac)"

39 , reserve_display = terminal_app_reserve_display flushed_put

40 , release_display = terminal_app_release_display flushed_put

41− , display_context = \r -> do

42− dc <- display_context t r

43− return $ dc { context_device = t' }

44 }

41 }

45 return t'

42 return t'

46

43

src/Graphics/Vty/Terminal/Mock.hs+3−3

@@ -52,9 +52,9 @@ mock_terminal r = liftIO $ do

52 , context_color_count = 16

53 , supports_cursor_visibility = True

54 , assumed_state_ref = new_assumed_state_ref

55− , display_context = \r_ -> return $ DisplayContext

55+ , mk_display_context = \t_actual r_actual -> return $ DisplayContext

56− { context_region = r_

56+ { context_region = r_actual

57− , context_device = t

57+ , context_device = t_actual

58 -- A cursor move is always visualized as the single character 'M'

59 , move_cursor_required_bytes = \_x _y -> 1

60 , serialize_move_cursor = \_x _y ptr -> do

src/Graphics/Vty/Terminal/TerminfoBased.hs+8−8

@@ -22,7 +22,6 @@ import Graphics.Vty.DisplayRegion

22

23import Control.Applicative

24import Control.Monad ( foldM, when )

25−import Control.Monad.Fix (mfix)

26import Control.Monad.Trans

25import Control.Monad.Trans

27

26

28import Data.Bits ( (.&.) )

27import Data.Bits ( (.&.) )

@@ -144,8 +143,9 @@ reserve_terminal in_ID out_handle = liftIO $ do

144 True -> 1

143 True -> 1

145 , supports_cursor_visibility = isJust $ civis terminfo_caps

144 , supports_cursor_visibility = isJust $ civis terminfo_caps

146 , assumed_state_ref = new_assumed_state_ref

145 , assumed_state_ref = new_assumed_state_ref

147− -- would be better to use fix, but I'm having issues avoiding <<loop>>

146+ -- I think fix would help assure t_actual is the only reference. I was having issues

147+ -- tho.

148− , display_context = liftIO . terminfo_display_context terminfo_caps t

148+ , mk_display_context = \t_actual -> liftIO . terminfo_display_context t_actual terminfo_caps

149 }

150 send_cap s = send_cap_to_terminal t (s terminfo_caps)

151 maybe_send_cap s = when (isJust $ s terminfo_caps) . send_cap (fromJust . s)

@@ -191,11 +191,11 @@ get_window_size = do

191 (a,b) <- (`divMod` 65536) `fmap` c_get_window_size

192 return (fromIntegral b, fromIntegral a)

193

194−terminfo_display_context :: TerminfoCaps -> Terminal -> DisplayRegion -> IO DisplayContext

194+terminfo_display_context :: Terminal -> TerminfoCaps -> DisplayRegion -> IO DisplayContext

195−terminfo_display_context terminfo_caps t r = do

195+terminfo_display_context t_actual terminfo_caps r =

196 let dc = DisplayContext

197+ { context_device = t_actual

197− { context_region = r

198+ , context_region = r

198− , context_device = t

199 , move_cursor_required_bytes = \x y -> cap_expression_required_bytes (cup terminfo_caps)

200 [toEnum y, toEnum x]

201 , serialize_move_cursor = \x y out_ptr -> serialize_cap_expression (cup terminfo_caps)

@@ -223,7 +223,7 @@ terminfo_display_context terminfo_caps t r = do

223 , serialize_row_end = serialize_cap_expression (clear_eol terminfo_caps) []

224 , inline_hack = return ()

225 }

226− return dc

226+ in return dc

227

228-- | Instead of evaluating all the rules related to setting display attributes twice (once in

229-- required bytes and again in serialize) or some memoization scheme just return a size

src/Graphics/Vty/Terminal/XTermColor.hs+3−3

@@ -34,9 +34,9 @@ reserve_terminal variant out_handle = liftIO $ do

34 , release_terminal = do

35 liftIO $ flushed_put set_default_char_set

36 release_terminal t

37− , display_context = \r -> do

37+ , mk_display_context = \t_actual r -> do

38− dc <- display_context t r

38+ dc <- mk_display_context t_actual t_actual r

39− return $ dc { context_device = t', inline_hack = xterm_inline_hack t }

39+ return $ dc { inline_hack = xterm_inline_hack t' }

40 }

41 return t'

42

test/Verify/Graphics/Vty/Image.hs+39−14

@@ -46,24 +46,28 @@ instance Show SingleRowSingleAttrImage where

46newtype WidthResize = WidthResize (Image -> (Image, Int))

47

48instance Arbitrary WidthResize where

49− arbitrary = oneof

49+ arbitrary = do

50− [ return $ WidthResize $ \i -> (i, image_width i)

51− , do

52− WidthResize f <- arbitrary

50+ WidthResize f <- arbitrary

53− out_width <- choose (1, 256)

51+ w <- choose (1,1024)

52+ oneof $ map (return . WidthResize)

53+ [ \i -> (i, image_width i)

54− return $ WidthResize $ \i -> (resize_width out_width $ fst $ f i, out_width)

54+ , \i -> (resize_width w $ fst $ f i, w)

55+ , \i -> let i' = fst $ f i in (crop_left w i', min (image_width i') w)

56+ , \i -> let i' = fst $ f i in (crop_right w i', min (image_width i') w)

55− ]

57+ ]

56

58

57newtype HeightResize = HeightResize (Image -> (Image, Int))

59newtype HeightResize = HeightResize (Image -> (Image, Int))

58

60

59instance Arbitrary HeightResize where

61instance Arbitrary HeightResize where

60− arbitrary = oneof

62+ arbitrary = do

61− [ return $ HeightResize $ \i -> (i, image_height i)

62− , do

63− HeightResize f <- arbitrary

63+ HeightResize f <- arbitrary

64− out_height <- choose (1, 256)

64+ h <- choose (1,1024)

65+ oneof $ map (return . HeightResize)

66+ [ \i -> (i, image_height i)

65− return $ HeightResize $ \i -> (resize_height out_height $ fst $ f i, out_height)

67+ , \i -> (resize_height h $ fst $ f i, h)

68+ , \i -> let i' = fst $ f i in (crop_top h i', min (image_height i') h)

69+ , \i -> let i' = fst $ f i in (crop_bottom h i', min (image_height i') h)

66− ]

70+ ]

67

71

68newtype ImageResize = ImageResize (Image -> (Image, (Int, Int)))

72newtype ImageResize = ImageResize (Image -> (Image, (Int, Int)))

69

73

@@ -162,3 +166,24 @@ instance Arbitrary Image where

162 return $! fst $! f i

166 return $! fst $! f i

163 ]

167 ]

164

168

169+data CropOperation

170+ = CropFromLeft

171+ | CropFromRight

172+ | CropFromTop

173+ | CropFromBottom

174+ deriving (Eq, Show)

175+

176+instance Arbitrary CropOperation where

177+ arbitrary = oneof $ map return [CropFromLeft, CropFromRight, CropFromTop, CropFromBottom]

178+

179+data Translation = Translation Image (Int, Int) Image

180+ deriving (Eq, Show)

181+

182+instance Arbitrary Translation where

183+ arbitrary = do

184+ i <- arbitrary

185+ x <- arbitrary `suchThat` (> 0)

186+ y <- arbitrary `suchThat` (> 0)

187+ let i' = translate x y i

188+ return $ Translation i (x,y) i'

189+

test/VerifyImageOps.hs+36

@@ -105,6 +105,36 @@ disjoint_width_vert_join_bg_fill (NonEmpty stack_0) (NonEmpty stack_1) =

105 ( expected_width == (image_width $ part_bottom image) )

106 _ -> True

107

108+translation_is_linear_on_out_size :: Translation -> Bool

109+translation_is_linear_on_out_size (Translation i (x,y) i') =

110+ image_width i' == image_width i + x && image_height i' == image_height i + y

111+

112+padding_is_linear_on_out_size :: Image -> Gen Bool

113+padding_is_linear_on_out_size i = do

114+ l <- offset

115+ t <- offset

116+ r <- offset

117+ b <- offset

118+ let i' = pad l t r b i

119+ return $ image_width i' == image_width i + l + r && image_height i' == image_height i + t + b

120+ where offset = choose (1,1024)

121+

122+crop_left_limits_width :: Image -> Int -> Property

123+crop_left_limits_width i v = v >= 0 ==>

124+ v >= image_width (crop_left v i)

125+

126+crop_right_limits_width :: Image -> Int -> Property

127+crop_right_limits_width i v = v >= 0 ==>

128+ v >= image_width (crop_right v i)

129+

130+crop_top_limits_height :: Image -> Int -> Property

131+crop_top_limits_height i v = v >= 0 ==>

132+ v >= image_height (crop_top v i)

133+

134+crop_bottom_limits_height :: Image -> Int -> Property

135+crop_bottom_limits_height i v = v >= 0 ==>

136+ v >= image_height (crop_bottom v i)

137+

108tests :: IO [Test]

138tests :: IO [Test]

109tests = return

139tests = return

110 [ verify "two_sw_horiz_concat" two_sw_horiz_concat

140 [ verify "two_sw_horiz_concat" two_sw_horiz_concat

@@ -120,5 +150,11 @@ tests = return

120 , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill

150 , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill

121 , verify "disjoint_width_vert_join" disjoint_width_vert_join

151 , verify "disjoint_width_vert_join" disjoint_width_vert_join

122 , verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill

152 , verify "disjoint_width_vert_join BG fill" disjoint_width_vert_join_bg_fill

153+ , verify "translation effects output dimensions linearly" translation_is_linear_on_out_size

154+ , verify "padding effects output dimensions linearly" padding_is_linear_on_out_size

155+ , verify "crop left limits width" crop_left_limits_width

156+ , verify "crop right limits width" crop_right_limits_width

157+ , verify "crop top limits height" crop_top_limits_height

158+ , verify "crop bottom limits height" crop_bottom_limits_height

123 ]

159 ]

124

160