@@ -0,0 +1,545 @@
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