@@ -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, join)
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.
@@ -243,7 +247,7 @@ displayLines width tag cursorTag (TextZipper lb b a la) =
243247 Just (c, rest) ->
244248 let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
245249 cursor = Span cursorTag (T.singleton c)
246− in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
250+ in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
247251 [] -> [[cursor]]
248252 (l:ls) -> (cursor : l) : ls
249253 in DisplayLines
@@ -297,16 +301,16 @@ splitAtWidth :: Int -> Text -> (Text, Text)
297301splitAtWidth n t@(Text arr off len)
298302 | n <= 0 = (T.empty, t)
299303 | n >= textWidth t = (t, T.empty)
300− | otherwise = let k = iterNWidth n t
304+ | otherwise = let k = toLogicalIndex n t
301305 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
306+
307+toLogicalIndex :: Int -> Text -> Int
308+toLogicalIndex n' t'@(Text _ _ len') = loop 0 0
309+ where loop !i !cnt
310+ | i >= len' || cnt + w > n' = i
311+ | otherwise = loop (i+d) (cnt + w)
312+ where Iter c d = iter t' i
313+ w = charWidth c
310314
311315-- | Takes the given number of columns of characters. For example
312316--
@@ -380,7 +384,7 @@ goToDisplayLinePosition x y dl tz =
380384 Just o ->
381385 let
382386 moveRight = case drop y $ _displayLines_spans dl of
383− [] -> x
387+ [] -> x
384388 (s:_) -> charIndexAt x . stream . mconcat . fmap (\(Span _ t) -> t) $ s
385389 in rightN (o + min moveRight x) $ top tz
386390
@@ -420,3 +424,235 @@ charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
420424 Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
421425 w = z + charWidth c
422426{-# INLINE[0] charIndexAt #-}
427+
428+
429+
430+
431+-- | Same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...])
432+-- 'Char's representing white space.
433+wordsWithWhitespace :: Text -> [Text]
434+wordsWithWhitespace t@(Text arr off len) = loop 0 0 False
435+ where
436+ loop !start !n !wasSpace
437+ | n >= len = if start == n
438+ then []
439+ else [Text arr (start+off) (n-start)]
440+ | isSpace c = loop start (n+d) True
441+ | wasSpace = Text arr (start+off) (n-start) : loop n n False
442+ | otherwise = loop start (n+d) False
443+ where Iter c d = iter t n
444+{-# INLINE wordsWithWhitespace #-}
445+
446+-- | Split words into logical lines, 'True' in the tuple indicates line ends with a whitespace character that got deleted
447+splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
448+splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
449+ appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]
450+ appendOut [] t b = [(t,b)]
451+ appendOut ((t',_):ts') t b = (t'<>t,b) : ts'
452+
453+ -- remove the last whitespace in output
454+ modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]
455+ modifyOutForNewLine [] = error "should never happen"
456+ modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of
457+ Nothing -> error "should never happen"
458+ Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace
459+
460+ loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
461+ loop [] _ out = out
462+ loop (x:xs) cumw out = r where
463+ newWidth = textWidth x + cumw
464+ r = if newWidth > maxWidth
465+ then if isSpace $ T.index x (toLogicalIndex (maxWidth - cumw) x)
466+ -- if line runs over but character of splitting is whitespace then split on the whitespace
467+ then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
468+ in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True
469+ else if cumw == 0
470+ -- single word exceeds max width, so just split on the word
471+ then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
472+ in loop (t2:xs) 0 [] <> appendOut out t1 False
473+ -- otherwise start a new line
474+ else loop (x:xs) 0 [] <> modifyOutForNewLine out
475+ else loop xs newWidth $ appendOut out x False
476+
477+data TextAlignment =
478+ TextAlignment_Left
479+ | TextAlignment_Right
480+ | TextAlignment_Center
481+ deriving (Eq, Show)
482+
483+-- A map from the index (row) of display line to
484+-- fst: leading empty spaces from left (may be negative) to adjust for alignment
485+-- snd: the text offset from the beginning of the document
486+-- to the first character of the display line
487+type OffsetMapWithAlignment = Map Int (Int, Int)
488+
489+-- | Information about the document as it is displayed (i.e., post-wrapping)
490+data DisplayLinesWithAlignment tag = DisplayLinesWithAlignment
491+ { _displayLinesWithAlignment_spans :: [[Span tag]]
492+ , _displayLinesWithAlignment_offsetMap :: OffsetMapWithAlignment
493+ -- cursor position relative to upper left hand corner
494+ , _displayLinesWithAlignment_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
495+ }
496+ deriving (Show)
497+
498+data WrappedLine = WrappedLine
499+ { _wrappedLines_text :: Text
500+ , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character
501+ , _wrappedLines_offset :: Int -- ^ offset from beginning of line
502+ }
503+ deriving (Eq, Show)
504+
505+
506+-- | Wraps a logical line of text to fit within the given width. The first
507+-- wrapped line is offset by the number of columns provided. Subsequent wrapped
508+-- lines are not.
509+wrapWithOffsetAndAlignment
510+ :: TextAlignment
511+ -> Int -- ^ Maximum width
512+ -> Int -- ^ Offset for first line
513+ -> Text -- ^ Text to be wrapped
514+ -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line)
515+wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []
516+wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where
517+ r' = splitWordsAtDisplayWidth maxWidth $ T.replicate n " " : wordsWithWhitespace txt
518+ fmapfn (t,b) = case alignment of
519+ TextAlignment_Left -> WrappedLine t b 0
520+ TextAlignment_Right -> WrappedLine t b (maxWidth-l)
521+ TextAlignment_Center -> WrappedLine t b ((maxWidth-l) `div` 2)
522+ where l = textWidth t
523+ r'' = case r' of
524+ [] -> []
525+ (x,b):xs -> (T.drop n x,b):xs
526+ r = fmap fmapfn r''
527+
528+-- converts deleted eol spaces into logical lines
529+eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]
530+eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . join . fmap (L.groupBy (\(WrappedLine _ b _) _ -> not b))
531+
532+offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
533+offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines
534+
535+offsetMapWithAlignment
536+ :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines
537+ -> OffsetMapWithAlignment
538+offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0)
539+ where
540+ offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
541+ maps <- forM x $ \(line,align) -> do
542+ let l = T.length line
543+ (dl, o) <- get
544+ put (dl + 1, o + l)
545+ return $ Map.singleton dl (align, o)
546+ (dl, o) <- get
547+ put (dl, o + 1)
548+ -- add additional offset to last line in wrapped lines (for newline char)
549+ return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps
550+
551+
552+-- | Given a width and a 'TextZipper', produce a list of display lines
553+-- (i.e., lines of wrapped text) with special attributes applied to
554+-- certain segments (e.g., the cursor). Additionally, produce the current
555+-- y-coordinate of the cursor and a mapping from display line number to text
556+-- offset
557+displayLinesWithAlignment
558+ :: (Show tag) => TextAlignment
559+ -> Int -- ^ Width, used for wrapping
560+ -> tag -- ^ Metadata for normal characters
561+ -> tag -- ^ Metadata for the cursor
562+ -> TextZipper -- ^ The text input contents and cursor state
563+ -> DisplayLinesWithAlignment tag
564+displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =
565+ let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line
566+ linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb
567+ linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line
568+ linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la
569+ offsets :: OffsetMapWithAlignment
570+ offsets = offsetMapWithAlignmentInternal $ mconcat
571+ [ linesBefore
572+ , [wrapWithOffsetAndAlignment alignment width 0 $ b <> a]
573+ , linesAfter
574+ ]
575+ flattenLines = concatMap (fmap _wrappedLines_text)
576+ spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore
577+ spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter
578+ -- Separate the spans before the cursor into
579+ -- * spans that are on earlier display lines (though on the same logical line), and
580+ -- * spans that are on the same display line
581+
582+ -- TODO cursor goes here if align right
583+ (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
584+ initLast $ map ((:[]) . Span tag) $ fmap _wrappedLines_text $ (wrapWithOffsetAndAlignment alignment width 0 b)
585+ -- Calculate the number of columns on the cursor's display line before the cursor
586+ curLineOffset = spansWidth spansCurLineBefore
587+ -- Check whether the spans on the current display line are long enough that
588+ -- the cursor has to go to the next line
589+ cursorAfterEOL = curLineOffset == width
590+ cursorCharWidth = case T.uncons a of
591+ Nothing -> 1
592+ Just (c, _) -> charWidth c
593+
594+ -- Separate the span after the cursor into
595+ -- * spans that are on the same display line, and
596+ -- * spans that are on later display lines (though on the same logical line)
597+
598+ -- TODO do not show cursor if align right
599+ (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
600+ headTail $ case T.uncons a of
601+ Nothing -> [[Span cursorTag " "]]
602+ Just (c, rest) ->
603+ let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
604+ cursor = Span cursorTag (T.singleton c)
605+ in case map ((:[]) . Span tag) $ fmap _wrappedLines_text $ (wrapWithOffsetAndAlignment alignment width o rest) of
606+ [] -> [[cursor]]
607+ (l:ls) -> (cursor : l) : ls
608+
609+ cursorY = sum
610+ [ length spansBefore
611+ , length spansCurrentBefore
612+ , if cursorAfterEOL then 1 else 0
613+ ]
614+ -- a little silly to convert back to text but whatever, it works
615+ cursorX = if cursorAfterEOL then 0 else textWidth (mconcat $ fmap (\(Span _ t) -> t) spansCurLineBefore)
616+
617+ in DisplayLinesWithAlignment
618+ { _displayLinesWithAlignment_spans = concat
619+ [ spansBefore
620+ , spansCurrentBefore
621+ , if cursorAfterEOL
622+ then [ spansCurLineBefore, spansCurLineAfter ]
623+ else [ spansCurLineBefore <> spansCurLineAfter ]
624+ , spansCurrentAfter
625+ , spansAfter
626+ ]
627+ , _displayLinesWithAlignment_offsetMap = offsets
628+ , _displayLinesWithAlignment_cursorPos = (cursorX, cursorY)
629+ }
630+ where
631+ initLast :: [a] -> Maybe ([a], a)
632+ initLast = \case
633+ [] -> Nothing
634+ (x:xs) -> case initLast xs of
635+ Nothing -> Just ([], x)
636+ Just (ys, y) -> Just (x:ys, y)
637+ headTail :: [a] -> Maybe (a, [a])
638+ headTail = \case
639+ [] -> Nothing
640+ x:xs -> Just (x, xs)
641+
642+
643+-- | Move the cursor of the given 'TextZipper' to the logical position indicated
644+-- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'
645+-- information. If the x coordinate is beyond the end of a line, the cursor is
646+-- moved to the end of the line.
647+goToDisplayLineWithAlignmentPosition :: Int -> Int -> DisplayLinesWithAlignment tag -> TextZipper -> TextZipper
648+goToDisplayLineWithAlignmentPosition x y dl tz =
649+ let offset = Map.lookup y $ _displayLinesWithAlignment_offsetMap dl
650+ in case offset of
651+ Nothing -> tz
652+ Just (alignOff,o) ->
653+ let
654+ trueX = max 0 (x - alignOff)
655+ moveRight = case drop y $ _displayLinesWithAlignment_spans dl of
656+ [] -> 0
657+ (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s
658+ in rightN (o + moveRight) $ top tz