git.iko.soy/reflex-vty
on ecc299a help sign in
reflex-vty/src/Data/Text/Zipper.hs
317 lines 13 kB history raw
1{-|
2Module: Data.Text.Zipper
3Description: 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.
9-}
10{-# LANGUAGE FlexibleContexts #-}
11{-# LANGUAGE LambdaCase #-}
12{-# LANGUAGE OverloadedStrings #-}
13module Data.Text.Zipper where
15import Data.Char (isSpace)
16import Data.Map (Map)
17import qualified Data.Map as Map
18import Data.Maybe (fromMaybe)
19import Control.Monad.State (evalState, forM, get, put)
21import Data.Text (Text)
22import qualified Data.Text as T
24-- | A zipper of the logical text input contents (the "document"). The lines
25-- before the line containing the cursor are stored in reverse order.
26-- The cursor is logically between the "before" and "after" text.
27-- A "logical" line of input is a line of input up until a user-entered newline
28-- character (as compared to a "display" line, which is wrapped to fit within
29-- a given viewport width).
30data TextZipper = TextZipper
31 { _textZipper_linesBefore :: [Text] -- reversed
32 , _textZipper_before :: Text
33 , _textZipper_after :: Text -- The cursor is on top of the first character of this text
34 , _textZipper_linesAfter :: [Text]
35 }
36 deriving (Show)
38-- | Move the cursor left one character, if possible
39left :: TextZipper -> TextZipper
40left = leftN 1
42-- | Move the cursor left by the given number of characters, or, if the document
43-- isn't long enough, to the beginning of the document
44leftN :: Int -> TextZipper -> TextZipper
45leftN n z@(TextZipper lb b a la) =
46 if T.length b >= n
47 then
48 let n' = T.length b - n
49 in TextZipper lb (T.take n' b) (T.drop n' b <> a) la
50 else case lb of
51 [] -> home z
52 (l:ls) -> leftN (n - T.length b - 1) $ TextZipper ls l "" ((b <> a) : la)
54-- | Move the cursor right one character, if possible
55right :: TextZipper -> TextZipper
56right = rightN 1
58-- | Move the character right by the given number of characters, or, if the document
59-- isn't long enough, to the end of the document
60rightN :: Int -> TextZipper -> TextZipper
61rightN n z@(TextZipper lb b a la) =
62 if T.length a >= n
63 then TextZipper lb (b <> T.take n a) (T.drop n a) la
64 else case la of
65 [] -> end z
66 (l:ls) -> rightN (n - T.length a - 1) $ TextZipper ((b <> a) : lb) "" l ls
68-- | Move the cursor up one logical line, if possible
69up :: TextZipper -> TextZipper
70up z@(TextZipper lb b a la) = case lb of
71 [] -> z
72 (l:ls) ->
73 let (b', a') = T.splitAt (T.length b) l
74 in TextZipper ls b' a' ((b <> a) : la)
76-- | Move the cursor down one logical line, if possible
77down :: TextZipper -> TextZipper
78down z@(TextZipper lb b a la) = case la of
79 [] -> z
80 (l:ls) ->
81 let (b', a') = T.splitAt (T.length b) l
82 in TextZipper ((b <> a) : lb) b' a' ls
84-- | Move the cursor up by the given number of lines
85pageUp :: Int -> TextZipper -> TextZipper
86pageUp pageSize z = if pageSize <= 0
87 then z
88 else pageUp (pageSize - 1) $ up z
90-- | Move the cursor down by the given number of lines
91pageDown :: Int -> TextZipper -> TextZipper
92pageDown pageSize z = if pageSize <= 0
93 then z
94 else pageDown (pageSize - 1) $ down z
96-- | Move the cursor to the beginning of the current logical line
97home :: TextZipper -> TextZipper
98home (TextZipper lb b a la) = TextZipper lb "" (b <> a) la
100-- | Move the cursor to the end of the current logical line
101end :: TextZipper -> TextZipper
102end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la
104-- | Move the cursor to the top of the document
105top :: TextZipper -> TextZipper
106top (TextZipper lb b a la) = case reverse lb of
107 [] -> TextZipper [] "" (b <> a) la
108 (start:rest) -> TextZipper [] "" start (rest <> [b <> a] <> la)
110-- | Insert a character at the current cursor position
111insertChar :: Char -> TextZipper -> TextZipper
112insertChar i = insert (T.singleton i)
114-- | Insert text at the current cursor position
115insert :: Text -> TextZipper -> TextZipper
116insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of
117 [] -> z
118 (start:rest) -> case reverse rest of
119 [] -> TextZipper lb (b <> start) a la
120 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
122-- | Delete the character to the left of the cursor
123deleteLeft :: TextZipper-> TextZipper
124deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
125 Nothing -> case lb of
126 [] -> z
127 (l:ls) -> TextZipper ls l a la
128 Just (b', _) -> TextZipper lb b' a la
130-- | Delete the character under/to the right of the cursor
131deleteRight :: TextZipper -> TextZipper
132deleteRight z@(TextZipper lb b a la) = case T.uncons a of
133 Nothing -> case la of
134 [] -> z
135 (l:ls) -> TextZipper lb b l ls
136 Just (_, a') -> TextZipper lb b a' la
138-- | Delete a word to the left of the cursor. Deletes all whitespace until it
139-- finds a non-whitespace character, and then deletes contiguous non-whitespace
140-- characters.
141deleteLeftWord :: TextZipper -> TextZipper
142deleteLeftWord (TextZipper lb b a la) =
143 let b' = T.dropWhileEnd isSpace b
144 in if T.null b'
145 then case lb of
146 [] -> TextZipper [] b' a la
147 (l:ls) -> deleteLeftWord $ TextZipper ls l a la
148 else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la
150-- | Insert up to n spaces to get to the next logical column that is a multiple of n
151tab :: Int -> TextZipper -> TextZipper
152tab n z@(TextZipper _ b _ _) =
153 insert (T.replicate (fromEnum $ n - (T.length b `mod` n)) " ") z
155-- | The plain text contents of the zipper
156value :: TextZipper -> Text
157value (TextZipper lb b a la) = T.intercalate "\n" $ mconcat [ reverse lb
158 , [b <> a]
159 , la
160 ]
162-- | The empty zipper
163empty :: TextZipper
164empty = TextZipper [] "" "" []
166-- | Constructs a zipper with the given contents. The cursor is placed after
167-- the contents.
168fromText :: Text -> TextZipper
169fromText = flip insert empty
171-- | A span of text tagged with some metadata that makes up part of a display
172-- line.
173data Span tag = Span tag Text
174 deriving (Show)
176-- | Information about the document as it is displayed (i.e., post-wrapping)
177data DisplayLines tag = DisplayLines
178 { _displayLines_spans :: [[Span tag]]
179 , _displayLines_offsetMap :: Map Int Int
180 , _displayLines_cursorY :: Int
181 }
182 deriving (Show)
184-- | Given a width and a 'TextZipper', produce a list of display lines
185-- (i.e., lines of wrapped text) with special attributes applied to
186-- certain segments (e.g., the cursor). Additionally, produce the current
187-- y-coordinate of the cursor and a mapping from display line number to text
188-- offset
189displayLines
190 :: Int -- ^ Width, used for wrapping
191 -> tag -- ^ Metadata for normal characters
192 -> tag -- ^ Metadata for the cursor
193 -> TextZipper -- ^ The text input contents and cursor state
194 -> DisplayLines tag
195displayLines width tag cursorTag (TextZipper lb b a la) =
196 let linesBefore :: [[Text]] -- The wrapped lines before the cursor line
197 linesBefore = map (wrapWithOffset width 0) $ reverse lb
198 linesAfter :: [[Text]] -- The wrapped lines after the cursor line
199 linesAfter = map (wrapWithOffset width 0) la
200 offsets :: Map Int Int
201 offsets = offsetMap $ mconcat
202 [ linesBefore
203 , [wrapWithOffset width 0 $ b <> a]
204 , linesAfter
205 ]
206 spansBefore = map ((:[]) . Span tag) $ concat linesBefore
207 spansAfter = map ((:[]) . Span tag) $ concat linesAfter
208 -- Separate the spans before the cursor into
209 -- * spans that are on earlier display lines (though on the same logical line), and
210 -- * spans that are on the same display line
211 (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
212 initLast $ map ((:[]) . Span tag) (wrapWithOffset width 0 b)
213 -- Calculate the number of columns on the cursor's display line before the cursor
214 curLineOffset = spansLength spansCurLineBefore
215 -- Check whether the spans on the current display line are long enough that
216 -- the cursor has to go to the next line
217 cursorAfterEOL = curLineOffset == width
218 -- Separate the span after the cursor into
219 -- * spans that are on the same display line, and
220 -- * spans that are on later display lines (though on the same logical line)
221 (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
222 headTail $ case T.uncons a of
223 Nothing -> [[Span cursorTag " "]]
224 Just (c, rest) ->
225 let o = if cursorAfterEOL then 1 else curLineOffset + 1
226 cursor = Span cursorTag (T.singleton c)
227 in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
228 [] -> [[cursor]]
229 (l:ls) -> (cursor : l) : ls
230 in DisplayLines
231 { _displayLines_spans = concat
232 [ spansBefore
233 , spansCurrentBefore
234 , if cursorAfterEOL
235 then [ spansCurLineBefore, spansCurLineAfter ]
236 else [ spansCurLineBefore <> spansCurLineAfter ]
237 , spansCurrentAfter
238 , spansAfter
239 ]
240 , _displayLines_offsetMap = offsets
241 , _displayLines_cursorY = sum
242 [ length spansBefore
243 , length spansCurrentBefore
244 , if cursorAfterEOL then 1 else 0
245 ]
246 }
247 where
248 initLast :: [a] -> Maybe ([a], a)
249 initLast = \case
250 [] -> Nothing
251 (x:xs) -> case initLast xs of
252 Nothing -> Just ([], x)
253 Just (ys, y) -> Just (x:ys, y)
254 headTail :: [a] -> Maybe (a, [a])
255 headTail = \case
256 [] -> Nothing
257 x:xs -> Just (x, xs)
259-- | Wraps a logical line of text to fit within the given width. The first
260-- wrapped line is offset by the number of columns provided. Subsequent wrapped
261-- lines are not.
262wrapWithOffset :: Int -> Int -> Text -> [Text]
263wrapWithOffset maxWidth _ _ | maxWidth <= 0 = []
264wrapWithOffset maxWidth n xs =
265 let (firstLine, rest) = T.splitAt (maxWidth - n) xs
266 in firstLine : (fmap (T.take maxWidth) . takeWhile (not . T.null) . iterate (T.drop maxWidth) $ rest)
268-- | For a given set of wrapped logical lines, computes a map
269-- from display line index to text offset in the original text.
270-- This is used to help determine how interactions with the displayed
271-- text map back to the original text.
272-- For example, given the document @\"AA\\nBBB\\nCCCCCCCC\\n\"@ wrapped to 5 columns,
273-- this function will compute the offset in the original document of each character
274-- in column 1:
275--
276-- > AA... (0, 0)
277-- > BBB.. (1, 3)
278-- > CCCCC (2, 7) -- (this line wraps to the next row)
279-- > CCC.. (3, 12)
280-- > ..... (4, 16)
281offsetMap
282 :: [[Text]] -- ^ The outer list represents logical lines, and the
283 -- inner list represents the display lines into which
284 -- the logical line has been wrapped
285 -> Map Int Int -- ^ A map from the index (row) of display line to
286 -- the text offset from the beginning of the document
287 -- to the first character of the display line
288offsetMap ts = evalState (offsetMap' ts) (0, 0)
289 where
290 offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
291 maps <- forM x $ \line -> do
292 let l = T.length line
293 (dl, o) <- get
294 put (dl + 1, o + l)
295 return $ Map.singleton dl o
296 (dl, o) <- get
297 put (dl, o + 1)
298 return $ Map.insert dl (o + 1) $ Map.unions maps
300-- | Move the cursor of the given 'TextZipper' to the logical position indicated
301-- by the given display line coordinates, using the provided 'DisplayLines'
302-- information. If the x coordinate is beyond the end of a line, the cursor is
303-- moved to the end of the line.
304goToDisplayLinePosition :: Int -> Int -> DisplayLines tag -> TextZipper -> TextZipper
305goToDisplayLinePosition x y dl tz =
306 let offset = Map.lookup y $ _displayLines_offsetMap dl
307 in case offset of
308 Nothing -> tz
309 Just o ->
310 let displayLineLength = case drop y $ _displayLines_spans dl of
311 [] -> x
312 (s:_) -> spansLength s
313 in rightN (o + (min displayLineLength x)) $ top tz
315-- | Get the length of the text in a set of 'Span's
316spansLength :: [Span tag] -> Int
317spansLength = sum . map (\(Span _ t) -> T.length t)