init

scratch.el

@@ -0,0 +1,177 @@
+;; -*- lexical-binding: t -*-
+;;;; core ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(require 'ht)
+
+(defun syd/remove-highlights ()
+  (remove-overlays nil nil 'category 'evil-leap))
+
+(defun syd/add-label (pos label)
+  "TODO returns overlay"
+  ;; The label shall be displayed two characters /after/ `pos'.  This ensures
+  ;; the user is able to see the entirety of the target; that is, the first
+  ;; character, located at `pos', and the second, immediately following.
+  (let ((overlay (make-overlay (+ pos 2) (+ pos 3)))
+        (label-string (string label)))
+    (put-text-property 0 1 'face (list :background "red") label-string)
+    (overlay-put overlay 'category 'evil-leap)
+    (overlay-put overlay 'before-string label-string)
+    ;; Normally, we want the labels to cover the buffer's text, rather than
+    ;; shifting it to the side; however, doing so unconditionally will cover
+    ;; newlines, collapsing multiple visual lines onto one.
+    (unless (= (char-after (+ pos 2)) ?\n)
+      (overlay-put overlay 'invisible t))
+    overlay))
+
+(defun syd/label-targets-safe (targets)
+  "TODO returns a hash table mapping labels to targets and overlays"
+  ;; Nasty!  While I'd prefer to iterate over `zip evil-leap-safe-labels
+  ;; targets`, this isn't Haskell; each iteration through `targets', we pop
+  ;; `labels'.
+  (let ((labels evil-leap-safe-labels)
+        (labeled-targets (ht-create 'eq)))
+    ;; The first target is assigned the label -1, to indicate that it can be
+    ;; auto-jumped to.  The remaining targets are labeled as you'd expect.
+    (ht-set! labeled-targets -1 (cons (car targets) nil))
+    (dolist (tgt (cdr targets) labeled-targets)
+      (pcase-let* ((`(,pos ,_ ,_) tgt)
+                   (lbl (pop labels))
+                   (overlay (syd/add-label pos lbl)))
+        (ht-set! labeled-targets lbl (cons tgt overlay))))))
+
+(defun syd/label-targets-unsafe (targets)
+  "TODO returns a hash table mapping labels to targets and overlays"
+  ;; TODO: space labels don't work
+  (let ((labels (append evil-leap-labels (-cycle '(?\s))))
+        (labeled-targets (ht-create 'eq)))
+    (dolist (tgt targets labeled-targets)
+      (pcase-let* ((`(,pos ,_ ,_) tgt)
+                   (lbl (pop labels))
+                   (overlay (syd/add-label pos lbl)))
+        (ht-set! labeled-targets lbl (cons tgt overlay))))))
+
+(defun syd/label-targets (targets)
+  "TODO returns a hash table mapping labels to targets and overlays"
+  (let ((safe? (<= (length targets) (length evil-leap-safe-labels))))
+    ;;                              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+    ;; FIXME: I think this should be (+ 1 (length evil-leap-safe-labels)).
+    (if safe?
+        (syd/label-targets-safe targets)
+        (syd/label-targets-unsafe targets))))
+
+(defun syd/do-auto-jump (action labeled-targets)
+  (when-let ((tgt-and-overlay (ht-get labeled-targets -1)))
+    (funcall action (car tgt-and-overlay))))
+
+(defun syd/select-targets (opts targets)
+  ;; Safe labels are preferred, but are not available when there are more
+  ;; targets than safe labels.
+  (unwind-protect
+      (let ((labeled-targets (syd/label-targets targets))
+            (action (plist-get opts :action)))
+        (syd/do-auto-jump action labeled-targets)
+        (if-let ((given-key (evil-read-key))
+                 (selected-target-and-overlay (ht-get labeled-targets given-key)))
+            (funcall action (car selected-target-and-overlay))
+          (error "TODO no such label")))
+    (syd/remove-highlights)))
+
+(defun syd/select-labeled-targets (opts labeled-targets)
+  (unwind-protect
+      (let ((action (plist-get opts :action)))
+        (syd/do-auto-jump action labeled-targets)
+        (if-let ((given-key (evil-read-key))
+                 (selected-target-and-overlay (ht-get labeled-targets given-key)))
+            (funcall action (car selected-target-and-overlay))
+          (error "TODO no such label"))))
+  (syd/remove-highlights))
+
+;;;; gathering ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defun syd/insert-branch-target (table second-char target)
+  (ht-set! table
+           second-char
+           (cons target (ht-get table second-char))))
+
+(defun syd/gather-branches-forward (first-char)
+  "Traverse each visible two-character sequence of FIRST-CHAR followed by
+another character.  The returned value will be a hash map, mapping discovered
+second characters to a list of targets representing their occurences."
+  (let ((end-of-visible (window-end))
+        (pattern (rx-to-string `(seq ,first-char (group anychar))))
+        ;; (pattern (string first-char ?.))
+        (table (ht-create 'equal)))
+    (save-excursion
+      (while (re-search-forward pattern end-of-visible t)
+        ;; We are forced to save-excursion a second time, lest we enter a
+        ;; feedback loop, where `re-search-forward' moves to a match, and
+        ;; `goto-char' jumps to a position *preceding* the match.
+        (save-excursion
+          (goto-char (match-beginning 0))
+          (let ((second-char (aref (match-string 1) 0)) ; string->char
+                (target (list (point) (current-column) (line-number-at-pos))))
+            (syd/insert-branch-target table second-char target)))))
+    ;; Reverse each list of targets.
+    (ht-each (lambda (k v) (ht-set! table k (reverse v)))
+             table)
+    table))
+
+;;;; entry point ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; (defun syd/gather-targets-forward (regexp)
+;;   (let ((end-of-visible (window-end))
+;;         targets)
+;;     (save-excursion
+;;       (while (re-search-forward regexp end-of-visible t)
+;;         ;; We are forced to save-excursion a second time, lest we enter a
+;;         ;; feedback loop, where `re-search-forward' moves to a match, and
+;;         ;; `goto-char' jumps to a position *preceding* the match.
+;;         (save-excursion
+;;           (goto-char (match-beginning 0))
+;;           (push (list (point) (current-column) (line-number-at-pos))
+;;                 targets))))
+;;     (reverse targets)))
+
+(defun syd/label-branch-targets (branches)
+  "Mutate BRANCHES by calling `syd/label-targets' on each value, and replacing
+it with the result."
+  (ht-each (lambda (k tgts)
+             (ht-set! branches k (syd/label-targets tgts)))
+           branches))
+
+(defun syd/unlabel-other-branches (second-char branches)
+  "Delete every overlay referenced by BRANCHES, *except* those under the branch
+with key SECOND-CHAR."
+  (ht-each (lambda (k labeled-tgts)
+             (unless (eq k second-char)
+               (ht-each (lambda (lbl tgt-and-overlay)
+                          ;; cdr may be nil in precense of auto-jump.
+                          (when-let ((overlay (cdr tgt-and-overlay)))
+                            (delete-overlay overlay)))
+                        labeled-tgts)))
+           branches))
+
+(evil-define-motion syd/leap-forward (count)
+  "TODO"
+  :jump t
+  :type 'exclusive
+  (interactive)
+  (let* ((action (lambda (x) (goto-char (car x))))
+         (first-char (evil-read-key))
+         (branches (syd/gather-branches-forward first-char))
+         (_ (syd/label-branch-targets branches))
+         (second-char (evil-read-key))
+         (_ (syd/unlabel-other-branches second-char branches))
+         (labeled-targets (ht-get branches second-char)))
+    ;; (print branches)
+    ;; (print labeled-targets)
+    ;; nil
+    (syd/select-labeled-targets
+     (list :action (lambda (x) (goto-char (car x))))
+     labeled-targets)
+    ))
+
+;; (defun syd/demo-targets (regexp)
+;;   (syd/select-targets
+;;    (list :action (lambda (x) (goto-char (car x))))
+;;    (syd/gather-targets-forward regexp)))