folding with overlays

extensions/vi-mode/commands.lisp

@@ -198,16 +198,19 @@
 
 (define-command vi-forward-char (&optional (n 1)) (:universal)
   (let* ((p (current-point))
-         (max-offset (- (length (line-string p))
-                        (point-charpos p))))
+         (max-offset (with-point ((e p))
+                       (visual-line-end e)
+                       (count-characters p e))))
     (character-offset p (min n max-offset))))
 
 (define-command vi-backward-char (&optional (n 1)) (:universal)
   (let ((p (current-point)))
-    (dotimes (_ n)
-      (if (bolp p)
-          (return)
-          (character-offset p -1)))))
+    (with-point ((bol p))
+      (visual-line-beginning bol)
+      (dotimes (_ n)
+        (if (point<= p bol)
+            (return)
+            (character-offset p -1))))))
 
 (define-motion vi-next-line (&optional (n 1)) (:universal)
     (:type :line)
@@ -309,7 +312,7 @@
 
 (define-command vi-move-to-beginning-of-line () ()
   (with-point ((start (current-point)))
-    (line-start start)
+    (visual-line-beginning start)
     (or (text-property-at (current-point) :field -1)
         (previous-single-property-change (current-point)
                                          :field
@@ -318,7 +321,7 @@
 
 (define-command vi-move-to-end-of-line (&optional (n 1)) (:universal)
   (vi-line n)
-  (line-end (current-point)))
+  (visual-line-end (current-point)))
 
 (define-command vi-move-to-last-nonblank () ()
   (vi-move-to-end-of-line)

extensions/vi-mode/commands/utils.lisp

@@ -61,7 +61,10 @@
             (1- len)))))
 
 (defun fall-within-line (point)
-  (when (eolp point)
+  "Clamps the given point to the character before the newline at the end of the line it is in."
+  ;; a buffer-line end whose newline is hidden by a fold is mid-visual-line, so we dont clamp.
+  (when (and (eolp point)
+             (not (invisible-overlay-covering point)))
     (line-end point)
     (unless (bolp point)
       (character-offset point *cursor-offset*))))

lem-tests.asd

@@ -79,6 +79,7 @@
                (:file "filer")
                (:file "listener-mode")
                (:file "interface")
-               (:file "display-cache"))
+               (:file "display-cache")
+               (:file "visual-line"))
   :perform (test-op (o c)
                     (symbol-call :rove :run c)))

lem.asd

@@ -149,6 +149,13 @@
 
                (:file "color-theme")
 
+               (:module "display"
+                :serial t
+                :components ((:file "base")
+                             (:file "char-type")
+                             (:file "logical-line")
+                             (:file "physical-line")))
+
                (:module "commands"
                 :serial t
                 :components ((:file "move")
@@ -168,13 +175,6 @@
                              (:file "frame")
                              #+sbcl (:file "sprof")))
 
-               (:module "display"
-                :serial t
-                :components ((:file "base")
-                             (:file "char-type")
-                             (:file "logical-line")
-                             (:file "physical-line")))
-
                (:file "external-packages")
 
                (:module "ext"

src/attribute.lisp

@@ -192,6 +192,9 @@
   (:light :foreground nil :background "#eedc82")
   (:dark :foreground nil :background "blue"))
 
+(define-attribute fold-attribute
+  (t :foreground :base04))
+
 (define-attribute modeline
   (t :bold t :background "#404040" :foreground "white"))
 

src/commands/move.lisp

@@ -12,6 +12,8 @@
            :move-to-beginning-of-logical-line
            :move-to-end-of-line
            :move-to-end-of-logical-line
+           :visual-line-beginning
+           :visual-line-end
            :next-page
            :previous-page
            :next-page-char
@@ -45,6 +47,134 @@
 (define-key *global-keymap* "C-x [" 'previous-page-char)
 (define-key *global-keymap* "M-g" 'goto-line)
 
+(defvar *cursor-positions-before-command*
+  (make-hash-table :test 'eq)
+  "Maps each cursor point to its absolute buffer position before the running command, so
+`run-overlay-cursor-motion-hooks' can tell which direction it moved.")
+
+(defvar *cursor-overlays-before-command*
+  (make-hash-table :test 'eq)
+  "Maps each cursor point to the cursor-hook overlays it occupied before the running command,
+so `run-overlay-cursor-motion-hooks' can tell which overlays it entered and which it left.")
+
+(add-hook *pre-command-hook* 'snapshot-cursor-state)
+(add-hook *post-command-hook* 'run-overlay-cursor-motion-hooks)
+
+(defun snapshot-cursor-state ()
+  "Snapshot every cursor's position and the cursor-hook overlays it occupies, so that after the
+command `run-overlay-cursor-motion-hooks' can tell which overlays each cursor entered and left,
+and in which direction."
+  (clrhash *cursor-positions-before-command*)
+  (clrhash *cursor-overlays-before-command*)
+  (dolist (point (buffer-cursors (current-buffer)))
+    (setf (gethash point *cursor-positions-before-command*)
+          (position-at-point point))
+    (setf (gethash point *cursor-overlays-before-command*)
+          (overlays-with-cursor-hooks-covering point))))
+
+(defun run-overlay-cursor-enter-functions (point direction)
+  "Run the :cursor-enter-functions of every cursor-hook overlay POINT has entered since the
+command, each called as (FUNCTION point overlay direction). repeats while a handler
+repositions POINT so that overlays it is then pushed into also fire."
+  (let ((seen (copy-list (gethash point *cursor-overlays-before-command*)))
+        (visited (list (position-at-point point))))
+    (loop
+      (let ((entered (set-difference (overlays-with-cursor-hooks-covering point) seen)))
+        (when (null entered)
+          (return))
+        (let ((before-pass (position-at-point point)))
+          (dolist (overlay entered)
+            (push overlay seen)
+            (dolist (function (overlay-get overlay :cursor-enter-functions))
+              (funcall function point overlay direction)))
+          (let ((after-pass (position-at-point point)))
+            ;; stop once a pass leaves POINT put, or revisits a position. the latter guards
+            ;; against two overlays snapping a cursor back and forth forever.
+            ;; this is tricky. this is definitely not the best way to do things but it works for now.
+            ;; the nature of overlay hooks itself is tricky anyway.
+            (when (or (= before-pass after-pass)
+                      (member after-pass visited))
+              (return))
+            (push after-pass visited)))))))
+
+(defun run-overlay-cursor-leave-functions (point direction)
+  "Run the :cursor-leave-functions of every cursor-hook overlay POINT was in before the
+command, each called as (FUNCTION point overlay direction)."
+  (let ((left (set-difference (gethash point *cursor-overlays-before-command*)
+                              (overlays-with-cursor-hooks-covering point))))
+    (dolist (overlay left)
+      (dolist (function (overlay-get overlay :cursor-leave-functions))
+        (funcall function point overlay direction)))))
+
+(defun cursor-move-direction-overlay (point)
+  "The direction POINT moved during the command, :forward or :backward (:forward when its prior
+position is unknown or unchanged)."
+  (let ((before (gethash point *cursor-positions-before-command*)))
+    (if (and before (< (position-at-point point) before))
+        :backward
+        :forward)))
+
+(defun run-overlay-cursor-motion-hooks ()
+  (dolist (point (buffer-cursors (current-buffer)))
+    (let ((direction (cursor-move-direction-overlay point)))
+      (run-overlay-cursor-enter-functions point direction)
+      (run-overlay-cursor-leave-functions point direction))))
+
+(defun visual-line-end (point)
+  "Move POINT to the end of its visual line. returns POINT."
+  (line-end point)
+  (loop :until (last-line-p point)
+        :while (invisible-overlay-covering point)
+        :do (line-offset point 1)
+            (line-end point))
+  point)
+
+(defun visual-line-beginning (point)
+  "Move POINT to the start of its visual line. returns POINT."
+  (line-start point)
+  (loop :while (line-continuation-p point)
+        :do (line-offset point -1)
+            (line-start point))
+  point)
+
+(defun line-continuation-to-skip (point)
+  (let ((overlay (line-continuation-p point)))
+    (and overlay
+         (not (overlay-get overlay :cursor-leave-functions))
+         overlay)))
+
+(defun skip-invisible-lines (point direction)
+  "Move POINT past any fully invisible lines in DIRECTION (1 or -1).
+returns POINT on success, or NIL if a buffer boundary is reached."
+  (loop :while (line-continuation-to-skip point)
+        :do (unless (line-offset point direction)
+              (return-from skip-invisible-lines nil)))
+  point)
+
+(defun move-to-next-visible-virtual-line (point n)
+  "Like `move-to-next-virtual-line' but skips fully invisible lines."
+  (let ((dir (if (plusp n) 1 -1))
+        (steps (abs n)))
+    (loop :repeat steps
+          :do (unless (move-to-next-virtual-line point dir)
+                (return-from move-to-next-visible-virtual-line nil))
+              (when (line-continuation-to-skip point)
+                (unless (skip-invisible-lines point dir)
+                  (return-from move-to-next-visible-virtual-line nil))))
+    point))
+
+(defun visible-line-offset (point n)
+  "Like `line-offset' but skips fully invisible lines."
+  (let ((dir (if (plusp n) 1 -1))
+        (steps (abs n)))
+    (loop :repeat steps
+          :do (unless (line-offset point dir)
+                (return-from visible-line-offset nil))
+              (when (line-continuation-to-skip point)
+                (unless (skip-invisible-lines point dir)
+                  (return-from visible-line-offset nil))))
+    point))
+
 (defun next-line-aux (n
                       point-column-fn
                       forward-line-fn
@@ -67,14 +197,14 @@
   "Move the cursor to next line."
   (next-line-aux n
                  #'point-virtual-line-column
-                 #'move-to-next-virtual-line
+                 #'move-to-next-visible-virtual-line
                  #'move-to-virtual-line-column))
 
 (define-command (next-logical-line (:advice-classes movable-advice)) (&optional n) (:universal)
   "Move the cursor to the next logical line."
   (next-line-aux n
                  #'point-column
-                 #'line-offset
+                 #'visible-line-offset
                  #'move-to-column))
 
 (define-command (previous-line (:advice-classes movable-advice)) (&optional (n 1)) (:universal)