Merge pull request #108 from glguy/absolute-cursor-patch

Add support for absolute cursor positioning

CHANGELOG

@@ -1,3 +1,6 @@
+5.10
+  - Add aboslute cursor positioning mode AbsoluteCursor to Cursor
+
 5.9.1
   - Vty now only emits UTF8 charset sequences in terminals without a
     preexisting UTF8 declaration to avoid emitting garbage sequences

src/Graphics/Vty.hs

@@ -129,38 +129,25 @@ intMkVty input out = do
     lastUpdateRef <- newIORef Nothing
 
     let innerUpdate inPic = do
-            b@(w,h) <- displayBounds out
+            b <- displayBounds out
             let cursor  = picCursor inPic
-                inPic' = case cursor of
-                  Cursor x y ->
-                    let
-                       x'      = case x of
-                                   _ | x < 0     -> 0
-                                     | x >= w    -> w - 1
-                                     | otherwise -> x
-                       y'      = case y of
-                                   _ | y < 0     -> 0
-                                     | y >= h    -> h - 1
-                                     | otherwise -> y
-                     in inPic { picCursor = Cursor x' y' }
-                  _ -> inPic
             mlastUpdate <- readIORef lastUpdateRef
             updateData <- case mlastUpdate of
                 Nothing -> do
                     dc <- displayContext out b
-                    outputPicture dc inPic'
+                    outputPicture dc inPic
                     return (b, dc)
                 Just (lastBounds, lastContext) -> do
                     if b /= lastBounds
                         then do
                             dc <- displayContext out b
-                            outputPicture dc inPic'
+                            outputPicture dc inPic
                             return (b, dc)
                         else do
-                            outputPicture lastContext inPic'
+                            outputPicture lastContext inPic
                             return (b, lastContext)
             writeIORef lastUpdateRef $ Just updateData
-            writeIORef lastPicRef $ Just inPic'
+            writeIORef lastPicRef $ Just inPic
 
     let innerRefresh = do
             writeIORef lastUpdateRef Nothing

src/Graphics/Vty/Config.hs

@@ -266,7 +266,7 @@ parseModifier :: forall s u (m :: * -> *).
 parseModifier = do
     m <- P.identifier configLexer
     case m of
-        "KMenu" -> return MShift
+        "MShift" -> return MShift
         "MCtrl" -> return MCtrl
         "MMeta" -> return MMeta
         "MAlt" -> return MAlt

src/Graphics/Vty/Image/Internal.hs

@@ -38,12 +38,13 @@ clipText txt leftSkip rightClip =
         txt' = if padPrefix then TL.cons '…' (TL.drop (toDrop+1) txt) else TL.drop toDrop txt
         (toTake,padSuffix) = clipForCharWidth rightClip txt' 0
         txt'' = TL.append (TL.take toTake txt') (if padSuffix then TL.singleton '…' else TL.empty)
-        clipForCharWidth 0 _ n = (n, False)
+        -- Note: some characters and zero-width and combining characters
+        -- combine to the left, so keep taking characters even if the width
+        -- is zero.
         clipForCharWidth w t n
             | TL.null t = (n, False)
-            | w <  cw = (n, True)
-            | w == cw = (n+1, False)
-            | w >  cw = clipForCharWidth (w - cw) (TL.tail t) (n + 1)
+            | w < cw    = (n, w /= 0)
+            | otherwise = clipForCharWidth (w - cw) (TL.tail t) (n + 1)
             where cw = safeWcwidth (TL.head t)
         clipForCharWidth _ _ _ = error "clipForCharWidth applied to undefined"
     in txt''

src/Graphics/Vty/Output/Interface.hs

@@ -166,13 +166,20 @@ outputPicture dc pic = liftIO $ do
         out = (if manipCursor then writeHideCursor dc else mempty)
               `mappend` writeOutputOps dc initialAttr diffs ops
               `mappend`
-                (case picCursor pic of
+                (let (w,h) = contextRegion dc
+                     clampX = max 0 . min (w-1)
+                     clampY = max 0 . min (h-1) in
+                 case picCursor pic of
                     _ | not manipCursor -> mempty
-                    NoCursor             -> mempty
+                    NoCursor            -> mempty
+                    AbsoluteCursor x y ->
+                        writeShowCursor dc `mappend`
+                        writeMoveCursor dc (clampX x) (clampY y)
                     Cursor x y           ->
                         let m = cursorOutputMap ops $ picCursor pic
                             (ox, oy) = charToOutputPos m (x,y)
-                        in writeShowCursor dc `mappend` writeMoveCursor dc ox oy
+                        in writeShowCursor dc `mappend`
+                           writeMoveCursor dc (clampX ox) (clampY oy)
                 )
     -- ... then serialize
     outputByteBuffer (contextDevice dc) (writeToByteString out)

src/Graphics/Vty/Picture.hs

@@ -69,13 +69,16 @@ picForLayers is = Picture
 --
 -- todo: The Cursor can be given a (character,row) offset outside of the visible bounds of the
 -- output region. In this case the cursor will not be shown.
-data Cursor = 
+data Cursor =
+      -- | Hide the cursor
       NoCursor
-    | Cursor Int Int
+      -- | Show the cursor at the given logical column accounting for char width and row
+    | Cursor !Int !Int
+      -- | Show the cursor at the given absolute terminal column and row
+    | AbsoluteCursor !Int !Int
 
 instance NFData Cursor where
-    rnf NoCursor = ()
-    rnf (Cursor w h) = w `seq` h `seq` ()
+    rnf c = c `seq` ()
 
 -- | A 'Picture' has a background pattern. The background is either ClearBackground. Which shows the
 -- layer below or is blank if the bottom layer. Or the background pattern is a character and a
@@ -85,11 +88,11 @@ instance NFData Cursor where
 -- \todo The current attribute is always set to the default attributes at the start of updating the
 -- screen to a picture.
 data Background
-    = Background 
+    = Background
     { backgroundChar :: Char
     , backgroundAttr :: Attr
     }
-     -- | A ClearBackground is: 
+     -- | A ClearBackground is:
      --
      -- * the space character if there are remaining non-skip ops
      --

vty.cabal

@@ -1,5 +1,5 @@
 name:                vty
-version:             5.9.1
+version:             5.10
 license:             BSD3
 license-file:        LICENSE
 author:              AUTHORS