@@ -9,26 +9,22 @@ Description: A zipper for text documents that allows convenient editing and navi
99-}
1010module Data.Text.Zipper where
1111
12−import Prelude
13−
14−import Control.Exception (assert)
15−import Control.Monad.State (evalState, forM, get, put)
1612import Data.Char (isSpace)
1713import Data.Map (Map)
14+import qualified Data.Map as Map
1815import Data.Maybe (fromMaybe)
1916import Data.String
17+import Control.Monad.State (evalState, forM, get, put)
18+
2019import Data.Text (Text)
20+import qualified Data.Text as T
2121import Data.Text.Internal (Text(..), text)
2222import Data.Text.Internal.Fusion (stream)
2323import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
2424import Data.Text.Unsafe
25−import qualified Data.List as L
26−import qualified Data.Map as Map
27−import qualified Data.Text as T
2825
2926import Graphics.Text.Width (wcwidth)
3027
31−
3228-- | A zipper of the logical text input contents (the "document"). The lines
3329-- before the line containing the cursor are stored in reverse order.
3430-- The cursor is logically between the "before" and "after" text.
@@ -170,7 +166,7 @@ deleteLeftWord (TextZipper lb b a la) =
170166-- | Insert up to n spaces to get to the next logical column that is a multiple of n
171167tab :: Int -> TextZipper -> TextZipper
172168tab n z@(TextZipper _ b _ _) =
173− insert (T.replicate (fromEnum $ n - T.length b `mod` max 1 n) " ") z
169+ insert (T.replicate (fromEnum $ n - (T.length b `mod` max 1 n)) " ") z
174170
175171-- | The plain text contents of the zipper
176172value :: TextZipper -> Text
@@ -193,35 +189,105 @@ fromText = flip insert empty
193189data Span tag = Span tag Text
194190 deriving (Show)
195191
196−-- | Text alignment type
197−data TextAlignment =
198− TextAlignment_Left
199− | TextAlignment_Right
200− | TextAlignment_Center
201− deriving (Eq, Show)
202−
203−-- A map from the index (row) of display line to (fst,snd)
204−-- fst: leading empty spaces from left (may be negative) to adjust for alignment
205−-- snd: the text offset from the beginning of the document
206−-- to the first character of the display line
207−type OffsetMapWithAlignment = Map Int (Int, Int)
208−
209−-- helper type representing a single visual line that may be part of a wrapped logical line
210−data WrappedLine = WrappedLine
211− { _wrappedLines_text :: Text
212− , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character
213− , _wrappedLines_offset :: Int -- ^ offset from beginning of line
214− }
215− deriving (Eq, Show)
216−
217192-- | Information about the document as it is displayed (i.e., post-wrapping)
218193data DisplayLines tag = DisplayLines
219194 { _displayLines_spans :: [[Span tag]]
220− , _displayLines_offsetMap :: OffsetMapWithAlignment
221− , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
195+ , _displayLines_offsetMap :: Map Int Int
196+ , _displayLines_cursorY :: Int
222197 }
223198 deriving (Show)
224199
200+-- | Given a width and a 'TextZipper', produce a list of display lines
201+-- (i.e., lines of wrapped text) with special attributes applied to
202+-- certain segments (e.g., the cursor). Additionally, produce the current
203+-- y-coordinate of the cursor and a mapping from display line number to text
204+-- offset
205+displayLines
206+ :: Int -- ^ Width, used for wrapping
207+ -> tag -- ^ Metadata for normal characters
208+ -> tag -- ^ Metadata for the cursor
209+ -> TextZipper -- ^ The text input contents and cursor state
210+ -> DisplayLines tag
211+displayLines width tag cursorTag (TextZipper lb b a la) =
212+ let linesBefore :: [[Text]] -- The wrapped lines before the cursor line
213+ linesBefore = map (wrapWithOffset width 0) $ reverse lb
214+ linesAfter :: [[Text]] -- The wrapped lines after the cursor line
215+ linesAfter = map (wrapWithOffset width 0) la
216+ offsets :: Map Int Int
217+ offsets = offsetMap $ mconcat
218+ [ linesBefore
219+ , [wrapWithOffset width 0 $ b <> a]
220+ , linesAfter
221+ ]
222+ spansBefore = map ((:[]) . Span tag) $ concat linesBefore
223+ spansAfter = map ((:[]) . Span tag) $ concat linesAfter
224+ -- Separate the spans before the cursor into
225+ -- * spans that are on earlier display lines (though on the same logical line), and
226+ -- * spans that are on the same display line
227+ (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
228+ initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b)
229+ -- Calculate the number of columns on the cursor's display line before the cursor
230+ curLineOffset = spansWidth spansCurLineBefore
231+ -- Check whether the spans on the current display line are long enough that
232+ -- the cursor has to go to the next line
233+ cursorAfterEOL = curLineOffset == width
234+ cursorCharWidth = case T.uncons a of
235+ Nothing -> 1
236+ Just (c, _) -> charWidth c
237+ -- Separate the span after the cursor into
238+ -- * spans that are on the same display line, and
239+ -- * spans that are on later display lines (though on the same logical line)
240+ (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
241+ headTail $ case T.uncons a of
242+ Nothing -> [[Span cursorTag " "]]
243+ Just (c, rest) ->
244+ let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
245+ cursor = Span cursorTag (T.singleton c)
246+ in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
247+ [] -> [[cursor]]
248+ (l:ls) -> (cursor : l) : ls
249+ in DisplayLines
250+ { _displayLines_spans = concat
251+ [ spansBefore
252+ , spansCurrentBefore
253+ , if cursorAfterEOL
254+ then [ spansCurLineBefore, spansCurLineAfter ]
255+ else [ spansCurLineBefore <> spansCurLineAfter ]
256+ , spansCurrentAfter
257+ , spansAfter
258+ ]
259+ , _displayLines_offsetMap = offsets
260+ , _displayLines_cursorY = sum
261+ [ length spansBefore
262+ , length spansCurrentBefore
263+ , if cursorAfterEOL then 1 else 0
264+ ]
265+ }
266+ where
267+ initLast :: [a] -> Maybe ([a], a)
268+ initLast = \case
269+ [] -> Nothing
270+ (x:xs) -> case initLast xs of
271+ Nothing -> Just ([], x)
272+ Just (ys, y) -> Just (x:ys, y)
273+ headTail :: [a] -> Maybe (a, [a])
274+ headTail = \case
275+ [] -> Nothing
276+ x:xs -> Just (x, xs)
277+
278+-- | Wraps a logical line of text to fit within the given width. The first
279+-- wrapped line is offset by the number of columns provided. Subsequent wrapped
280+-- lines are not.
281+wrapWithOffset
282+ :: Int -- ^ Maximum width
283+ -> Int -- ^ Offset for first line
284+ -> Text -- ^ Text to be wrapped
285+ -> [Text]
286+wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []
287+wrapWithOffset maxWidth n xs =
288+ let (firstLine, rest) = splitAtWidth (maxWidth - n) xs
289+ in firstLine : (fmap (takeWidth maxWidth) . takeWhile (not . T.null) . iterate (dropWidth maxWidth) $ rest)
290+
225291-- | Split a 'Text' at the given column index. For example
226292--
227293-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
@@ -231,16 +297,16 @@ splitAtWidth :: Int -> Text -> (Text, Text)
231297splitAtWidth n t@(Text arr off len)
232298 | n <= 0 = (T.empty, t)
233299 | n >= textWidth t = (t, T.empty)
234− | otherwise = let k = toLogicalIndex n t
300+ | otherwise = let k = iterNWidth n t
235301 in (text arr off k, text arr (off+k) (len-k))
236−
237−toLogicalIndex :: Int -> Text -> Int
238−toLogicalIndex n' t'@(Text _ _ len') = loop 0 0
239− where loop !i !cnt
240− | i >= len' || cnt + w > n' = i
241− | otherwise = loop (i+d) (cnt + w)
242− where Iter c d = iter t' i
243− w = charWidth c
302+ where
303+ iterNWidth :: Int -> Text -> Int
304+ iterNWidth n' t'@(Text _ _ len') = loop 0 0
305+ where loop !i !cnt
306+ | i >= len' || cnt + w > n' = i
307+ | otherwise = loop (i+d) (cnt + w)
308+ where Iter c d = iter t' i
309+ w = charWidth c
244310
245311-- | Takes the given number of columns of characters. For example
246312--
@@ -269,6 +335,56 @@ dropWidth n = snd . splitAtWidth n
269335charWidth :: Char -> Int
270336charWidth = wcwidth
271337
338+
339+-- | For a given set of wrapped logical lines, computes a map
340+-- from display line index to text offset in the original text.
341+-- This is used to help determine how interactions with the displayed
342+-- text map back to the original text.
343+-- For example, given the document @\"AA\\nBBB\\nCCCCCCCC\\n\"@ wrapped to 5 columns,
344+-- this function will compute the offset in the original document of each character
345+-- in column 1:
346+--
347+-- > AA... (0, 0)
348+-- > BBB.. (1, 3)
349+-- > CCCCC (2, 7) -- (this line wraps to the next row)
350+-- > CCC.. (3, 12)
351+-- > ..... (4, 16)
352+offsetMap
353+ :: [[Text]] -- ^ The outer list represents logical lines, and the
354+ -- inner list represents the display lines into which
355+ -- the logical line has been wrapped
356+ -> Map Int Int -- ^ A map from the index (row) of display line to
357+ -- the text offset from the beginning of the document
358+ -- to the first character of the display line
359+offsetMap ts = evalState (offsetMap' ts) (0, 0)
360+ where
361+ offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
362+ maps <- forM x $ \line -> do
363+ let l = T.length line
364+ (dl, o) <- get
365+ put (dl + 1, o + l)
366+ return $ Map.singleton dl o
367+ (dl, o) <- get
368+ put (dl, o + 1)
369+ return $ Map.insert dl (o + 1) $ Map.unions maps
370+
371+-- | Move the cursor of the given 'TextZipper' to the logical position indicated
372+-- by the given display line coordinates, using the provided 'DisplayLines'
373+-- information. If the x coordinate is beyond the end of a line, the cursor is
374+-- moved to the end of the line.
375+goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
376+goToDisplayLinePosition x y dl tz =
377+ let offset = Map.lookup y $ _displayLines_offsetMap dl
378+ in case offset of
379+ Nothing -> tz
380+ Just o ->
381+ let
382+ moveRight = case drop y $ _displayLines_spans dl of
383+ [] -> x
384+ (s:_) -> charIndexAt x . stream . mconcat . fmap (\(Span _ t) -> t) $ s
385+ in rightN (o + min moveRight x) $ top tz
386+
387+
272388-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
273389spansWidth :: [Span tag] -> Int
274390spansWidth = sum . map (\(Span _ t) -> textWidth t)
@@ -304,242 +420,3 @@ charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
304420 Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
305421 w = z + charWidth c
306422{-# INLINE[0] charIndexAt #-}
307−
308−
309−
310−
311−-- | Same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...])
312−-- 'Char's representing white space.
313−wordsWithWhitespace :: Text -> [Text]
314−wordsWithWhitespace t@(Text arr off len) = loop 0 0 False
315− where
316− loop !start !n !wasSpace
317− | n >= len = [Text arr (start+off) (n-start) | not (start == n)]
318− | isSpace c = loop start (n+d) True
319− | wasSpace = Text arr (start+off) (n-start) : loop n n False
320− | otherwise = loop start (n+d) False
321− where Iter c d = iter t n
322−{-# INLINE wordsWithWhitespace #-}
323−
324−-- | Split words into logical lines, 'True' in the tuple indicates line ends with a whitespace character that got deleted
325−splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
326−splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
327− appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]
328− appendOut [] t b = [(t,b)]
329− appendOut ((t',_):ts') t b = (t'<>t,b) : ts'
330−
331− -- remove the last whitespace in output
332− modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]
333− modifyOutForNewLine [] = error "should never happen"
334− modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of
335− Nothing -> error "should never happen"
336− Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace
337−
338− loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
339− loop [] _ out = out
340− loop (x:xs) cumw out = r where
341− newWidth = textWidth x + cumw
342− r = if newWidth > maxWidth
343− then if isSpace $ T.index x (toLogicalIndex (maxWidth - cumw) x)
344− -- if line runs over but character of splitting is whitespace then split on the whitespace
345− then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
346− in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True
347− else if cumw == 0
348− -- single word exceeds max width, so just split on the word
349− then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
350− in loop (t2:xs) 0 [] <> appendOut out t1 False
351− -- otherwise start a new line
352− else loop (x:xs) 0 [] <> modifyOutForNewLine out
353− else loop xs newWidth $ appendOut out x False
354−
355−
356−
357−-- | Wraps a logical line of text to fit within the given width. The first
358−-- wrapped line is offset by the number of columns provided. Subsequent wrapped
359−-- lines are not.
360−wrapWithOffsetAndAlignment
361− :: TextAlignment
362− -> Int -- ^ Maximum width
363− -> Int -- ^ Offset for first line
364− -> Text -- ^ Text to be wrapped
365− -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line)
366−wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []
367−wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where
368− -- we pad by offset amount with any non-space character which we will remove later so that no changes need to be made to splitWordsAtDisplayWidth
369− r' = splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)
370− fmapfn (t,b) = case alignment of
371− TextAlignment_Left -> WrappedLine t b 0
372− TextAlignment_Right -> WrappedLine t b (maxWidth-l)
373− TextAlignment_Center -> WrappedLine t b ((maxWidth-l) `div` 2)
374− where l = textWidth t
375− r'' = case r' of
376− [] -> []
377− (x,b):xs -> (T.drop n x,b):xs
378− r = fmap fmapfn r''
379−
380−-- converts deleted eol spaces into logical lines
381−eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]
382−eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))
383−
384−offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
385−offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines
386−
387−offsetMapWithAlignment
388− :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines
389− -> OffsetMapWithAlignment
390−offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0)
391− where
392− offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
393− maps <- forM x $ \(line,align) -> do
394− let l = T.length line
395− (dl, o) <- get
396− put (dl + 1, o + l)
397− return $ Map.singleton dl (align, o)
398− (dl, o) <- get
399− put (dl, o + 1)
400− -- add additional offset to last line in wrapped lines (for newline char)
401− return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps
402−
403−
404−-- | Given a width and a 'TextZipper', produce a list of display lines
405−-- (i.e., lines of wrapped text) with special attributes applied to
406−-- certain segments (e.g., the cursor). Additionally, produce the current
407−-- y-coordinate of the cursor and a mapping from display line number to text
408−-- offset
409−displayLinesWithAlignment
410− :: TextAlignment
411− -> Int -- ^ Width, used for wrapping
412− -> tag -- ^ Metadata for normal characters
413− -> tag -- ^ Metadata for the cursor
414− -> TextZipper -- ^ The text input contents and cursor state
415− -> DisplayLines tag
416−displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =
417− let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line
418− linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb
419− linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line
420− linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la
421−
422− -- simulate trailing cursor character when computing OffsetMap
423− afterWithCursor = if T.null a then " " else a
424− offsets :: OffsetMapWithAlignment
425− offsets = offsetMapWithAlignmentInternal $ mconcat
426− [ linesBefore
427− , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor]
428− , linesAfter
429− ]
430− flattenLines = concatMap (fmap _wrappedLines_text)
431− spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore
432− spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter
433− -- Separate the spans before the cursor into
434− -- * spans that are on earlier display lines (though on the same logical line), and
435− -- * spans that are on the same display line
436−
437− (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
438− initLast $ map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width 0 b)
439− -- Calculate the number of columns on the cursor's display line before the cursor
440− curLineOffset = spansWidth spansCurLineBefore
441− -- Check whether the spans on the current display line are long enough that
442− -- the cursor has to go to the next line
443− cursorAfterEOL = curLineOffset == width
444− cursorCharWidth = case T.uncons a of
445− Nothing -> 1
446− Just (c, _) -> charWidth c
447−
448− -- Separate the span after the cursor into
449− -- * spans that are on the same display line, and
450− -- * spans that are on later display lines (though on the same logical line)
451−
452− (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
453− headTail $ case T.uncons a of
454− Nothing -> [[Span cursorTag " "]]
455− Just (c, rest) ->
456− let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
457− cursor = Span cursorTag (T.singleton c)
458− in case map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width o rest) of
459− [] -> [[cursor]]
460− (l:ls) -> (cursor : l) : ls
461−
462− curLineSpanNormalCase = if cursorAfterEOL
463− then [ spansCurLineBefore, spansCurLineAfter ]
464− else [ spansCurLineBefore <> spansCurLineAfter ]
465−
466− -- for right alignment, we want draw the cursor tag to be on the character just before the logical cursor position
467− curLineSpan = if alignment == TextAlignment_Right && not cursorAfterEOL
468− then case reverse spansCurLineBefore of
469− [] -> curLineSpanNormalCase
470− (Span _ x):xs -> case spansCurLineAfter of
471− [] -> error "should not be possible" -- curLineSpanNormalCase
472− (Span _ y):ys -> [reverse (Span cursorTag x:xs) <> ((Span tag y):ys)]
473− else curLineSpanNormalCase
474−
475− cursorY = sum
476− [ length spansBefore
477− , length spansCurrentBefore
478− , if cursorAfterEOL then 1 else 0
479− ]
480− -- a little silly to convert back to text but whatever, it works
481− cursorX = if cursorAfterEOL then 0 else textWidth (mconcat $ fmap (\(Span _ t) -> t) spansCurLineBefore)
482−
483− in DisplayLines
484− { _displayLines_spans = concat
485− [ spansBefore
486− , spansCurrentBefore
487− , curLineSpan
488− , spansCurrentAfter
489− , spansAfter
490− ]
491− , _displayLines_offsetMap = offsets
492− , _displayLines_cursorPos = (cursorX, cursorY)
493− }
494− where
495− initLast :: [a] -> Maybe ([a], a)
496− initLast = \case
497− [] -> Nothing
498− (x:xs) -> case initLast xs of
499− Nothing -> Just ([], x)
500− Just (ys, y) -> Just (x:ys, y)
501− headTail :: [a] -> Maybe (a, [a])
502− headTail = \case
503− [] -> Nothing
504− x:xs -> Just (x, xs)
505−
506−
507−-- | Move the cursor of the given 'TextZipper' to the logical position indicated
508−-- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'
509−-- information. If the x coordinate is beyond the end of a line, the cursor is
510−-- moved to the end of the line.
511−goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
512−goToDisplayLinePosition x y dl tz =
513− let offset = Map.lookup y $ _displayLines_offsetMap dl
514− in case offset of
515− Nothing -> tz
516− Just (alignOff,o) ->
517− let
518− trueX = max 0 (x - alignOff)
519− moveRight = case drop y $ _displayLines_spans dl of
520− [] -> 0
521− (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s
522− in rightN (o + moveRight) $ top tz
523−
524−-- | Given a width and a 'TextZipper', produce a list of display lines
525−-- (i.e., lines of wrapped text) with special attributes applied to
526−-- certain segments (e.g., the cursor). Additionally, produce the current
527−-- y-coordinate of the cursor and a mapping from display line number to text
528−-- offset
529−displayLines
530− :: Int -- ^ Width, used for wrapping
531− -> tag -- ^ Metadata for normal characters
532− -> tag -- ^ Metadata for the cursor
533− -> TextZipper -- ^ The text input contents and cursor state
534− -> DisplayLines tag
535−displayLines = displayLinesWithAlignment TextAlignment_Left
536−
537−-- | Wraps a logical line of text to fit within the given width. The first
538−-- wrapped line is offset by the number of columns provided. Subsequent wrapped
539−-- lines are not.
540−wrapWithOffset
541− :: Int -- ^ Maximum width
542− -> Int -- ^ Offset for first line
543− -> Text -- ^ Text to be wrapped
544− -> [Text]
545−wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs