@@ -1,6 +1,3 @@
1−-- | forked from reflex-vty-0.1.4.1
2−-- adds alignment support
5Module: Potato.Data.Text.Zipper
2Module: Potato.Data.Text.Zipper
6Description: A zipper for text documents that allows convenient editing and navigation
3Description: A zipper for text documents that allows convenient editing and navigation
@@ -19,8 +16,8 @@ module Data.Text.Zipper where
20import Prelude
17import Prelude
22−import Control.Exception (assert)
19+import Control.Exception (assert)
23−import Control.Monad (join)
20+import Control.Monad (join)
24import Control.Monad.State (evalState, forM, get, put)
21import Control.Monad.State (evalState, forM, get, put)
25import Data.Char (isSpace)
22import Data.Char (isSpace)
26import Data.Map (Map)
23import Data.Map (Map)
@@ -28,17 +25,17 @@ import qualified Data.Map as Map
28import Data.Maybe (fromMaybe)
25import Data.Maybe (fromMaybe)
29import Data.String
26import Data.String
31−import qualified Data.List as L
28+import qualified Data.List as L
32import Data.Text (Text)
29import Data.Text (Text)
33import qualified Data.Text as T
30import qualified Data.Text as T
34import Data.Text.Internal (Text (..), text)
31import Data.Text.Internal (Text (..), text)
35import Data.Text.Internal.Fusion (stream)
32import Data.Text.Internal.Fusion (stream)
36import Data.Text.Internal.Fusion.Types (Step (..), Stream (..))
33import Data.Text.Internal.Fusion.Types (Step (..), Stream (..))
37import Data.Text.Unsafe
34import Data.Text.Unsafe
38−import Data.Tuple.Extra
35+import Data.Tuple.Extra
41−import Graphics.Text.Width (wcwidth)
38+import Graphics.Text.Width (wcwidth)
43-- | A zipper of the logical text input contents (the "document"). The lines
40-- | A zipper of the logical text input contents (the "document"). The lines
44-- before the line containing the cursor are stored in reverse order.
41-- before the line containing the cursor are stored in reverse order.
@@ -47,12 +44,13 @@ import Graphics.Text.Width (wcwidth)
47-- character (as compared to a "display" line, which is wrapped to fit within
44-- character (as compared to a "display" line, which is wrapped to fit within
48-- a given viewport width).
45-- a given viewport width).
49data TextZipper = TextZipper
46data TextZipper = TextZipper
50− { _textZipper_linesBefore :: [Text] -- reversed
47+ { _textZipper_linesBefore :: [Text] -- reversed
51− , _textZipper_before :: Text
48+ , _textZipper_before :: Text
49+ -- The cursor is on top of the first character of this text
52− , _textZipper_after :: Text -- The cursor is on top of the first character of this text
50+ , _textZipper_after :: Text -- The cursor is on top of the first character of this text
53− , _textZipper_linesAfter :: [Text]
51+ , _textZipper_linesAfter :: [Text]
55− deriving (Show)
53+ deriving (Show)
57instance IsString TextZipper where
55instance IsString TextZipper where
58 fromString = fromText . T.pack
56 fromString = fromText . T.pack
@@ -135,7 +133,7 @@ end (TextZipper lb b a la) = TextZipper lb (b <> a) "" la
135-- | Move the cursor to the top of the document
133-- | Move the cursor to the top of the document
136top :: TextZipper -> TextZipper
134top :: TextZipper -> TextZipper
137top (TextZipper lb b a la) = case reverse lb of
135top (TextZipper lb b a la) = case reverse lb of
138− [] -> TextZipper [] "" (b <> a) la
136+ [] -> TextZipper [] "" (b <> a) la
139 (start:rest) -> TextZipper [] "" start (rest <> [b <> a] <> la)
137 (start:rest) -> TextZipper [] "" start (rest <> [b <> a] <> la)
141-- | Insert a character at the current cursor position
139-- | Insert a character at the current cursor position
@@ -147,14 +145,14 @@ insert :: Text -> TextZipper -> TextZipper
147insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of
145insert i z@(TextZipper lb b a la) = case T.split (=='\n') i of
149 (start:rest) -> case reverse rest of
147 (start:rest) -> case reverse rest of
150− [] -> TextZipper lb (b <> start) a la
148+ [] -> TextZipper lb (b <> start) a la
151 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
149 (l:ls) -> TextZipper (ls <> [b <> start] <> lb) l a la
153-- | Delete the character to the left of the cursor
151-- | Delete the character to the left of the cursor
154deleteLeft :: TextZipper-> TextZipper
152deleteLeft :: TextZipper-> TextZipper
155deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
153deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
156 Nothing -> case lb of
154 Nothing -> case lb of
158 (l:ls) -> TextZipper ls l a la
156 (l:ls) -> TextZipper ls l a la
159 Just (b', _) -> TextZipper lb b' a la
157 Just (b', _) -> TextZipper lb b' a la
@@ -162,7 +160,7 @@ deleteLeft z@(TextZipper lb b a la) = case T.unsnoc b of
162deleteRight :: TextZipper -> TextZipper
160deleteRight :: TextZipper -> TextZipper
163deleteRight z@(TextZipper lb b a la) = case T.uncons a of
161deleteRight z@(TextZipper lb b a la) = case T.uncons a of
164 Nothing -> case la of
162 Nothing -> case la of
166 (l:ls) -> TextZipper lb b l ls
164 (l:ls) -> TextZipper lb b l ls
167 Just (_, a') -> TextZipper lb b a' la
165 Just (_, a') -> TextZipper lb b a' la
@@ -174,7 +172,7 @@ deleteLeftWord (TextZipper lb b a la) =
174 let b' = T.dropWhileEnd isSpace b
172 let b' = T.dropWhileEnd isSpace b
175 in if T.null b'
173 in if T.null b'
176 then case lb of
174 then case lb of
177− [] -> TextZipper [] b' a la
175+ [] -> TextZipper [] b' a la
178 (l:ls) -> deleteLeftWord $ TextZipper ls l a la
176 (l:ls) -> deleteLeftWord $ TextZipper ls l a la
179 else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la
177 else TextZipper lb (T.dropWhileEnd (not . isSpace) b') a la
@@ -202,15 +200,15 @@ fromText = flip insert empty
202-- | A span of text tagged with some metadata that makes up part of a display
200-- | A span of text tagged with some metadata that makes up part of a display
204data Span tag = Span tag Text
202data Span tag = Span tag Text
205− deriving (Show)
203+ deriving (Show)
207-- | Information about the document as it is displayed (i.e., post-wrapping)
205-- | Information about the document as it is displayed (i.e., post-wrapping)
208data DisplayLines tag = DisplayLines
206data DisplayLines tag = DisplayLines
209− { _displayLines_spans :: [[Span tag]]
207+ { _displayLines_spans :: [[Span tag]]
210− , _displayLines_offsetMap :: Map Int Int
208+ , _displayLines_offsetMap :: Map Int Int
211− , _displayLines_cursorY :: Int
209+ , _displayLines_cursorY :: Int
213− deriving (Show)
211+ deriving (Show)
215-- | Given a width and a 'TextZipper', produce a list of display lines
213-- | Given a width and a 'TextZipper', produce a list of display lines
216-- (i.e., lines of wrapped text) with special attributes applied to
214-- (i.e., lines of wrapped text) with special attributes applied to
@@ -247,7 +245,7 @@ displayLines width tag cursorTag (TextZipper lb b a la) =
247 -- the cursor has to go to the next line
245 -- the cursor has to go to the next line
248 cursorAfterEOL = curLineOffset == width
246 cursorAfterEOL = curLineOffset == width
249 cursorCharWidth = case T.uncons a of
247 cursorCharWidth = case T.uncons a of
250− Nothing -> 1
248+ Nothing -> 1
251 Just (c, _) -> charWidth c
249 Just (c, _) -> charWidth c
252 -- Separate the span after the cursor into
250 -- Separate the span after the cursor into
253 -- * spans that are on the same display line, and
251 -- * spans that are on the same display line, and
@@ -259,7 +257,7 @@ displayLines width tag cursorTag (TextZipper lb b a la) =
259 let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
257 let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
260 cursor = Span cursorTag (T.singleton c)
258 cursor = Span cursorTag (T.singleton c)
261 in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
259 in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
262− [] -> [[cursor]]
260+ [] -> [[cursor]]
263 (l:ls) -> (cursor : l) : ls
261 (l:ls) -> (cursor : l) : ls
264 in DisplayLines
262 in DisplayLines
265 { _displayLines_spans = concat
263 { _displayLines_spans = concat
@@ -283,7 +281,7 @@ displayLines width tag cursorTag (TextZipper lb b a la) =
283 initLast = \case
281 initLast = \case
284 [] -> Nothing
282 [] -> Nothing
285 (x:xs) -> case initLast xs of
283 (x:xs) -> case initLast xs of
286− Nothing -> Just ([], x)
284+ Nothing -> Just ([], x)
287 Just (ys, y) -> Just (x:ys, y)
285 Just (ys, y) -> Just (x:ys, y)
288 headTail :: [a] -> Maybe (a, [a])
286 headTail :: [a] -> Maybe (a, [a])
289 headTail = \case
287 headTail = \case
@@ -439,27 +437,6 @@ charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
460−-- NEW TEXT ALIGNMENT STUFF BELOW
463-- same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...])
440-- same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...])
464-- 'Char's representing white space.
441-- 'Char's representing white space.
465wordsWithWhitespace :: Text -> [Text]
442wordsWithWhitespace :: Text -> [Text]
@@ -475,19 +452,18 @@ wordsWithWhitespace t@(Text arr off len) = loop 0 0 False
475 where Iter c d = iter t n
452 where Iter c d = iter t n
476{-# INLINE wordsWithWhitespace #-}
453{-# INLINE wordsWithWhitespace #-}
478−-- TODO Check that this handles EOL space/newline stuff correctly
479-- take sum of word length, returns True if ends with trailng space
455-- take sum of word length, returns True if ends with trailng space
480splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
456splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
481splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
457splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
482 appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]
458 appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]
483− appendOut [] t b = [(t,b)]
459+ appendOut [] t b = [(t,b)]
484 appendOut ((t',_):ts') t b = (t'<>t,b) : ts'
460 appendOut ((t',_):ts') t b = (t'<>t,b) : ts'
486 -- remove the last whitespace in output
462 -- remove the last whitespace in output
487 modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]
463 modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]
488 modifyOutForNewLine [] = error "should never happen"
464 modifyOutForNewLine [] = error "should never happen"
489 modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of
465 modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of
490− Nothing -> error "should never happen"
466+ Nothing -> error "should never happen"
491 Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace
467 Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace
493 loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
469 loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
@@ -508,7 +484,9 @@ splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
508 else loop (x:xs) 0 [] <> modifyOutForNewLine out
484 else loop (x:xs) 0 [] <> modifyOutForNewLine out
509 else loop xs newWidth $ appendOut out x False
485 else loop xs newWidth $ appendOut out x False
511−data TextAlignment = TextAlignment_Left | TextAlignment_Right | TextAlignment_Center
487+data TextAlignment = TextAlignment_Left
488+ | TextAlignment_Right
489+ | TextAlignment_Center
513-- A map from the index (row) of display line to
491-- A map from the index (row) of display line to
514-- fst: leading empty spaces from left (may be negative) to adjust for alignment
492-- fst: leading empty spaces from left (may be negative) to adjust for alignment
@@ -518,11 +496,12 @@ type OffsetMapWithAlignment = Map Int (Int, Int)
519-- | Information about the document as it is displayed (i.e., post-wrapping)
497-- | Information about the document as it is displayed (i.e., post-wrapping)
520data DisplayLinesWithAlignment tag = DisplayLinesWithAlignment
498data DisplayLinesWithAlignment tag = DisplayLinesWithAlignment
521− { _displayLinesWithAlignment_spans :: [[Span tag]]
499+ { _displayLinesWithAlignment_spans :: [[Span tag]]
522− , _displayLinesWithAlignment_offsetMap :: OffsetMapWithAlignment
500+ , _displayLinesWithAlignment_offsetMap :: OffsetMapWithAlignment
501+ -- cursor position relative to upper left hand corner
523− , _displayLinesWithAlignment_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
502+ , _displayLinesWithAlignment_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
525− deriving (Show)
504+ deriving (Show)
527-- | Wraps a logical line of text to fit within the given width. The first
506-- | Wraps a logical line of text to fit within the given width. The first
528-- wrapped line is offset by the number of columns provided. Subsequent wrapped
507-- wrapped line is offset by the number of columns provided. Subsequent wrapped
@@ -537,12 +516,12 @@ wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []
537wrapWithOffsetAndAlignment alignment maxWidth n text = assert (n <= maxWidth) r where
516wrapWithOffsetAndAlignment alignment maxWidth n text = assert (n <= maxWidth) r where
538 r' = splitWordsAtDisplayWidth maxWidth $ T.replicate n " " : wordsWithWhitespace text
517 r' = splitWordsAtDisplayWidth maxWidth $ T.replicate n " " : wordsWithWhitespace text
539 fmapfn (t,b) = case alignment of
518 fmapfn (t,b) = case alignment of
540− TextAlignment_Left -> (t,b,0)
519+ TextAlignment_Left -> (t,b,0)
541− TextAlignment_Right -> (t,b,maxWidth-l)
520+ TextAlignment_Right -> (t,b,maxWidth-l)
542 TextAlignment_Center -> (t,b,(maxWidth-l) `div` 2)
521 TextAlignment_Center -> (t,b,(maxWidth-l) `div` 2)
543 where l = textWidth t
522 where l = textWidth t
544 r'' = case r' of
523 r'' = case r' of
545− [] -> []
524+ [] -> []
546 (x,b):xs -> (T.drop n x,b):xs
525 (x,b):xs -> (T.drop n x,b):xs
547 r = fmap fmapfn r''
526 r = fmap fmapfn r''