src/Graphics/Vty/Span.hs · vty

git.iko.soy/vty

on ae06339 help sign in

vty/src/Graphics/Vty/Span.hs

221 lines 10 kB history raw

2{-# LANGUAGE BangPatterns #-}

3{-# LANGUAGE ExistentialQuantification #-}

4{-# LANGUAGE NamedFieldPuns #-}

5{-# LANGUAGE GADTs #-}

6{-# LANGUAGE ExistentialQuantification #-}

7{-# LANGUAGE ScopedTypeVariables #-}

8-- The ops to define the content for an output region.

9module Graphics.Vty.Span

10 where

12import Codec.Binary.UTF8.Width ( wcwidth )

14import Graphics.Vty.Image

15import Graphics.Vty.Picture

16import Graphics.Vty.DisplayRegion

18import Codec.Binary.UTF8.String ( encode )

20import Control.Monad ( forM_ )

21import Control.Monad.ST.Strict

23import Data.Array.ST

24import qualified Data.ByteString as B

25import qualified Data.ByteString.Internal as BInt

26import qualified Data.Foldable as Foldable

27import Data.Word

28import qualified Data.ByteString.UTF8 as BSUTF8

29import qualified Data.String.UTF8 as UTF8

31import Foreign.Storable ( pokeByteOff )

33import GHC.Arr

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

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

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

38 - nth row (from top to bottom) of the picture to render.

39 -

40 - A span op sequence will be defined for all rows and columns (and no more) of the region provided

41 - with the picture to spans_for_pic.

42 -

43 -

44 - todo: Partition attribute changes into multiple categories according to the serialized

45 - representation of the various attributes.

46 -}

47data SpanOpSequence = SpanOpSequence

48 { effected_region :: DisplayRegion

49 , row_ops :: RowOps

50 }

52type RowOps = Array Word SpanOps

53type SpanOps = [SpanOp]

55span_ops_columns :: SpanOpSequence -> Word

56span_ops_columns ops = region_width $ effected_region ops

58span_ops_rows :: SpanOpSequence -> Word

59span_ops_rows ops = region_height $ effected_region ops

61span_ops_effected_columns :: [SpanOp] -> Word

62span_ops_effected_columns in_ops = span_ops_effected_columns' 0 in_ops

63 where

64 span_ops_effected_columns' t [] = t

65 span_ops_effected_columns' t (TextSpan w _ _ : r) = span_ops_effected_columns' (t + w) r

66 span_ops_effected_columns' t (_ : r) = span_ops_effected_columns' t r

68-- |

69--

70-- todo: This type may need to be restructured to increase sharing in the bytestring

71--

72-- todo: Make foldable

73data SpanOp =

74 AttributeChange !Attr

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

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

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

78 | TextSpan !Word !Word (UTF8.UTF8 B.ByteString)

79 deriving Eq

81span_op_has_width :: SpanOp -> Maybe (Word, Word)

82span_op_has_width (TextSpan ow cw _) = Just (cw, ow)

83span_op_has_width _ = Nothing

85columns_to_char_offset :: Word -> SpanOp -> Word

86columns_to_char_offset cx (TextSpan _ _ utf8_str) =

87 let str = UTF8.toString utf8_str

88 in toEnum $ sum $ map wcwidth $ take (fromEnum cx) str

89columns_to_char_offset _cx _ = error "columns_to_char_offset applied to span op without width"

91-- | Produces the span ops that will render the given picture, possibly cropped or padded, into the

92-- specified region.

93spans_for_pic :: Picture -> DisplayRegion -> SpanOpSequence

94spans_for_pic pic r = SpanOpSequence r $ runSTArray (build_spans pic r)

96build_spans :: Picture -> DisplayRegion -> ST s (STArray s Word [SpanOp])

97build_spans pic region = do

98 -- m for mutable

99 mrow_ops <- newSTArray (0, region_height region - 1) []

100 -- I think this can be better optimized if the build produced span operations in display order.

101 -- However, I got stuck trying to implement an algorithm that did this. This will be considered

102 -- as a possible future optimization.

103 --

104 -- A depth first traversal of the image is performed.

105 -- ordered according to the column range defined by the image from least to greatest.

106 -- The output row ops will at least have the region of the image specified. Iterate over all

107 -- output rows and output background fills for all unspecified columns.

108 if region_height region > 0

109 then do

110 -- The ops builder recursively descends the image and outputs span ops that would

111 -- display that image. The number of columns remaining in this row before exceeding the

112 -- bounds is also provided. This is used to clip the span ops produced.

113 ops_for_row mrow_ops (pic_background pic) region (pic_image pic) 0 (region_width region)

114 -- Fill in any unspecified columns with the background pattern.

115 forM_ [0 .. region_height region - 1] $ \row -> do

116 end_x <- readSTArray mrow_ops row >>= return . span_ops_effected_columns

117 if end_x < region_width region

118 then snoc_bg_fill mrow_ops (pic_background pic) (region_width region - end_x) row

119 else return ()

120 else return ()

121 return mrow_ops

122

123type MRowOps s = STArray s Word SpanOps

124

125ops_for_row :: MRowOps s -> Background -> DisplayRegion -> Image -> Word -> Word -> ST s ()

126ops_for_row mrow_ops bg region image y remaining_columns

127 | remaining_columns == 0 = return ()

128 | y >= region_height region = return ()

129 | otherwise = case image of

130 EmptyImage -> return ()

131 -- The width provided is the number of columns this text span will occupy when displayed.

132 -- if this is greater than the number of remaining columsn the output has to be produced a

133 -- character at a time.

134 HorizText a text_str ow cw -> do

135 snoc_text_span a text_str ow cw mrow_ops y remaining_columns

136 VertJoin t b _ _ -> do

137 ops_for_row mrow_ops bg region t y remaining_columns

138 ops_for_row mrow_ops bg region b (y + image_height t) remaining_columns

139 HorizJoin l r _ _ -> do

140 ops_for_row mrow_ops bg region l y remaining_columns

141 -- Don't output the right part unless there is at least a single column left after

142 -- outputting the left part.

143 if image_width l < remaining_columns

144 then ops_for_row mrow_ops bg region r y (remaining_columns - image_width l)

145 else return ()

146 BGFill width height -> do

147 let actual_height = if y + height > region_height region

148 then region_height region - y

149 else height

150 actual_width = if width > remaining_columns

151 then remaining_columns

152 else width

153 forM_ [y .. y + actual_height - 1] $ \y' -> snoc_bg_fill mrow_ops bg actual_width y'

154 Translation _offset i -> ops_for_row mrow_ops bg region i y remaining_columns

155

156snoc_text_span :: (Foldable.Foldable t)

157 => Attr

158 -> t Char

159 -> Word -- width of text span in output display columns

160 -> Word -- width of text span in characters

161 -> MRowOps s

162 -> Word

163 -> Word

164 -> ST s ()

165snoc_text_span a text_str ow cw mrow_ops y remaining_columns = do

166 if ow > remaining_columns

167 then do

168 snoc_op mrow_ops y $ AttributeChange a

169 let (ow', cw', txt) = Foldable.foldl'

170 build_cropped_txt

171 ( 0, 0, B.empty )

172 text_str

173 snoc_op mrow_ops y $ TextSpan ow' cw' (UTF8.fromRep txt)

174 else do

175 snoc_op mrow_ops y $ AttributeChange a

176 let utf8_bs = ({-# SCC "BSUTF8.fromString" #-} BSUTF8.fromString) $ Foldable.foldMap (\c -> [c]) text_str

177 snoc_op mrow_ops y $ TextSpan ow cw (UTF8.fromRep utf8_bs)

178 where

179 build_cropped_txt (ow', char_count', b0) c = {-# SCC "build_cropped_txt" #-}

180 let w = wcwidth c

181 -- Characters with unknown widths occupy 1 column.

182 --

183 -- todo: Not sure if this is actually correct.

184 -- I presume there is a replacement character that is output by the terminal instead of

185 -- the character. If so then this replacement process may need to be implemented

186 -- manually for consistent behavior across terminals.

187 w' = toEnum $ if w < 0 then 1 else w

188 in if (w' + ow') > remaining_columns

189 then ( ow', char_count', b0 )

190 else ( ow' + w', char_count' + 1, B.append b0 $ B.pack $ encode [c] )

191

192snoc_bg_fill :: MRowOps s -> Background -> Word -> Word -> ST s ()

193snoc_bg_fill _row_ops _bg 0 _row

194 = return ()

195snoc_bg_fill mrow_ops (Background c back_attr) fill_length row

196 = do

197 snoc_op mrow_ops row $ AttributeChange back_attr

198 -- By all likelyhood the background character will be an ASCII character. Which is a single

199 -- byte in utf8. Optimize for this special case.

200 utf8_bs <- if c <= (toEnum 255 :: Char)

201 then

202 let !(c_byte :: Word8) = BInt.c2w c

203 in unsafeIOToST $ do

204 BInt.create ( fromEnum fill_length )

205 $ \ptr -> mapM_ (\i -> pokeByteOff ptr i c_byte)

206 [0 .. fromEnum (fill_length - 1)]

207 else

208 let !(c_bytes :: [Word8]) = encode [c]

209 in unsafeIOToST $ do

210 BInt.create (fromEnum fill_length * length c_bytes)

211 $ \ptr -> mapM_ (\(i,b) -> pokeByteOff ptr i b)

212 $ zip [0 .. fromEnum (fill_length - 1)] (cycle c_bytes)

213 snoc_op mrow_ops row $ TextSpan fill_length fill_length (UTF8.fromRep utf8_bs)

214

215snoc_op :: MRowOps s -> Word -> SpanOp -> ST s ()

216snoc_op !mrow_ops !row !op = do

217 ops <- readSTArray mrow_ops row

218 let ops' = ops ++ [op]

219 writeSTArray mrow_ops row ops'

220 return ()

221