@@ -1,5 +1,8 @@
1+-- | forked from reflex-vty-0.1.4.1
2+-- adds alignment support
3+
14{-|
2−Module: Data.Text.Zipper
5+Module: Potato.Data.Text.Zipper
36Description: A zipper for text documents that allows convenient editing and navigation
47
58'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,25 +10,33 @@ Description: A zipper for text documents that allows convenient editing and navi
710'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.
811
912-}
10−{-# LANGUAGE BangPatterns #-}
11−{-# LANGUAGE FlexibleContexts #-}
12−{-# LANGUAGE LambdaCase #-}
13+{-# LANGUAGE BangPatterns #-}
14+{-# LANGUAGE FlexibleContexts #-}
15+{-# LANGUAGE LambdaCase #-}
1316{-# LANGUAGE OverloadedStrings #-}
17+
1418module Data.Text.Zipper where
1519
16−import Data.Char (isSpace)
17−import Data.Map (Map)
18−import qualified Data.Map as Map
19−import Data.Maybe (fromMaybe)
20−import Data.String
21−import Control.Monad.State (evalState, forM, get, put)
20+import Prelude
21+
22+import Control.Exception (assert)
23+import Control.Monad (join)
24+import Control.Monad.State (evalState, forM, get, put)
25+import Data.Char (isSpace)
26+import Data.Map (Map)
27+import qualified Data.Map as Map
28+import Data.Maybe (fromMaybe)
29+import Data.String
30+
31+import qualified Data.List as L
32+import Data.Text (Text)
33+import qualified Data.Text as T
34+import Data.Text.Internal (Text (..), text)
35+import Data.Text.Internal.Fusion (stream)
36+import Data.Text.Internal.Fusion.Types (Step (..), Stream (..))
37+import Data.Text.Unsafe
38+import Data.Tuple.Extra
2239
23−import Data.Text (Text)
24−import qualified Data.Text as T
25−import Data.Text.Internal (Text(..), text)
26−import Data.Text.Internal.Fusion (stream)
27−import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
28−import Data.Text.Unsafe
2940
3041import Graphics.Text.Width (wcwidth)
3142
@@ -247,7 +258,7 @@ displayLines width tag cursorTag (TextZipper lb b a la) =
247258 Just (c, rest) ->
248259 let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
249260 cursor = Span cursorTag (T.singleton c)
250− in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
261+ in case map ((:[]) . Span tag) (wrapWithOffset width o rest) of
251262 [] -> [[cursor]]
252263 (l:ls) -> (cursor : l) : ls
253264 in DisplayLines
@@ -264,7 +275,7 @@ displayLines width tag cursorTag (TextZipper lb b a la) =
264275 , _displayLines_cursorY = sum
265276 [ length spansBefore
266277 , length spansCurrentBefore
267− , if cursorAfterEOL then 1 else 0
278+ , if cursorAfterEOL then cursorCharWidth else 0
268279 ]
269280 }
270281 where
@@ -301,16 +312,16 @@ splitAtWidth :: Int -> Text -> (Text, Text)
301312splitAtWidth n t@(Text arr off len)
302313 | n <= 0 = (T.empty, t)
303314 | n >= textWidth t = (t, T.empty)
304− | otherwise = let k = iterNWidth n t
315+ | otherwise = let k = toLogicalIndex n t
305316 in (text arr off k, text arr (off+k) (len-k))
306− where
307− iterNWidth :: Int -> Text -> Int
308− iterNWidth 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
317+
318+toLogicalIndex :: Int -> Text -> Int
319+toLogicalIndex n' t'@(Text _ _ len') = loop 0 0
320+ where loop !i !cnt
321+ | i >= len' || cnt + w > n' = i
322+ | otherwise = loop (i+d) (cnt + w)
323+ where Iter c d = iter t' i
324+ w = charWidth c
314325
315326-- | Takes the given number of columns of characters. For example
316327--
@@ -424,3 +435,245 @@ charIndexAt pos (Stream next s0 _len) = loop_length 0 0 s0
424435 Yield c s' -> if w > pos then i else loop_length (i+1) w s' where
425436 w = z + charWidth c
426437{-# INLINE[0] charIndexAt #-}
438+
439+
440+
441+
442+
443+
444+
445+
446+
447+
448+
449+
450+
451+
452+
453+
454+
455+
456+
457+
458+
459+
460+-- NEW TEXT ALIGNMENT STUFF BELOW
461+
462+
463+-- same as T.words except whitespace characters are included at end (i.e. ["line1 ", ...])
464+-- 'Char's representing white space.
465+wordsWithWhitespace :: Text -> [Text]
466+wordsWithWhitespace t@(Text arr off len) = loop 0 0 False
467+ where
468+ loop !start !n !wasSpace
469+ | n >= len = if start == n
470+ then []
471+ else [Text arr (start+off) (n-start)]
472+ | isSpace c = loop start (n+d) True
473+ | wasSpace = Text arr (start+off) (n-start) : loop n n False
474+ | otherwise = loop start (n+d) False
475+ where Iter c d = iter t n
476+{-# INLINE wordsWithWhitespace #-}
477+
478+-- TODO Check that this handles EOL space/newline stuff correctly
479+-- take sum of word length, returns True if ends with trailng space
480+splitWordsAtDisplayWidth :: Int -> [Text] -> [(Text, Bool)]
481+splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
482+ appendOut :: [(Text,Bool)] -> Text -> Bool -> [(Text,Bool)]
483+ appendOut [] t b = [(t,b)]
484+ appendOut ((t',_):ts') t b = (t'<>t,b) : ts'
485+
486+ -- remove the last whitespace in output
487+ modifyOutForNewLine :: [(Text,Bool)] -> [(Text,Bool)]
488+ modifyOutForNewLine [] = error "should never happen"
489+ modifyOutForNewLine ((t',_):ts) = case T.unsnoc t' of
490+ Nothing -> error "should never happen"
491+ Just (t,lastChar) -> assert (isSpace lastChar) $ (t,True):ts -- assume last char is whitespace
492+
493+ loop :: [Text] -> Int -> [(Text,Bool)] -> [(Text,Bool)]
494+ loop [] _ out = out
495+ loop (x:xs) cumw out = r where
496+ newWidth = textWidth x + cumw
497+ r = if newWidth > maxWidth
498+ then if isSpace $ T.index x (toLogicalIndex (maxWidth - cumw) x)
499+ -- if line runs over but character of splitting is whitespace then split on the whitespace
500+ then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
501+ in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True
502+ else if cumw == 0
503+ -- single word exceeds max width, so just split on the word
504+ then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
505+ in loop (t2:xs) 0 [] <> appendOut out t1 False
506+
507+ -- otherwise start a new line
508+ else loop (x:xs) 0 [] <> modifyOutForNewLine out
509+ else loop xs newWidth $ appendOut out x False
510+
511+data TextAlignment = TextAlignment_Left | TextAlignment_Right | TextAlignment_Center
512+
513+-- A map from the index (row) of display line to
514+-- fst: leading empty spaces from left (may be negative) to adjust for alignment
515+-- snd: the text offset from the beginning of the document
516+-- to the first character of the display line
517+type OffsetMapWithAlignment = Map Int (Int, Int)
518+
519+-- | Information about the document as it is displayed (i.e., post-wrapping)
520+data DisplayLinesWithAlignment tag = DisplayLinesWithAlignment
521+ { _displayLinesWithAlignment_spans :: [[Span tag]]
522+ , _displayLinesWithAlignment_offsetMap :: OffsetMapWithAlignment
523+ , _displayLinesWithAlignment_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
524+ }
525+ deriving (Show)
526+
527+-- | 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
529+-- lines are not.
530+wrapWithOffsetAndAlignment
531+ :: TextAlignment
532+ -> Int -- ^ Maximum width
533+ -> Int -- ^ Offset for first line
534+ -> Text -- ^ Text to be wrapped
535+ -> [(Text,Bool,Int)] -- (words on that line, hidden space char, offset from beginning of line)
536+wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []
537+wrapWithOffsetAndAlignment alignment maxWidth n text = assert (n <= maxWidth) r where
538+ r' = splitWordsAtDisplayWidth maxWidth $ T.replicate n " " : wordsWithWhitespace text
539+ fmapfn (t,b) = case alignment of
540+ TextAlignment_Left -> (t,b,0)
541+ TextAlignment_Right -> (t,b,maxWidth-l)
542+ TextAlignment_Center -> (t,b,(maxWidth-l) `div` 2)
543+ where l = textWidth t
544+ r'' = case r' of
545+ [] -> []
546+ (x,b):xs -> (T.drop n x,b):xs
547+ r = fmap fmapfn r''
548+
549+-- converts deleted eol spaces into logical lines
550+eolSpacesToLogicalLines :: [[(Text, Bool, Int)]] -> [[(Text, Int)]]
551+eolSpacesToLogicalLines = fmap (fmap (\(a, b, c) -> (a,c))) . join . fmap (L.groupBy (\(_,b,_) _ -> not b))
552+
553+offsetMapWithAlignmentInternal :: [[(Text, Bool, Int)]] -> OffsetMapWithAlignment
554+offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines
555+
556+offsetMapWithAlignment
557+ :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines
558+ -> OffsetMapWithAlignment
559+offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0)
560+ where
561+ offsetMap' xs = fmap Map.unions $ forM xs $ \x -> do
562+ maps <- forM x $ \(line,align) -> do
563+ let l = T.length line
564+ (dl, o) <- get
565+ put (dl + 1, o + l)
566+ return $ Map.singleton dl (align, o)
567+ (dl, o) <- get
568+ put (dl, o + 1)
569+ -- add additional offset to last line in wrapped lines (for newline char)
570+ return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps
571+
572+
573+-- | Given a width and a 'TextZipper', produce a list of display lines
574+-- (i.e., lines of wrapped text) with special attributes applied to
575+-- certain segments (e.g., the cursor). Additionally, produce the current
576+-- y-coordinate of the cursor and a mapping from display line number to text
577+-- offset
578+displayLinesWithAlignment
579+ :: (Show tag) => TextAlignment
580+ -> Int -- ^ Width, used for wrapping
581+ -> tag -- ^ Metadata for normal characters
582+ -> tag -- ^ Metadata for the cursor
583+ -> TextZipper -- ^ The text input contents and cursor state
584+ -> DisplayLinesWithAlignment tag
585+displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =
586+ let linesBefore :: [[(Text, Bool, Int)]] -- The wrapped lines before the cursor line
587+ linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb
588+ linesAfter :: [[(Text, Bool, Int)]] -- The wrapped lines after the cursor line
589+ linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la
590+ offsets :: OffsetMapWithAlignment
591+ offsets = offsetMapWithAlignmentInternal $ mconcat
592+ [ linesBefore
593+ , [wrapWithOffsetAndAlignment alignment width 0 $ b <> a]
594+ , linesAfter
595+ ]
596+ flattenLines = concatMap (fmap fst3)
597+ spansBefore = map ((:[]) . Span tag) $ flattenLines linesBefore
598+ spansAfter = map ((:[]) . Span tag) $ flattenLines linesAfter
599+ -- Separate the spans before the cursor into
600+ -- * spans that are on earlier display lines (though on the same logical line), and
601+ -- * spans that are on the same display line
602+
603+ -- TODO cursor goes here if align right
604+ (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
605+ initLast $ map ((:[]) . Span tag) $ fmap fst3 $ (wrapWithOffsetAndAlignment alignment width 0 b)
606+ -- Calculate the number of columns on the cursor's display line before the cursor
607+ curLineOffset = spansWidth spansCurLineBefore
608+ -- Check whether the spans on the current display line are long enough that
609+ -- the cursor has to go to the next line
610+ cursorAfterEOL = curLineOffset == width
611+ cursorCharWidth = case T.uncons a of
612+ Nothing -> 1
613+ Just (c, _) -> charWidth c
614+
615+ -- Separate the span after the cursor into
616+ -- * spans that are on the same display line, and
617+ -- * spans that are on later display lines (though on the same logical line)
618+
619+ -- TODO do not show cursor if align right
620+ (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
621+ headTail $ case T.uncons a of
622+ Nothing -> [[Span cursorTag " "]]
623+ Just (c, rest) ->
624+ let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
625+ cursor = Span cursorTag (T.singleton c)
626+ in case map ((:[]) . Span tag) $ fmap fst3 $ (wrapWithOffsetAndAlignment alignment width o rest) of
627+ [] -> [[cursor]]
628+ (l:ls) -> (cursor : l) : ls
629+
630+ cursorY = sum
631+ [ length spansBefore
632+ , length spansCurrentBefore
633+ , if cursorAfterEOL then 1 else 0
634+ ]
635+ -- a little silly to convert back to text but whatever, it works
636+ cursorX = if cursorAfterEOL then 0 else textWidth (mconcat $ fmap (\(Span _ t) -> t) spansCurLineBefore)
637+
638+ in DisplayLinesWithAlignment
639+ { _displayLinesWithAlignment_spans = concat
640+ [ spansBefore
641+ , spansCurrentBefore
642+ , if cursorAfterEOL
643+ then [ spansCurLineBefore, spansCurLineAfter ]
644+ else [ spansCurLineBefore <> spansCurLineAfter ]
645+ , spansCurrentAfter
646+ , spansAfter
647+ ]
648+ , _displayLinesWithAlignment_offsetMap = offsets
649+ , _displayLinesWithAlignment_cursorPos = (cursorX, cursorY)
650+ }
651+ where
652+ initLast :: [a] -> Maybe ([a], a)
653+ initLast = \case
654+ [] -> Nothing
655+ (x:xs) -> case initLast xs of
656+ Nothing -> Just ([], x)
657+ Just (ys, y) -> Just (x:ys, y)
658+ headTail :: [a] -> Maybe (a, [a])
659+ headTail = \case
660+ [] -> Nothing
661+ x:xs -> Just (x, xs)
662+
663+
664+-- | Move the cursor of the given 'TextZipper' to the logical position indicated
665+-- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'
666+-- information. If the x coordinate is beyond the end of a line, the cursor is
667+-- moved to the end of the line.
668+goToDisplayLineWithAlignmentPosition :: Int -> Int -> DisplayLinesWithAlignment tag -> TextZipper -> TextZipper
669+goToDisplayLineWithAlignmentPosition x y dl tz =
670+ let offset = Map.lookup y $ _displayLinesWithAlignment_offsetMap dl
671+ in case offset of
672+ Nothing -> tz
673+ Just (alignOff,o) ->
674+ let
675+ trueX = max 0 (x - alignOff)
676+ moveRight = case drop y $ _displayLinesWithAlignment_spans dl of
677+ [] -> 0
678+ (s:_) -> charIndexAt trueX . stream . mconcat . fmap (\(Span _ t) -> t) $ s
679+ in rightN (o + moveRight) $ top tz