@@ -22,11 +22,10 @@ import Control.Monad.State.Strict hiding ( state )
2222import Control.Monad.ST.Strict hiding ( unsafeIOToST )
2323
2424import qualified Data.Vector as Vector hiding ( take, replicate )
25+import Data.Monoid (mappend)
2526import Data.Vector.Mutable ( MVector(..))
2627import qualified Data.Vector.Mutable as MVector
2728
28−import qualified Data.Text as T
29−import qualified Data.Text.Encoding as T
3029import qualified Data.Text.Lazy as TL
3130
3231type MRowOps s = MVector s SpanOps
@@ -36,6 +35,9 @@ type MSpanOps s = MVector s SpanOp
3635-- transform plus clip. More or less.
3736data BlitState = BlitState
3837 -- 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.
3941 { _column_offset :: Int
4042 , _row_offset :: Int
4143 -- 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
8587 case layer_ops of
8688 [] -> fail "empty picture"
8789 [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
8995
9096substitute_skips :: Background -> MRowOps s -> ST s (MRowOps s)
9197substitute_skips ClearBackground ops = do
@@ -120,22 +126,53 @@ substitute_skips (Background {background_char, background_attr}) ops = do
120126 MVector.write ops row row_ops'
121127 return ops
122128
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+
123160swap_skips_for_single_column_char_span :: Char -> Attr -> SpanOps -> SpanOps
124161swap_skips_for_single_column_char_span c a = Vector.map f
125− where f (Skip ow) = let txt = T.pack $ replicate ow c
126− in TextSpan a ow ow (T.encodeUtf8 txt)
162+ where f (Skip ow) = let txt = TL.pack $ replicate ow c
163+ in TextSpan a ow ow txt
127164 f v = v
128165
129166swap_skips_for_char_span :: Int -> Char -> Attr -> SpanOps -> SpanOps
130167swap_skips_for_char_span w c a = Vector.map f
131168 where
132169 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
134171 txt_1_cw = ow `mod` w
135− txt_1 = T.pack $ replicate txt_1_cw '…'
172+ txt_1 = TL.pack $ replicate txt_1_cw '…'
136173 cw = txt_0_cw + txt_1_cw
137− txt = txt_0 `T.append` txt_1
138− in TextSpan a ow cw $ T.encodeUtf8 txt
174+ txt = txt_0 `TL.append` txt_1
175+ in TextSpan a ow cw txt
139176 f v = v
140177
141178-- | 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
279316 add_maybe_clipped i1
280317 _ -> fail $ name ++ " has unhandled skip class"
281318
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−
302319add_unclipped_text :: Attr -> DisplayText -> BlitM s ()
303320add_unclipped_text a txt = do
304321 let op = TextSpan a used_display_columns
305322 (fromIntegral $ TL.length txt)
306− (T.encodeUtf8 $ TL.toStrict txt)
323+ txt
307324 used_display_columns = wcswidth $ TL.unpack txt
308325 use row_offset >>= snoc_op op
309326