Fix several issues in Zipper.hs

ChangeLog.md

@@ -1,5 +1,9 @@
 # Revision history for reflex-vty
 
+## Unreleased
+
+* Fix several issues with wide chars, cursor position and word wrapping in Zipper.hs
+
 ## 0.4.1.1
 
 * Support ghc-9.6
@@ -18,7 +22,7 @@
     * Mouse drag sequences that start ON the region and drag off ARE reported
     * Introduce `MonadHold` constraint to `pane`
   * Added `MonadHold` constraint to several methods that use `pane`
-  
+
 ## 0.3.1.1
 
 * Loosen version bounds and support GHC 9.4

src/Data/Text/Zipper.hs

@@ -9,25 +9,21 @@ Description: A zipper for text documents that allows convenient editing and navi
 -}
 module Data.Text.Zipper where
 
-import           Prelude
-
 import Control.Exception (assert)
+import Control.Monad
+import Control.Monad.State (evalState, get, put)
 import Data.Char (isSpace)
 import Data.Map (Map)
-import Data.Maybe (fromMaybe)
 import Data.String
-import Control.Monad
-import Control.Monad.Fix
-import Control.Monad.State (evalState, get, put)
 
+import qualified Data.List as L
+import qualified Data.Map as Map
 import Data.Text (Text)
+import qualified Data.Text as T
 import Data.Text.Internal (Text(..), text)
 import Data.Text.Internal.Fusion (stream)
-import Data.Text.Internal.Fusion.Types (Stream(..), Step(..))
+import Data.Text.Internal.Fusion.Types (Step(..), Stream(..))
 import Data.Text.Unsafe
-import qualified Data.List as L
-import qualified Data.Map as Map
-import qualified Data.Text as T
 
 import Graphics.Text.Width (wcwidth)
 
@@ -44,7 +40,7 @@ data TextZipper = TextZipper
   , _textZipper_after :: Text -- The cursor is on top of the first character of this text
   , _textZipper_linesAfter :: [Text]
   }
-  deriving (Show)
+  deriving (Show, Eq)
 
 instance IsString TextZipper where
   fromString = fromText . T.pack
@@ -194,7 +190,7 @@ fromText = flip insert empty
 -- | A span of text tagged with some metadata that makes up part of a display
 -- line.
 data Span tag = Span tag Text
-  deriving (Show)
+  deriving (Eq, Show)
 
 -- | Text alignment type
 data TextAlignment =
@@ -203,13 +199,13 @@ data TextAlignment =
   | TextAlignment_Center
   deriving (Eq, Show)
 
--- A map from the index (row) of display line to (fst,snd)
+-- | A map from the index (row) of display line to (fst,snd)
 -- fst: leading empty spaces from left (may be negative) to adjust for alignment
 -- snd: the text offset from the beginning of the document
 -- to the first character of the display line
 type OffsetMapWithAlignment = Map Int (Int, Int)
 
