[nongnu] elpa/annotate 785b5aea7f 042/372: rework annotation display logic

[ELPA Syncer]

branch: elpa/annotate
commit 785b5aea7fd45fe914c592eb40208b0ad5ae0228
Author: Bastian Bechtold <basti@bastibe.de>
Commit: Bastian Bechtold <basti@bastibe.de>

    rework annotation display logic
    
    This now uses Emacs' font-lock framework to create and update
    annotations. This allows them stay in a fixed place despite being edited
    or the text around them being edited. Also, there can now be several
    annotations per line, and annotations that are longer than the window width.
---
 README.md   |   3 +-
 annotate.el | 188 ++++++++++++++++++++++++++++++++++++++++++++----------------
 2 files changed, 140 insertions(+), 51 deletions(-)

diff --git a/README.md b/README.md
index 1e6769a2d9..bfefc4d6f7 100644
--- a/README.md
+++ b/README.md
@@ -22,7 +22,6 @@ Annotations can be exported `annotate-export-annotations` as 
commented unified d
 
 ### Incompatibilities:
 
-- you can't annotate org-mode source code blocks.
-- `form-feed-mode`. For unknown reasons, `form-feed-mode` erases all 
annotations (to be more precise: the `display` text properties of the line feed 
characters, which is what `annotate` uses to display it's annotations).
+- annotations in org-mode source blocks will be underlined, but the 
annotations don't show up. This is likely a fundamental incompatibility with 
the way source blocks are highlighted and the way annotations are displayed.
 
 This package is released under the MIT license.
diff --git a/annotate.el b/annotate.el
index ffbbd9c46c..7283aede23 100644
--- a/annotate.el
+++ b/annotate.el
@@ -5,7 +5,7 @@
 ;; Maintainer: Bastian Bechtold
 ;; URL: https://github.com/bastibe/annotate.el
 ;; Created: 2015-06-10
-;; Version: 0.3.5
+;; Version: 0.4.0
 
 ;; This file is NOT part of GNU Emacs.
 
@@ -50,7 +50,7 @@
 ;;;###autoload
 (defgroup annotate nil
   "Annotate files without changing them."
-  :version "0.3.5"
+  :version "0.4.0"
   :group 'text)
 
 ;;;###autoload
@@ -105,14 +105,20 @@
   :group 'annotate)
 
 (defun annotate-initialize ()
-  "Load annotations and set up save hook."
+  "Load annotations and set up save and display hooks."
   (annotate-load-annotations)
-  (add-hook 'after-save-hook 'annotate-save-annotations t t))
+  (add-hook 'after-save-hook 'annotate-save-annotations t t)
+  (font-lock-add-keywords
+   nil '((annotate--font-lock-matcher (2 (annotate--annotation-builder))
+                                      (1 (annotate--change-guard))))))
 
 (defun annotate-shutdown ()
-  "Clear annotations and remove save hook."
+  "Clear annotations and remove save and display hooks."
   (annotate-clear-annotations)
-  (remove-hook 'after-save-hook 'annotate-save-annotations t))
+  (remove-hook 'after-save-hook 'annotate-save-annotations t)
+  (font-lock-remove-keywords
+   nil '((annotate--font-lock-matcher (2 (annotate--annotation-builder))
+                                      (1 (annotate--change-guard))))))
 
 ;;;###autoload
 (defun annotate-annotate ()
@@ -123,7 +129,9 @@
            (annotate-change-annotation (point)))
           (t
            (cl-destructuring-bind (start end) (annotate-bounds)
-             (annotate-create-annotation start end))))))
+             (annotate-create-annotation start end)))))
+  (font-lock-fontify-block 1)
+  (set-buffer-modified-p t))
 
 ;;;###autoload
 (defun annotate-next-annotation ()
@@ -300,6 +308,101 @@ annotation, and can be conveniently viewed in diff-mode."
           (diff-mode)
           (view-mode)))
 
