@@ -1,545 +0,0 @@
2−Module: Data.Text.Zipper
3−Description: A zipper for text documents that allows convenient editing and navigation
5−'TextZipper' is designed to be help manipulate the contents of a text input field. It keeps track of the logical lines of text (i.e., lines separated by user-entered newlines) and the current cursor position. Several functions are defined in this module to navigate and edit the TextZipper from the cursor position.
7−'TextZipper's can be converted into 'DisplayLines', which describe how the contents of the zipper will be displayed when wrapped to fit within a container of a certain width. It also provides some convenience facilities for converting interactions with the rendered DisplayLines back into manipulations of the underlying TextZipper.
10−module Data.Text.Zipper where
14−import Control.Exception (assert)
15−import Control.Monad.State (evalState, forM, get, put)
16−import Data.Char (isSpace)
18−import Data.Maybe (fromMaybe)
20−import Data.Text (Text)
21−import Data.Text.Internal (Text(..), text)
22−import Data.Text.Internal.Fusion (stream)
23−import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
24−import Data.Text.Unsafe
25−import qualified Data.List as L
26−import qualified Data.Map as Map
27−import qualified Data.Text as T
29−import Graphics.Text.Width (wcwidth)
32−-- | A zipper of the logical text input contents (the "document"). The lines
33−-- before the line containing the cursor are stored in reverse order.
34−-- The cursor is logically between the "before" and "after" text.
35−-- A "logical" line of input is a line of input up until a user-entered newline
36−-- character (as compared to a "display" line, which is wrapped to fit within
37−-- a given viewport width).
38−data TextZipper = TextZipper
39− { _textZipper_linesBefore :: [Text] -- reversed
40− , _textZipper_before :: Text
41− , _textZipper_after :: Text -- The cursor is on top of the first character of this text
42− , _textZipper_linesAfter :: [Text]
46−instance IsString TextZipper where
47− fromString = fromText . T.pack
49−-- | Map a replacement function over the characters in a 'TextZipper'
50−mapZipper :: (Char -> Char) -> TextZipper -> TextZipper
51−mapZipper f (TextZipper lb b a la) = TextZipper
52− { _textZipper_linesBefore = fmap (T.map f) lb
53− , _textZipper_before = T.map f b
54− , _textZipper_after = T.map f a
55− , _textZipper_linesAfter = fmap (T.map f) la
58−-- | Move the cursor left one character, if possible
59−left :: TextZipper -> TextZipper
62−-- | Move the cursor left by the given number of characters, or, if the document
63−-- isn't long enough, to the beginning of the document
64−leftN :: Int -> TextZipper -> TextZipper
65−leftN n z@(TextZipper lb b a la) =
68− let n' = T.length b - n
69− in TextZipper lb (T.take n' b) (T.drop n' b <> a) la
72− (l:ls) -> leftN (n - T.length b - 1) $ TextZipper ls l "" ((b <> a) : la)
74−-- | Move the cursor right one character, if possible
75−right :: TextZipper -> TextZipper
78−-- | Move the character right by the given number of characters, or, if the document
79−-- isn't long enough, to the end of the document
80−rightN :: Int -> TextZipper -> TextZipper
81−rightN n z@(TextZipper lb b a la) =
83− then TextZipper lb (b <> T.take n a) (T.drop n a) la
86− (l:ls) -> rightN (n - T.length a - 1) $ TextZipper ((b <> a) : lb) "" l ls
88−-- | Move the cursor up one logical line, if possible
89−up :: TextZipper -> TextZipper
90−up z@(TextZipper lb b a la) = case lb of
93− let (b', a') = T.splitAt (T.length b) l
94− in TextZipper ls b' a' ((b <> a) : la)
96−-- | Move the cursor down one logical line, if possible
97−down :: TextZipper -> TextZipper
98−down z@(TextZipper lb b a la) = case la of
101− let (b', a') = T.splitAt (T.length b) l
102− in TextZipper ((b <> a) : lb) b' a' ls
104−-- | Move the cursor up by the given number of lines
105−pageUp :: Int -> TextZipper -> TextZipper
106−pageUp pageSize z = if pageSize <= 0
108− else pageUp (pageSize - 1) $ up z
110−-- | Move the cursor down by the given number of lines
111−pageDown :: Int -> TextZipper -> TextZipper
112−pageDown pageSize z = if pageSize <= 0
114− else pageDown (pageSize - 1) $ down z
116−-- | Move the cursor to the beginning of the current logical line
117−home :: TextZipper -> TextZipper
118−home (TextZipper lb b a la) = TextZipper lb "" (b <> a) la
120−-- | Move the cursor to the end of the current logical line
121−end :: TextZipper -> TextZipper
122−end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la
124−-- | Move the cursor to the top of the document
125−top :: TextZipper -> TextZipper
126−top (TextZipper lb b a la) = case reverse lb of
127− [] -> TextZipper [] "" (b <> a) la
128− (start:rest) -> TextZipper [] "" start (rest <> [b <> a] <> la)
130−-- | Insert a character at the current cursor position
131−insertChar :: Char -> TextZipper -> TextZipper
132−insertChar i = insert (T.singleton i)
134−-- | Insert text at the current cursor position
135−insert :: Text -> TextZipper -> TextZipper
136−insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of
138− (start:rest) -> case reverse rest of
139− [] -> TextZipper lb (b <> start) a la
140− (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
142−-- | Delete the character to the left of the cursor
143−deleteLeft :: TextZipper-> TextZipper
144−deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
145− Nothing -> case lb of
147− (l:ls) -> TextZipper ls l a la
148− Just (b', _) -> TextZipper lb b' a la
150−-- | Delete the character under/to the right of the cursor
151−deleteRight :: TextZipper -> TextZipper
152−deleteRight z@(TextZipper lb b a la) = case T.uncons a of
153− Nothing -> case la of
155− (l:ls) -> TextZipper lb b l ls
156− Just (_, a') -> TextZipper lb b a' la
158−-- | Delete a word to the left of the cursor. Deletes all whitespace until it
159−-- finds a non-whitespace character, and then deletes contiguous non-whitespace
161−deleteLeftWord :: TextZipper -> TextZipper
162−deleteLeftWord (TextZipper lb b a la) =
163− let b' = T.dropWhileEnd isSpace b
166− [] -> TextZipper [] b' a la
167− (l:ls) -> deleteLeftWord $ TextZipper ls l a la
168− else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la
170−-- | Insert up to n spaces to get to the next logical column that is a multiple of n
171−tab :: Int -> TextZipper -> TextZipper
172−tab n z@(TextZipper _ b _ _) =
173− insert (T.replicate (fromEnum $ n - T.length b `mod` max 1 n) " ") z
175−-- | The plain text contents of the zipper
176−value :: TextZipper -> Text
177−value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb
182−-- | The empty zipper
184−empty = TextZipper [] "" "" []
186−-- | Constructs a zipper with the given contents. The cursor is placed after
188−fromText :: Text -> TextZipper
189−fromText = flip insert empty
191−-- | A span of text tagged with some metadata that makes up part of a display
193−data Span tag = Span tag Text
196−-- | Text alignment type
199− | TextAlignment_Right
200− | TextAlignment_Center
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)
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
217−-- | Information about the document as it is displayed (i.e., post-wrapping)
218−data DisplayLines tag = DisplayLines
219− { _displayLines_spans :: [[Span tag]]
220− , _displayLines_offsetMap :: OffsetMapWithAlignment
221− , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
225−-- | Split a 'Text' at the given column index. For example
227−-- > splitAtWidth 3 "ᄀabc" == ("ᄀa", "bc")
229−-- because the first character has a width of two (see 'charWidth' for more on that).
230−splitAtWidth :: Int -> Text -> (Text, Text)
231−splitAtWidth n t@(Text arr off len)
232− | n <= 0 = (T.empty, t)
233− | n >= textWidth t = (t, T.empty)
234− | otherwise = let k = toLogicalIndex n t
235− in (text arr off k, text arr (off+k) (len-k))
237−toLogicalIndex :: Int -> Text -> Int
238−toLogicalIndex n' t'@(Text _ _ len') = loop 0 0
240− | i >= len' || cnt + w > n' = i
241− | otherwise = loop (i+d) (cnt + w)
242− where Iter c d = iter t' i
245−-- | Takes the given number of columns of characters. For example
247−-- > takeWidth 3 "ᄀabc" == "ᄀa"
249−-- because the first character has a width of 2 (see 'charWidth' for more on that).
250−-- This function will not take a character if its width exceeds the width it seeks to take.
251−takeWidth :: Int -> Text -> Text
252−takeWidth n = fst . splitAtWidth n
254−-- | Drops the given number of columns of characters. For example
256−-- > dropWidth 2 "ᄀabc" == "abc"
258−-- because the first character has a width of 2 (see 'charWidth' for more on that).
259−-- This function will not drop a character if its width exceeds the width it seeks to drop.
260−dropWidth :: Int -> Text -> Text
261−dropWidth n = snd . splitAtWidth n
263−-- | Get the display width of a 'Char'. "Full width" and "wide" characters
264−-- take two columns and everything else takes a single column. See
265−-- <https://www.unicode.org/reports/tr11/> for more information
266−-- This is implemented using wcwidth from Vty such that it matches what will
267−-- be displayed on the terminal. Note that this method can change depending
268−-- on how vty is configed. Please see vty documentation for details.
269−charWidth :: Char -> Int
272−-- | Get the width of the text in a set of 'Span's, taking into account unicode character widths
273−spansWidth :: [Span tag] -> Int
274−spansWidth = sum . map (\(Span _ t) -> textWidth t)
276−-- | Get the length (number of characters) of the text in a set of 'Span's
277−spansLength :: [Span tag] -> Int
278−spansLength = sum . map (\(Span _ t) -> T.length t)
280−-- | Compute the width of some 'Text', taking into account fullwidth
282−textWidth :: Text -> Int
283−textWidth t = widthI (stream t)
285−-- | Compute the width of a stream of characters, taking into account
286−-- fullwidth unicode forms.
287−widthI :: Stream Char -> Int
288−widthI (Stream next s0 _len) = loop_length 0 s0
290− loop_length !z s = case next s of
292− Skip s' -> loop_length z s'
293− Yield c s' -> loop_length (z + charWidth c) s'
294−{-# INLINE[0] widthI #-}
296−-- | Compute the logical index position of a stream of characters from a visual
297−-- position taking into account fullwidth unicode forms.
298−charIndexAt :: Int -> Stream Char -> Int
299−charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
301− loop_length i !z s = case next s of
303− Skip s' -> loop_length i z s'
304− Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
306−{-# INLINE[0] charIndexAt #-}
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
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 #-}
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'
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
338− loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
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
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
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
360−wrapWithOffsetAndAlignment
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
377− (x,b):xs -> (T.drop n x,b):xs
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))
384−offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
385−offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines
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)
392− offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
393− maps <- forM x $ \(line,align) -> do
394− let l = T.length line
397− return $ Map.singleton dl (align, o)
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
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
409−displayLinesWithAlignment
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
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
422− -- simulate trailing cursor character when computing OffsetMap
423− afterWithCursor = if T.null a then " " else a
424− offsets :: OffsetMapWithAlignment
425− offsets = offsetMapWithAlignmentInternal $ mconcat
427− , [wrapWithOffsetAndAlignment alignment width 0 $ b <> afterWithCursor]
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
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
446− Just (c, _) -> charWidth c
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)
452− (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
453− headTail $ case T.uncons a of
454− Nothing -> [[Span cursorTag " "]]
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
460− (l:ls) -> (cursor : l) : ls
462− curLineSpanNormalCase = if cursorAfterEOL
463− then [ spansCurLineBefore, spansCurLineAfter ]
464− else [ spansCurLineBefore <> spansCurLineAfter ]
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
476− [ length spansBefore
477− , length spansCurrentBefore
478− , if cursorAfterEOL then 1 else 0
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)
484− { _displayLines_spans = concat
486− , spansCurrentBefore
491− , _displayLines_offsetMap = offsets
492− , _displayLines_cursorPos = (cursorX, cursorY)
495− initLast :: [a] -> Maybe ([a], a)
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])
504− x:xs -> Just (x, xs)
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
516− Just (alignOff,o) ->
518− trueX = max 0 (x - alignOff)
519− moveRight = case drop y $ _displayLines_spans dl of
521− (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s
522− in rightN (o + moveRight) $ top tz
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
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
535−displayLines = displayLinesWithAlignment TextAlignment_Left
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
541− :: Int -- ^ Maximum width
542− -> Int -- ^ Offset for first line
543− -> Text -- ^ Text to be wrapped
545−wrapWithOffset maxWidth n xs = _wrappedLines_text <$> wrapWithOffsetAndAlignment TextAlignment_Left maxWidth n xs