44ae286 · vty · git.iko.soy

git.iko.soy/vty

on master help sign in

move the textspan op to use TL.Text value. Easier to split.

44ae286Corey O'Connor13 years ago

src/Graphics/Vty/Image/Internal.hs+21

compare with master

unifiedsplit

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

2module Graphics.Vty.Image.Internal where

4import Graphics.Vty.Attributes

5+import Graphics.Text.Width

6import Control.DeepSeq

7import Control.DeepSeq

@@ -14,6 +15,26 @@ import qualified Data.Text.Lazy as TL

14-- input text type?

15-- input text type?

15type DisplayText = TL.Text

16type DisplayText = TL.Text

18+-- TODO: store a skip list in HorizText(?)

19+-- TODO: represent display strings containing chars that are not 1 column chars as a separate

20+-- display string value?

21+clip_text :: DisplayText -> Int -> Int -> DisplayText

22+clip_text txt left_skip right_clip =

23+ -- CPS would clarify this I think

24+ let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0

25+ txt' = if pad_prefix then TL.cons '…' (TL.drop (to_drop+1) txt) else TL.drop to_drop txt

26+ (to_take,pad_suffix) = clip_for_char_width right_clip txt' 0

27+ txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty)

28+ clip_for_char_width 0 _ n = (n, False)

29+ clip_for_char_width w t n

30+ | TL.null t = (n, False)

31+ | w < cw = (n, True)

32+ | w == cw = (n+1, False)

33+ | w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)

34+ where cw = safe_wcwidth (TL.head t)

35+ clip_for_char_width _ _ _ = error "clip_for_char_width applied to undefined"

36+ in txt''

37+

17-- | An image in VTY is

38-- | An image in VTY is

18--

39--

19-- * a horizontal line of characters with a single attribute.

40-- * a horizontal line of characters with a single attribute.

src/Graphics/Vty/PictureToSpans.hs+47−30

@@ -22,11 +22,10 @@ import Control.Monad.State.Strict hiding ( state )

22import Control.Monad.ST.Strict hiding ( unsafeIOToST )

24import qualified Data.Vector as Vector hiding ( take, replicate )

25+import Data.Monoid (mappend)

25import Data.Vector.Mutable ( MVector(..))

26import Data.Vector.Mutable ( MVector(..))

26import qualified Data.Vector.Mutable as MVector

27import qualified Data.Vector.Mutable as MVector

28−import qualified Data.Text as T

29−import qualified Data.Text.Encoding as T

30import qualified Data.Text.Lazy as TL

29import qualified Data.Text.Lazy as TL

32type MRowOps s = MVector s SpanOps

31type MRowOps s = MVector s SpanOps

@@ -36,6 +35,9 @@ type MSpanOps s = MVector s SpanOp

36-- transform plus clip. More or less.

35-- transform plus clip. More or less.

37data BlitState = BlitState

36data BlitState = BlitState

38 -- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset

37 -- we always snoc to the operation vectors. Thus the column_offset = length of row at row_offset

38+ -- although, one possibility is to merge layers right in snoc_op (naming it something else, of

39+ -- course). In which case columnn_offset would be applicable.

40+ -- Right now we need it to exist.