+(defun annotate--font-lock-matcher (limit)
+  "Finds the next annotation. Matches two areas:
+- the area between the overlay and the annotation
+- the newline that will display the annotation
+
+The first match will get `annotate--change-guard` as its
+`insert-behind-hook`, to make sure that if a newline is inserted
+between the overlay and the annotation, the `display` property of
+the newline is properly disposed of.
+
+The second match will get `annotate-annotation-builder` as its
+`display` property, which makes the newline look like an
+annotation plus the newline."
+  (goto-char (next-overlay-change (point)))
+  (if (>= (point) limit)
+      nil ; no match found before limit
+    (progn
+      ;; go to the end of the longest overlay under point
+      (let ((overlays (sort (overlays-at (point))
+                            (lambda (x y)
+                              (> (overlay-end x) (overlay-end y))))))
+        (goto-char (overlay-end (car overlays))))
+      ;; capture the area from the overlay to EOL for the modification guard
+      ;; and the newline itself for the annotation.
+      (re-search-forward "\\(.*\\)\\(\n\\)")
+      t)))
+
+(defun annotate-lineate (text)
+  "Breaks `text` into lines to fit in the annotation space"
+  (let ((available-width (- (window-body-width)
+                            annotate-annotation-column))
+        (lineated "")
+        (current-pos 0))
+    (while (< current-pos (string-width text))
+      (setq lineated
+            (concat
+             lineated
+             (substring text current-pos
+                        (min (string-width text)
+                             (+ current-pos available-width -1)))
+             "\n"))
+      (setq current-pos (+ current-pos available-width -1)))
+    ;; strip trailing newline, if any
+    (if (string= (substring lineated (1- (string-bytes lineated))) "\n")
+        (substring lineated 0 (1- (string-bytes lineated)))
+      lineated)))
+
+(defun annotate--annotation-builder ()
+  "Searches the line before point for annotations, and returns a
+`facespec` with the annotation in its `display` property."
+  (save-excursion
+    (goto-char (1- (point))) ; we start at the start of the next line
+    ;; find overlays in the preceding line
+    (let* ((prefix (annotate-make-prefix)) ; white space before first 
annotation
+           (text "")
+           (bol (progn (beginning-of-line) (point)))
+           (eol (progn (end-of-line) (point)))
+           (overlays (sort (overlays-in bol eol)
+                           (lambda (x y)
+                             (< (overlay-end x) (overlay-end y))))))
+      ;; put each annotation on its own line
+      (dolist (ov overlays)
+        (if (overlay-get ov 'annotation)
+            (dolist (l (save-match-data (split-string (annotate-lineate 
(overlay-get ov 'annotation)) "\n")))
+              (setq text
+                    (concat text prefix
+                            (propertize l 'face 'annotate-annotation)
+                            "\n"))
+              ;; white space before for all but the first annotation
+              (setq prefix (make-string annotate-annotation-column ? )))))
+      ;; build facecpec with the annotation text as display property
+      (list 'face 'default 'display text))))
+
+(defun annotate--remove-annotation-property (begin end)
+  "Cleans up annotation properties associated with a region."
+  ;; inhibit infinite loop
+  (setq inhibit-modification-hooks t)
+  (save-excursion
+    (goto-char end)
+    ;; go to the EOL where the
+    ;; annotated newline used to be
+    (end-of-line)
+    ;; strip dangling display property
+    (remove-text-properties
+     (point) (1+ (point)) '(display nil)))
+  (setq inhibit-modification-hooks nil))
+
+(defun annotate--change-guard ()
+  "Returns a `facespec` with an `insert-behind-hooks` property
+that strips dangling `display` properties of text insertions if
+text is inserted. This cleans up after newline insertions between
+an overlay and it's annotation."
+  (list 'face nil
+        'insert-behind-hooks '(annotate--remove-annotation-property)))
+
 (defun annotate-context-before (pos)
   "Context lines before POS."
   (save-excursion
@@ -340,29 +443,20 @@ annotation, and can be conveniently viewed in diff-mode."
         (modified-p (buffer-modified-p)))
     ;; remove empty annotations created by earlier bug:
     (setq annotations (cl-remove-if (lambda (ann) (eq (nth 2 ann) nil))
-                                 annotations))
+                                    annotations))
     (when (and (eq nil annotations) annotate-use-messages)
       (message "No annotations found."))
     (when (not (eq nil annotations))
       (save-excursion
         (dolist (annotation annotations)
-          (let* ((start (nth 0 annotation))
-                 (end (nth 1 annotation))
-                 (text (nth 2 annotation))
-                 (highlight (make-overlay start end)))
-            (overlay-put highlight 'face 'annotate-highlight)
-            (overlay-put highlight 'annotation text)
-            (setq text (propertize text 'face 'annotate-annotation))
-            (goto-char end)
-            (move-end-of-line nil)
-            (let ((prefix (annotate-make-prefix)))
-              (put-text-property (point)
-                                 (1+ (point))
-                                 'display
-                                 (concat prefix text "\n"))))))
-      (set-buffer-modified-p modified-p)
-      (if annotate-use-messages
-          (message "Annotations loaded.")))))
+          (let ((start (nth 0 annotation))
+                (end (nth 1 annotation))
+                (text (nth 2 annotation)))
+            (annotate-create-annotation start end text)))))
+    (set-buffer-modified-p modified-p)
+    (font-lock-fontify-buffer)
+    (if annotate-use-messages
+        (message "Annotations loaded."))))
 
 ;;;###autoload
 (defun annotate-clear-annotations ()
@@ -376,34 +470,30 @@ annotation, and can be conveniently viewed in diff-mode."
                     (lambda (ov)
                       (eq nil (overlay-get ov 'annotation)))
                     overlays))
-    (save-excursion
-      (dolist (ov overlays)
-        (goto-char (overlay-end ov))
-        (move-end-of-line nil)
-        (delete-overlay ov)
-        (remove-text-properties (point) (1+ (point)) '(display nil))))
+    (dolist (ov overlays)
+      (annotate--remove-annotation-property
+       (overlay-start ov)
+       (overlay-end ov))
+      (delete-overlay ov))
     (set-buffer-modified-p modified-p)))
 
-(defun annotate-create-annotation (start end)
+(defun annotate-create-annotation (start end &optional text)
   "Create a new annotation for selected region."
-  (let ((annotation (read-from-minibuffer "Annotation: "))
-        (prefix (annotate-make-prefix)))
+  (let ((annotation (or text (read-from-minibuffer "Annotation: "))))
     (when (not (or (eq nil annotation) (string= "" annotation)))
       (let ((highlight (make-overlay start end)))
         (overlay-put highlight 'face 'annotate-highlight)
-        (overlay-put highlight 'annotation annotation)
-        (setq annotation (propertize annotation 'face 'annotate-annotation))
-        (save-excursion
-          (goto-char (max start end))
-          (move-end-of-line nil)
-          (put-text-property (point) (1+ (point))
-                             'display (concat prefix annotation "\n")))))))
+        (overlay-put highlight 'annotation annotation))))
+  (save-excursion
+    (goto-char end)
+    (font-lock-fontify-block 1)))
 
 (defun annotate-change-annotation (pos)
   "Change annotation at point. If empty, delete annotation."
   (let* ((highlight (car (overlays-at pos)))
-         (annotation (read-from-minibuffer "Annotation: " (overlay-get 
highlight 'annotation)))
-         (prefix (annotate-make-prefix)))
+         (annotation (read-from-minibuffer
+                      "Annotation: "
+                      (overlay-get highlight 'annotation))))
     (save-excursion
       (goto-char (overlay-end highlight))
       (move-end-of-line nil)
@@ -412,13 +502,12 @@ annotation, and can be conveniently viewed in diff-mode."
        ((eq nil annotation))
        ;; annotation was erased:
        ((string= "" annotation)
-        (delete-overlay highlight)
-        (remove-text-properties (point) (1+ (point)) '(display nil)))
+        (annotate--remove-annotation-property
+         (overlay-start highlight)
+         (overlay-end highlight))
+        (delete-overlay highlight))
        ;; annotation was changed:
-       (t
-        (overlay-put highlight 'annotation annotation)
-        (setq annotation (propertize annotation 'face 'annotate-annotation))
-        (put-text-property (point) (1+ (point)) 'display (concat prefix 
annotation "\n")))))))
+       (t (overlay-put highlight 'annotation annotation))))))
 
 (defun annotate-make-prefix ()
   "An empty string from the end of the line upto the annotation."
@@ -430,6 +519,7 @@ annotation, and can be conveniently viewed in diff-mode."
       (setq prefix-length (- annotate-annotation-column (- eol (point))))
       (if (< prefix-length 2)
           (make-string 2 ? )
+
         (make-string prefix-length ? )))))
 
 (defun annotate-bounds ()