@@ -9,22 +9,26 @@ 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)
1216import Data.Char (isSpace)
1317import Data.Map (Map)
14−import qualified Data.Map as Map
1518import Data.Maybe (fromMaybe)
1619import Data.String
17−import Control.Monad.State (evalState, forM, get, put)
18−
1920import 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
2528
2629import Graphics.Text.Width (wcwidth)
2730
31+
2832-- | A zipper of the logical text input contents (the "document"). The lines
2933-- before the line containing the cursor are stored in reverse order.
3034-- The cursor is logically between the "before" and "after" text.
@@ -166,7 +170,7 @@ deleteLeftWord (TextZipper lb b a la) =
166170-- | Insert up to n spaces to get to the next logical column that is a multiple of n
167171tab :: Int -> TextZipper -> TextZipper
168172tab n z@(TextZipper _ b _ _) =
169− insert (T.replicate (fromEnum $ n - (T.length b `mod` max 1 n)) " ") z
173+ insert (T.replicate (fromEnum $ n - T.length b `mod` max 1 n) " ") z
170174
171175-- | The plain text contents of the zipper
172176value :: TextZipper -> Text
@@ -189,105 +193,35 @@ fromText = flip insert empty
189193data Span tag = Span tag Text
190194 deriving (Show)
191195
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+
192217-- | Information about the document as it is displayed (i.e., post-wrapping)
193218data DisplayLines tag = DisplayLines
194219 { _displayLines_spans :: [[Span tag]]
195− , _displayLines_offsetMap :: Map Int Int
196− , _displayLines_cursorY :: Int
220+ , _displayLines_offsetMap :: OffsetMapWithAlignment
221+ , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
197222 }
198223 deriving (Show)
199224
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−
291225-- | Split a 'Text' at the given column index. For example
292226--
293227-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
@@ -297,16 +231,16 @@ splitAtWidth :: Int -> Text -> (Text, Text)
297231splitAtWidth n t@(Text arr off len)
298232 | n <= 0 = (T.empty, t)
299233 | n >= textWidth t = (t, T.empty)
300− | otherwise = let k = iterNWidth n t
234+ | otherwise = let k = toLogicalIndex n t
301235 in (text arr off k, text arr (off+k) (len-k))
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
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
310244
311245-- | Takes the given number of columns of characters. For example
312246--
@@ -335,56 +269,6 @@ dropWidth n = snd . splitAtWidth n
335269charWidth :: Char -> Int
336270charWidth = wcwidth
337271
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−
388272-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
389273spansWidth :: [Span tag] -> Int
390274spansWidth = sum . map (\(Span _ t) -> textWidth t)
@@ -420,3 +304,242 @@ charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
420304 Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
421305 w = z + charWidth c
422306{-# 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