39 { _column_offset :: Int

41 { _column_offset :: Int

40 , _row_offset :: Int

42 , _row_offset :: Int

41 -- clip coordinate space is in image space. Which means it's >= 0 and < image_width.

43 -- clip coordinate space is in image space. Which means it's >= 0 and < image_width.

@@ -85,7 +87,11 @@ combined_ops_for_layers pic r

85 case layer_ops of

87 case layer_ops of

86 [] -> fail "empty picture"

88 [] -> fail "empty picture"

87 [ops] -> substitute_skips (pic_background pic) ops

89 [ops] -> substitute_skips (pic_background pic) ops

88− _ -> fail "TODO: picture with more than one layer not supported"

90+ -- instead of merging ops after generation the merging can be performed as part of

91+ -- snoc_op.

92+ top_ops : lower_ops -> do

93+ ops <- foldM merge_under top_ops lower_ops

94+ substitute_skips (pic_background pic) ops

90substitute_skips :: Background -> MRowOps s -> ST s (MRowOps s)

96substitute_skips :: Background -> MRowOps s -> ST s (MRowOps s)

91substitute_skips ClearBackground ops = do

97substitute_skips ClearBackground ops = do

@@ -120,22 +126,53 @@ substitute_skips (Background {background_char, background_attr}) ops = do

120 MVector.write ops row row_ops'

126 MVector.write ops row row_ops'

121 return ops

127 return ops

122

128

129+merge_under :: MRowOps s -> MRowOps s -> ST s (MRowOps s)

130+merge_under upper lower = do

131+ forM_ [0 .. MVector.length upper - 1] $ \row -> do

132+ upper_row_ops <- MVector.read upper row

133+ lower_row_ops <- MVector.read lower row

134+ let row_ops = merge_row_under upper_row_ops lower_row_ops

135+ MVector.write upper row row_ops

136+ return upper

137+

138+-- fugly

139+merge_row_under :: SpanOps -> SpanOps -> SpanOps

140+merge_row_under upper_row_ops lower_row_ops =

141+ on_upper_op Vector.empty (Vector.head upper_row_ops) (Vector.tail upper_row_ops) lower_row_ops

142+ where

143+ -- H: it will never be the case that we are out of upper ops before lower ops.

144+ on_upper_op :: SpanOps -> SpanOp -> SpanOps -> SpanOps -> SpanOps

145+ on_upper_op out_ops op@(TextSpan _ w _ _) upper_ops lower_ops =

146+ let lower_ops' = drop_ops w lower_ops

147+ out_ops' = Vector.snoc out_ops op

148+ in if Vector.null lower_ops'

149+ then out_ops'

150+ else on_upper_op out_ops' (Vector.head upper_ops) (Vector.tail upper_ops) lower_ops'

151+ on_upper_op out_ops (Skip w) upper_ops lower_ops =

152+ let (ops', lower_ops') = split_ops_at w lower_ops

153+ out_ops' = out_ops `mappend` ops'

154+ in if Vector.null lower_ops'

155+ then out_ops'

156+ else on_upper_op out_ops' (Vector.head upper_ops) (Vector.tail upper_ops) lower_ops'

157+ on_upper_op _ (RowEnd _) _ _ = error "cannot merge rows containing RowEnd ops"

158+

159+

123swap_skips_for_single_column_char_span :: Char -> Attr -> SpanOps -> SpanOps

160swap_skips_for_single_column_char_span :: Char -> Attr -> SpanOps -> SpanOps

124swap_skips_for_single_column_char_span c a = Vector.map f

161swap_skips_for_single_column_char_span c a = Vector.map f

125− where f (Skip ow) = let txt = T.pack $ replicate ow c

162+ where f (Skip ow) = let txt = TL.pack $ replicate ow c

126− in TextSpan a ow ow (T.encodeUtf8 txt)

163+ in TextSpan a ow ow txt

127 f v = v

164 f v = v

128

165

129swap_skips_for_char_span :: Int -> Char -> Attr -> SpanOps -> SpanOps

166swap_skips_for_char_span :: Int -> Char -> Attr -> SpanOps -> SpanOps

130swap_skips_for_char_span w c a = Vector.map f

167swap_skips_for_char_span w c a = Vector.map f

131 where

168 where

132 f (Skip ow) = let txt_0_cw = ow `div` w

169 f (Skip ow) = let txt_0_cw = ow `div` w

133− txt_0 = T.pack $ replicate txt_0_cw c

170+ txt_0 = TL.pack $ replicate txt_0_cw c

134 txt_1_cw = ow `mod` w

171 txt_1_cw = ow `mod` w

135− txt_1 = T.pack $ replicate txt_1_cw '…'

172+ txt_1 = TL.pack $ replicate txt_1_cw '…'

136 cw = txt_0_cw + txt_1_cw

173 cw = txt_0_cw + txt_1_cw

137− txt = txt_0 `T.append` txt_1

174+ txt = txt_0 `TL.append` txt_1

138− in TextSpan a ow cw $ T.encodeUtf8 txt

175+ in TextSpan a ow cw txt

139 f v = v

176 f v = v

140

177

141-- | Builds a vector of row operations that will output the given picture to the terminal.

178-- | Builds a vector of row operations that will output the given picture to the terminal.

@@ -279,31 +316,11 @@ add_maybe_clipped_join name skip remaining offset i0_dim i0 i1 size = do

279 add_maybe_clipped i1

316 add_maybe_clipped i1

280 _ -> fail $ name ++ " has unhandled skip class"

317 _ -> fail $ name ++ " has unhandled skip class"

281

318

282−-- TODO: store a skip list in HorizText(?)

283−-- TODO: represent display strings containing chars that are not 1 column chars as a separate

284−-- display string value?

285−clip_text :: DisplayText -> Int -> Int -> DisplayText

286−clip_text txt left_skip right_clip =

287− -- CPS would clarify this I think

288− let (to_drop,pad_prefix) = clip_for_char_width left_skip txt 0

289− txt' = if pad_prefix then TL.cons '…' (TL.drop (to_drop+1) txt) else TL.drop to_drop txt

290− (to_take,pad_suffix) = clip_for_char_width right_clip txt' 0

291− txt'' = TL.append (TL.take to_take txt') (if pad_suffix then TL.singleton '…' else TL.empty)

292− clip_for_char_width 0 _ n = (n, False)

293− clip_for_char_width w t n

294− | TL.null t = (n, False)

295− | w < cw = (n, True)

296− | w == cw = (n+1, False)

297− | w > cw = clip_for_char_width (w - cw) (TL.tail t) (n + 1)

298− where cw = safe_wcwidth (TL.head t)

299− clip_for_char_width _ _ _ = error "clip_for_char_width applied to undefined"

300− in txt''

301−

302add_unclipped_text :: Attr -> DisplayText -> BlitM s ()

319add_unclipped_text :: Attr -> DisplayText -> BlitM s ()

303add_unclipped_text a txt = do

320add_unclipped_text a txt = do

304 let op = TextSpan a used_display_columns

321 let op = TextSpan a used_display_columns

305 (fromIntegral $ TL.length txt)

322 (fromIntegral $ TL.length txt)

306− (T.encodeUtf8 $ TL.toStrict txt)

323+ txt

307 used_display_columns = wcswidth $ TL.unpack txt

324 used_display_columns = wcswidth $ TL.unpack txt

308 use row_offset >>= snoc_op op

325 use row_offset >>= snoc_op op

309

326

src/Graphics/Vty/Span.hs+27−6

@@ -23,17 +23,20 @@ import Graphics.Vty.Image

23import Data.Vector (Vector)

24import qualified Data.Vector as Vector

26−import qualified Data.ByteString as BS

26+import qualified Data.Text.Lazy as TL

27−import qualified Data.Text as T

28−import qualified Data.Text.Encoding as T

30-- | This represents an operation on the terminal. Either an attribute change or the output of a

28-- | This represents an operation on the terminal. Either an attribute change or the output of a

31-- text string.

29-- text string.

32data SpanOp =

30data SpanOp =

33 -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF

31 -- | a span of UTF-8 text occupies a specific number of screen space columns. A single UTF

34 -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width

32 -- character does not necessarially represent 1 colunm. See Codec.Binary.UTF8.Width

35− -- TextSpan [output width in columns] [number of characters] [data]

33+ -- TextSpan [Attr] [output width in columns] [number of characters] [data]

36− TextSpan !Attr !Int !Int BS.ByteString

34+ TextSpan

35+ { text_span_attr :: !Attr

36+ , text_span_output_width :: !Int

37+ , text_span_char_width :: !Int

38+ , text_span_data :: DisplayText

39+ }

37 -- | Skips the given number of columns

40 -- | Skips the given number of columns

38 -- A skip is transparent.... maybe? I am not sure how attribute changes interact.

41 -- A skip is transparent.... maybe? I am not sure how attribute changes interact.

39 -- todo: separate from this type.

42 -- todo: separate from this type.

@@ -51,6 +54,24 @@ data SpanOp =

51-- color is changed.

54-- color is changed.

52type SpanOps = Vector SpanOp

55type SpanOps = Vector SpanOp

57+drop_ops :: Int -> SpanOps -> SpanOps

58+drop_ops w = snd . split_ops_at w

59+

60+split_ops_at :: Int -> SpanOps -> (SpanOps, SpanOps)

61+split_ops_at in_w in_ops = split_ops_at' in_w in_ops

62+ where

63+ split_ops_at' 0 ops = (Vector.empty, ops)

64+ split_ops_at' remaining_columns ops = case Vector.head ops of

65+ t@(TextSpan {}) -> undefined

66+ Skip w -> if remaining_columns >= w

67+ then let (pre,post) = split_ops_at' (remaining_columns - w) (Vector.tail ops)

68+ in (Vector.cons (Skip w) pre, post)

69+ else ( Vector.singleton $ Skip remaining_columns

70+ , Vector.cons (Skip (w - remaining_columns)) (Vector.tail ops)

71+ )

72+ RowEnd _ -> error "cannot split ops containing a row end"

73+

74+

54-- | vector of span operation vectors for display. One per row of the output region.

75-- | vector of span operation vectors for display. One per row of the output region.

55type DisplayOps = Vector SpanOps

76type DisplayOps = Vector SpanOps

@@ -91,7 +112,7 @@ span_op_has_width (RowEnd ow) = Just (ow,ow)

91-- | returns the number of columns to the character at the given position in the span op

112-- | returns the number of columns to the character at the given position in the span op

92columns_to_char_offset :: Int -> SpanOp -> Int

113columns_to_char_offset :: Int -> SpanOp -> Int

93columns_to_char_offset cx (TextSpan _ _ _ utf8_str) =

114columns_to_char_offset cx (TextSpan _ _ _ utf8_str) =

94− let str = T.unpack (T.decodeUtf8 utf8_str)

115+ let str = TL.unpack utf8_str

95 in wcswidth (take cx str)

116 in wcswidth (take cx str)

96columns_to_char_offset cx (Skip _) = cx

117columns_to_char_offset cx (Skip _) = cx

97columns_to_char_offset cx (RowEnd _) = cx

118columns_to_char_offset cx (RowEnd _) = cx

src/Graphics/Vty/Terminal/Interface.hs+4−2

@@ -23,6 +23,8 @@ import Graphics.Vty.DisplayAttributes

23import Control.Monad.Trans

25import qualified Data.ByteString.Internal as BS

26+import qualified Data.Text.Encoding as T

27+import qualified Data.Text.Lazy as TL

26import Data.IORef

28import Data.IORef

27import qualified Data.Vector as Vector

29import qualified Data.Vector as Vector

@@ -215,7 +217,7 @@ span_op_required_bytes dc fattr (TextSpan attr _ _ str) =

215 diffs = display_attr_diffs fattr fattr'

217 diffs = display_attr_diffs fattr fattr'

216 c = attr_required_bytes dc fattr attr' diffs

218 c = attr_required_bytes dc fattr attr' diffs

217 fattr' = fix_display_attr fattr attr'

219 fattr' = fix_display_attr fattr attr'

218− in (c + utf8_text_required_bytes str, fattr')

220+ in (c + utf8_text_required_bytes (T.encodeUtf8 $ TL.toStrict str), fattr')

219span_op_required_bytes _dc _fattr (Skip _) = error "span_op_required_bytes for Skip."

221span_op_required_bytes _dc _fattr (Skip _) = error "span_op_required_bytes for Skip."

220span_op_required_bytes dc fattr (RowEnd _) = (row_end_required_bytes dc, fattr)

222span_op_required_bytes dc fattr (RowEnd _) = (row_end_required_bytes dc, fattr)

221

223

@@ -265,7 +267,7 @@ serialize_span_op dc (TextSpan attr _ _ str) out_ptr fattr = do

265 fattr' = fix_display_attr fattr attr'

267 fattr' = fix_display_attr fattr attr'

266 diffs = display_attr_diffs fattr fattr'

268 diffs = display_attr_diffs fattr fattr'

267 out_ptr' <- serialize_set_attr dc fattr attr' diffs out_ptr

269 out_ptr' <- serialize_set_attr dc fattr attr' diffs out_ptr

268− out_ptr'' <- serialize_utf8_text str out_ptr'

270+ out_ptr'' <- serialize_utf8_text (T.encodeUtf8 $ TL.toStrict str) out_ptr'

269 return (out_ptr'', fattr')

271 return (out_ptr'', fattr')

270serialize_span_op _dc (Skip _) _out_ptr _fattr = error "serialize_span_op for Skip"

272serialize_span_op _dc (Skip _) _out_ptr _fattr = error "serialize_span_op for Skip"

271serialize_span_op dc (RowEnd _) out_ptr fattr = do

273serialize_span_op dc (RowEnd _) out_ptr fattr = do