--- helper type representing a single visual line that may be part of a wrapped logical line
+-- | Helper type representing a single visual line that may be part of a wrapped logical line
 data WrappedLine = WrappedLine
   { _wrappedLines_text :: Text
   , _wrappedLines_hiddenWhitespace :: Bool -- ^ 'True' if this line ends with a deleted whitespace character
@@ -218,12 +214,14 @@ data WrappedLine = WrappedLine
   deriving (Eq, Show)
 
 -- | Information about the document as it is displayed (i.e., post-wrapping)
-data DisplayLines tag = DisplayLines
-  { _displayLines_spans :: [[Span tag]]
-  , _displayLines_offsetMap :: OffsetMapWithAlignment
-  , _displayLines_cursorPos :: (Int, Int) -- cursor position relative to upper left hand corner
+data DisplayLines tag = DisplayLines {
+    _displayLines_spans :: [[Span tag]]
+    -- ^ NOTE this will contain a dummy space character if the cursor is at the end
+    , _displayLines_offsetMap :: OffsetMapWithAlignment
+    -- ^ NOTE this will not include offsets for the y position of dummy ' ' character if it is on its own line
+    , _displayLines_cursorPos :: (Int, Int) -- ^ cursor position relative to upper left hand corner
   }
-  deriving (Show)
+  deriving (Eq, Show)
 
 -- | Split a 'Text' at the given column index. For example
 --
@@ -234,16 +232,29 @@ splitAtWidth :: Int -> Text -> (Text, Text)
 splitAtWidth n t@(Text arr off len)
     | n <= 0 = (T.empty, t)
     | n >= textWidth t = (t, T.empty)
-    | otherwise = let k = toLogicalIndex n t
+    | otherwise = let k = characterIndexFromWidth n t
                   in (text arr off k, text arr (off+k) (len-k))
 
-toLogicalIndex :: Int -> Text -> Int
-toLogicalIndex n' t'@(Text _ _ len') = loop 0 0
-  where loop !i !cnt
-            | i >= len' || cnt + w > n' = i
-            | otherwise = loop (i+d) (cnt + w)
-          where Iter c d = iter t' i
-                w = charWidth c
+-- | Convert a physical width index to a character index. For example, the
+-- physical index 3 of the string "ᄀabc" corresponds to the character index 2,
+-- because the first character has a width of 2.
+characterIndexFromWidth :: Int -> Text -> Int
+characterIndexFromWidth n' t'@(Text _ _ len') = loop 0 0 0
+  where
+    loop
+      :: Int -- Byte index of the 'Text' we're traversing
+      -> Int -- The accumulated logical index so far
+      -> Int -- The accumulated physical width
+      -> Int -- The new logical index
+    loop !bytes !li !cumw
+        -- if we've gone past the last byte
+        | bytes >= len' = li-1
+        -- if we hit our target
+        | cumw + w > n' = li
+        -- advance one character
+        | otherwise = loop (bytes+byteWidth) (li+1) (cumw + w)
+      where Iter c byteWidth = iter t' bytes
+            w = charWidth c
 
 -- | Takes the given number of columns of characters. For example
 --
@@ -343,7 +354,7 @@ splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
   loop (x:xs) cumw out = r where
     newWidth = textWidth x + cumw
     r = if newWidth > maxWidth
-      then if isSpace $ T.index x (toLogicalIndex (maxWidth - cumw) x)
+      then if isSpace $ T.index x (characterIndexFromWidth (maxWidth - cumw) x)
         -- if line runs over but character of splitting is whitespace then split on the whitespace
         then let (t1,t2) = splitAtWidth (maxWidth - cumw) x
           in loop (T.drop 1 t2:xs) 0 [] <> appendOut out t1 True
@@ -355,7 +366,19 @@ splitWordsAtDisplayWidth maxWidth wwws = reverse $ loop wwws 0 [] where
           else loop (x:xs) 0 [] <> modifyOutForNewLine out
       else loop xs newWidth $ appendOut out x False
 
-
+-- | Calculate the offset that will result in rendered text being aligned left,
+-- right, or center
+alignmentOffset
+  :: TextAlignment
+  -> Int
+  -> Text
+  -> Int
+alignmentOffset alignment maxWidth t = case alignment of
+  TextAlignment_Left   -> 0
+  TextAlignment_Right  -> (maxWidth - l)
+  TextAlignment_Center -> (maxWidth - l) `div` 2
+  where
+    l = textWidth t
 
 -- | Wraps a logical line of text to fit within the given width. The first
 -- wrapped line is offset by the number of columns provided. Subsequent wrapped
@@ -368,25 +391,22 @@ wrapWithOffsetAndAlignment
   -> [WrappedLine] -- (words on that line, hidden space char, offset from beginning of line)
 wrapWithOffsetAndAlignment _ maxWidth _ _ | maxWidth <= 0 = []
 wrapWithOffsetAndAlignment alignment maxWidth n txt = assert (n <= maxWidth) r where
-  -- 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
-  r' = splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)
-  fmapfn (t,b) = case alignment of
-    TextAlignment_Left   -> WrappedLine t b 0
-    TextAlignment_Right  -> WrappedLine t b (maxWidth-l)
-    TextAlignment_Center -> WrappedLine t b ((maxWidth-l) `div` 2)
-    where l = textWidth t
+  r' = if T.null txt
+    then [("",False)]
+    -- I'm not sure why this is working, the "." padding will mess up splitWordsAtDisplayWidth for the next line if a single line exceeds the display width (but it doesn't)
+    -- it should be `T.replicate n " "` instead (which also works but makes an extra "" Wrappedline somewhere)
+    else splitWordsAtDisplayWidth maxWidth $ wordsWithWhitespace ( T.replicate n "." <> txt)
+  fmapfn (t,b) = WrappedLine t b $ alignmentOffset alignment maxWidth t
   r'' =  case r' of
     []       -> []
     (x,b):xs -> (T.drop n x,b):xs
   r = fmap fmapfn r''
 
--- converts deleted eol spaces into logical lines
+-- | converts deleted eol spaces into logical lines
 eolSpacesToLogicalLines :: [[WrappedLine]] -> [[(Text, Int)]]
-eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) .  concatMap (L.groupBy (\(WrappedLine _ b _) _ -> not b))
-
-offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
-offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines
+eolSpacesToLogicalLines = fmap (fmap (\(WrappedLine a _ c) -> (a,c))) . ((L.groupBy (\(WrappedLine _ b _) _ -> not b)) =<<)
 
+-- | Convert logical lines to a map of displayed rows of aligned text
 offsetMapWithAlignment
   :: [[(Text, Int)]] -- ^ The outer list represents logical lines, inner list represents wrapped lines
   -> OffsetMapWithAlignment
@@ -403,6 +423,9 @@ offsetMapWithAlignment ts = evalState (offsetMap' ts) (0, 0)
       -- add additional offset to last line in wrapped lines (for newline char)
       return $ Map.adjust (\(align,_)->(align,o+1)) dl $ Map.unions maps
 
+-- | Convert logical lines to a map of displayed rows of aligned text
+offsetMapWithAlignmentInternal :: [[WrappedLine]] -> OffsetMapWithAlignment
+offsetMapWithAlignmentInternal = offsetMapWithAlignment . eolSpacesToLogicalLines
 
 -- | Given a width and a 'TextZipper', produce a list of display lines
 -- (i.e., lines of wrapped text) with special attributes applied to
@@ -417,7 +440,8 @@ displayLinesWithAlignment
   -> TextZipper -- ^ The text input contents and cursor state
   -> DisplayLines tag
 displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =
-  let linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line
+  let
+      linesBefore :: [[WrappedLine]] -- The wrapped lines before the cursor line
       linesBefore = map (wrapWithOffsetAndAlignment alignment width 0) $ reverse lb
       linesAfter :: [[WrappedLine]] -- The wrapped lines after the cursor line
       linesAfter = map (wrapWithOffsetAndAlignment alignment width 0) la
@@ -437,75 +461,61 @@ displayLinesWithAlignment alignment width tag cursorTag (TextZipper lb b a la) =
       -- * spans that are on earlier display lines (though on the same logical line), and
       -- * spans that are on the same display line
 
-      (spansCurrentBefore, spansCurLineBefore) = fromMaybe ([], []) $
-        initLast $ map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width 0 b)
-      -- Calculate the number of columns on the cursor's display line before the cursor
-      curLineOffset = spansWidth spansCurLineBefore
-      -- Check whether the spans on the current display line are long enough that
-      -- the cursor has to go to the next line
-      cursorAfterEOL = curLineOffset == width
-      cursorCharWidth = case T.uncons a of
-        Nothing     -> 1
-        Just (c, _) -> charWidth c
-
-      -- Separate the span after the cursor into
-      -- * spans that are on the same display line, and
-      -- * spans that are on later display lines (though on the same logical line)
-
-      (spansCurLineAfter, spansCurrentAfter) = fromMaybe ([], []) $
-        headTail $ case T.uncons a of
-          Nothing -> [[Span cursorTag " "]]
-          Just (c, rest) ->
-            let o = if cursorAfterEOL then cursorCharWidth else curLineOffset + cursorCharWidth
-                cursor = Span cursorTag (T.singleton c)
-            in case map ((:[]) . Span tag) $ _wrappedLines_text <$> (wrapWithOffsetAndAlignment alignment width o rest) of
-                  []     -> [[cursor]]
-                  (l:ls) -> (cursor : l) : ls
-
-      curLineSpanNormalCase = if cursorAfterEOL
-        then [ spansCurLineBefore, spansCurLineAfter ]
-        else [ spansCurLineBefore <> spansCurLineAfter ]
-
-      -- for right alignment, we want draw the cursor tag to be on the character just before the logical cursor position
-      curLineSpan = if alignment == TextAlignment_Right && not cursorAfterEOL
-        then case reverse spansCurLineBefore of
-          [] -> curLineSpanNormalCase
-          (Span _ x):xs -> case spansCurLineAfter of
-            [] -> error "should not be possible" -- curLineSpanNormalCase
-            (Span _ y):ys -> [reverse (Span cursorTag x:xs) <> ((Span tag y):ys)]
-        else curLineSpanNormalCase
-
-      cursorY = sum
-        [ length spansBefore
-        , length spansCurrentBefore
-        , if cursorAfterEOL then 1 else 0
-        ]
-      -- a little silly to convert back to text but whatever, it works
-      cursorX = if cursorAfterEOL then 0 else textWidth (mconcat $ fmap (\(Span _ t) -> t) spansCurLineBefore)
+      -- do the current line
+      curlinetext = b <> a
+      curwrappedlines = (wrapWithOffsetAndAlignment alignment width 0 curlinetext)
+      blength = T.length b
+
+      -- map to spans and highlight the cursor
+      -- accumulator type (accumulated text length, Either (current y position) (cursor y and x position))
+      --mapaccumlfn :: (Int, Either Int (Int, Int)) -> WrappedLine -> ((Int, Either Int (Int, Int)), [Span tag])
+      mapaccumlfn (acclength, ecpos') (WrappedLine t dwseol xoff) = r where
+        tlength = T.length t
+        -- how many words we've gone through
+        nextacclength = acclength + tlength + if dwseol then 1 else 0
+        nextacc = (nextacclength, nextecpos)
+        cursoroncurspan = nextacclength >= blength && (blength >= acclength)
+        charsbeforecursor = blength-acclength
+        ctlength = textWidth $ T.take charsbeforecursor t
+        cursorx = xoff + ctlength
+        nextecpos = case ecpos' of
+          Left y -> if cursoroncurspan
+            then if ctlength == width
+              -- cursor wraps to next line case
+              then Right (y+1, 0)
+              else Right (y, cursorx)
+            else Left (y+1)
+          Right x -> Right x
+
+        beforecursor = T.take charsbeforecursor t
+        cursortext = T.take 1 $ T.drop charsbeforecursor t
+        aftercursor = T.drop (charsbeforecursor+1) t
+
+        cursorspans = [Span tag beforecursor, Span cursorTag cursortext] <> if T.null aftercursor then [] else [Span tag aftercursor]
+
+        r = if cursoroncurspan
+          then (nextacc, cursorspans)
+          else (nextacc, [Span tag t])
+      ((_, ecpos), curlinespans) = if T.null curlinetext
+        -- manually handle empty case because mapaccumlfn doesn't handle it
+        then ((0, Right (0, alignmentOffset alignment width "")), [[Span tag ""]])
+        else L.mapAccumL mapaccumlfn (0, Left 0) curwrappedlines
+
+      (cursorY', cursorX) = case ecpos of
+        Right (y,x) -> (y,x)
+        -- if we never hit the cursor position, this means it's at the beginning of the next line
+        Left y -> (y+1, alignmentOffset alignment width "")
+      cursorY = cursorY' + length spansBefore
 
   in  DisplayLines
         { _displayLines_spans = concat
           [ spansBefore
-          , spansCurrentBefore
-          , curLineSpan
-          , spansCurrentAfter
+          , curlinespans
           , spansAfter
           ]
         , _displayLines_offsetMap = offsets
         , _displayLines_cursorPos = (cursorX, cursorY)
         }
-  where
-    initLast :: [a] -> Maybe ([a], a)
-    initLast = \case
-      [] -> Nothing
-      (x:xs) -> case initLast xs of
-        Nothing      -> Just ([], x)
-        Just (ys, y) -> Just (x:ys, y)
-    headTail :: [a] -> Maybe (a, [a])
-    headTail = \case
-      [] -> Nothing
-      x:xs -> Just (x, xs)
-
 
 -- | Move the cursor of the given 'TextZipper' to the logical position indicated
 -- by the given display line coordinates, using the provided 'DisplayLinesWithAlignment'

src/Reflex/Vty/Widget.hs

@@ -232,7 +232,7 @@ inputInFocusedRegion = do
       return $ case e of
         V.EvKey _ _ | not focused -> Nothing
         V.EvMouseDown x y btn m ->
-          if tracking == Tracking btn || (tracking == WaitingForInput && isWithin reg' x y)
+          if tracking == Tracking btn || (tracking == WaitingForInput && withinRegion reg' x y)
             then Just (Tracking btn, Just $ V.EvMouseDown (x - l) (y - t) btn m)
             else Just (NotTracking, Nothing)
         V.EvMouseUp x y mbtn -> case mbtn of
@@ -268,11 +268,20 @@ nilRegion = Region 0 0 0 0
 regionSize :: Region -> (Int, Int)
 regionSize (Region _ _ w h) = (w, h)
 
-isWithin :: Region -> Int -> Int -> Bool
-isWithin (Region l t w h) x y = not . or $ [ x < l
-                                           , y < t
-                                           , x >= l + w
-                                           , y >= t + h ]
+-- | Check whether the x,y coordinates are within the specified region
+withinRegion
+  :: Region
+  -> Int
+  -- ^ x-coordinate
+  -> Int
+  -- ^ y-coordinate
+  -> Bool
+withinRegion (Region l t w h) x y = not . or $
+  [ x < l
+  , y < t
+  , x >= l + w
+  , y >= t + h
+  ]
 
 -- | Produces an 'Image' that fills a region with space characters
 regionBlankImage :: V.Attr -> Region -> Image

src/Reflex/Vty/Widget/Layout.hs

@@ -9,7 +9,6 @@ module Reflex.Vty.Widget.Layout where
 import Control.Applicative (liftA2)
 import Control.Monad.Morph
 import Control.Monad.NodeId (MonadNodeId(..), NodeId)
-import Control.Monad
 import Control.Monad.Fix
 import Control.Monad.Reader
 import Data.List (mapAccumL)