9748c1d · vty · git.iko.soy

git.iko.soy/vty

more tests of cropping operations. simplify the terminal interface a bit

commit9748c1d6598d7316c4a53bac9962ee04fcbd9006 authorCorey O'Connor <coreyoconnor@gmail.com> dateMon 29 Jul 2013, 09:44 (13 years ago) parentc3c652d

8 files changed+96−38

compare with master

unifiedsplit

src/Graphics/Vty/Image.hs−2 src/Graphics/Vty/Terminal/Interface.hs+7−5 src/Graphics/Vty/Terminal/MacOSX.hs−3 src/Graphics/Vty/Terminal/Mock.hs+3−3 src/Graphics/Vty/Terminal/TerminfoBased.hs+8−8 src/Graphics/Vty/Terminal/XTermColor.hs+3−3 test/Verify/Graphics/Vty/Image.hs+39−14 test/VerifyImageOps.hs+36

src/Graphics/Vty/Image.hs−2

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

213213

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

215215-- number of rows high.

216−--

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

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

219217char_fill _a _c 0 _h = EmptyImage

220218char_fill _a _c _w 0 = EmptyImage

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

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

2020

2121import Graphics.Vty.DisplayAttributes

2222

23−import Control.Monad.Fix

2423import Control.Monad.Trans

2524

2625import qualified Data.ByteString.Internal as BS

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

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

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

6160 -- (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

6362 }

6463

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

65+display_context t = liftIO . mk_display_context t t

66+

6567data AssumedState = AssumedState

6668 { prev_fattr :: Maybe FixedAttr

6769 , prev_output_ops :: Maybe DisplayOps

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

7173initial_assumed_state = AssumedState Nothing Nothing

7274

7375data DisplayContext = DisplayContext

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

75− context_region :: DisplayRegion

76− , context_device :: Terminal

76+ { context_device :: Terminal

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

78+ , context_region :: DisplayRegion

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

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

7981 , move_cursor_required_bytes :: Int -> Int -> Int

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

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

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

3939 , reserve_display = terminal_app_reserve_display flushed_put

4040 , 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' }

4441 }

4542 return t'

4643

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

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

5252 , context_color_count = 16

5353 , supports_cursor_visibility = True

5454 , assumed_state_ref = new_assumed_state_ref

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

56− { context_region = r_

57− , context_device = t

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

56+ { context_region = r_actual

57+ , context_device = t_actual

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

5959 , move_cursor_required_bytes = \_x _y -> 1

6060 , serialize_move_cursor = \_x _y ptr -> do

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

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

2222

2323import Control.Applicative

2424import Control.Monad ( foldM, when )

25−import Control.Monad.Fix (mfix)

2625import Control.Monad.Trans

2726

2827import Data.Bits ( (.&.) )

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

144143 True -> 1

145144 , supports_cursor_visibility = isJust $ civis terminfo_caps

146145 , assumed_state_ref = new_assumed_state_ref

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

148− , display_context = liftIO . terminfo_display_context terminfo_caps t

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

147+ -- tho.

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

149149 }

150150 send_cap s = send_cap_to_terminal t (s terminfo_caps)

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

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

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

192192 return (fromIntegral b, fromIntegral a)

193193

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

195−terminfo_display_context terminfo_caps t r = do

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

195+terminfo_display_context t_actual terminfo_caps r =

196196 let dc = DisplayContext

197− { context_region = r

198− , context_device = t

197+ { context_device = t_actual

198+ , context_region = r

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

200200 [toEnum y, toEnum x]

201201 , 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

223223 , serialize_row_end = serialize_cap_expression (clear_eol terminfo_caps) []

224224 , inline_hack = return ()

225225 }

226− return dc

226+ in return dc

227227

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

229229-- 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

3434 , release_terminal = do

3535 liftIO $ flushed_put set_default_char_set

3636 release_terminal t

37− , display_context = \r -> do

38− dc <- display_context t r

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

37+ , mk_display_context = \t_actual r -> do

38+ dc <- mk_display_context t_actual t_actual r

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

4040 }

4141 return t'

4242

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

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

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

4747

4848instance Arbitrary WidthResize where

49− arbitrary = oneof

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

51− , do

52− WidthResize f <- arbitrary

53− out_width <- choose (1, 256)

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

55− ]

49+ arbitrary = do

50+ WidthResize f <- arbitrary

51+ w <- choose (1,1024)

52+ oneof $ map (return . WidthResize)

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

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)

57+ ]

5658

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

5860

5961instance Arbitrary HeightResize where

60− arbitrary = oneof

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

62− , do

63− HeightResize f <- arbitrary

64− out_height <- choose (1, 256)

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

66− ]

62+ arbitrary = do

63+ HeightResize f <- arbitrary

64+ h <- choose (1,1024)

65+ oneof $ map (return . HeightResize)

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

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)

70+ ]

6771

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

6973

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

162166 return $! fst $! f i

163167 ]

164168

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) =

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

106106 _ -> True

107107

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+

108138tests :: IO [Test]

109139tests = return

110140 [ verify "two_sw_horiz_concat" two_sw_horiz_concat

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

120150 , verify "disjoint_height_horiz_join BG fill" disjoint_height_horiz_join_bg_fill

121151 , verify "disjoint_width_vert_join" disjoint_width_vert_join

122152 , 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

123159 ]

124160