evil-leap/evil-leap.el

;;; evil-leap.el --- Evil's answer to Neovim's answer to the mouse -*- lexical-binding: t; -*-
;;
;; Copyright (C) 2024 Madeleine Sydney
;;
;; Author: Madeleine Sydney <lomiskiam@gmail.com>
;; Maintainer: Madeleine Sydney <lomiskiam@gmail.com>
;; Created: October 06, 2024
;; Modified: October 06, 2024
;; Version: 0.0.1
;; Keywords: convenience text
;; Homepage: https://github.com/crumbtoo/leap.el
;; Package-Requires: ((emacs "26.1") (evil "1.2.12") (ht "2.0"))
;;
;; This file is not part of GNU Emacs.
;;
;;; Commentary:
;; Evil leap.
;;
;;
;;; Code:

(require 'evil)
(eval-when-compile (require 'evil))
(require 'ht)
(require 'cl-lib)


; Options

(defcustom evil-leap-safe-labels
  (string-to-list "sfnut/SFNLHMUGTZ?")
  "TODO A list of characters that you will never use immediately after an
evil-leap jump."
  :group 'evil-leap
  :type "List of characters")

(defcustom evil-leap-labels
  (string-to-list "sfnjklhodweimbuyvrgtaqpcxz/SFNJKLHODWEIMBUYVRGTAQPCXZ?")
  ;; (append evil-leap-safe-labels
  ;;         (string-to-list "jklhodweimbyvrgaqpcxzJKODWEIBYVRAQPCX"))
  "TODO A list of characters to use as labels."
  :group 'evil-leap
  :type "List of characters")

(defcustom evil-leap-character-aspect-ratio
  0.3
  "TODO"
  :group 'evil-leap
  :type "Number")

(defcustom evil-leap-equivalence-classes '((?\s ?\n ?\t ?\r))
  "TODO"
  :group 'evil-leap
  :type "List of lists of characters")

(defface evil-leap-label-face '((t :inherit isearch))
  "TODO"
  :group 'evil-leap)

(defface evil-leap-further-label-face '((t :inherit shadow))
  "TODO"
  :group 'evil-leap)

(defcustom evil-leap-use-char-fold-table t
  "TODO"
  :group 'evil-leap
  :type "Boolean")


; Core

(cl-defstruct
    (evil-leap-target
     (:constructor evil-leap-make-target))
  "TODO"
  pos
  line
  column
  ;; TODO: Perhaps we should be tracking /buffers/ rather than windows...
  (window
   nil
   :type "TODO window or nil"
   :documentation
   "TODO nil means current window")
  overlay
  payload)

(defun evil-leap--target-at-point ()
  "TODO"
  (evil-leap-make-target :pos (point)
                         :line (line-number-at-pos)
                         :column (current-column)
                         :window (or (minibuffer-selected-window)
                                     (selected-window))))

(define-inline evil-leap-jump-to-target (target)
  (when-let ((window (evil-leap-target-window target)))
    (select-window window))
  (goto-char (evil-leap-target-pos target)))

(defvar evil-leap-action #'evil-leap-jump-to-target)

(defun evil-leap--remove-all-labels ()
  (remove-overlays nil nil 'category 'evil-leap))

;; ₁₂

(defun evil-leap--add-overlay-target! (target label)
  "TODO returns overlay and sets overlay slot"
  ;; 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* ((pos (evil-leap-target-pos target))
         ;; If `target' has an associated window, grab the buffer associated
         ;; thereupon — we need to place the overlay in the correct buffer, of
         ;; course!
         (buffer (-some-> (evil-leap-target-window target)
                   window-buffer))
         ;; If overlay already exists, just make sure it's in the correct
         ;; position.  If it doesn't exist, create it.
         (overlay (if-let ((ov (evil-leap-target-overlay target)))
                      (move-overlay ov (+ pos 2) (+ pos 3)
                                    buffer)
                    (make-overlay (+ pos 2) (+ pos 3)
                                  buffer)))
         (label-string (string label)))
    (put-text-property 0 1
                       'face (if (eq label ?\s)
                                 'evil-leap-further-label-face
                                 'evil-leap-label-face)
                       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 (memq (char-after (+ pos 2)) '(?\n ?\r))
      (overlay-put overlay 'invisible t))
    (setf (evil-leap-target-overlay target) overlay)
    overlay))

(defun evil-leap--add-to-labeled-targets! (labeled-targets label target)
  "TODO Mutate LABELED-TARGETS by inserting value TARGET under key LABEL — with
spice!

Spice: If an entry with key LABEL already exists in LABELED-TARGETS, a fresh
hash table will be created and inserted into LABELED-TARGETS under key '?\\s'.
This fresh hash table will itself have a key '?\\d' pointing back to
LABELED-TARGETS.  If this '?\\s' entry already exists in LABELED-TARGETS, it
will instead try to insert it into /that/ hash table, continuing until a
suitable home is found.

;; Spice: Since the expected appearance of label overlays is so tightly coupled
;; with the above logic, the overlays are also created by this routine.  Sorry!

This all implies that important parts of evil-leap will enter the eldritch world
of Undefined Behaviour, should either `evil-leap-safe-labels' or
`evil-leap-labels' contain '?\\s' or '?\\d'."
  ;; If the label is already present in `labeled-targets', we insert it into the
  ;; "next map" at key '?\s'.
  (if (ht-get labeled-targets label)
      ;; If labeled-targets[?\s] (the "next map") exists, ...
      (if-let ((next-labeled-targets (ht-get labeled-targets ?\s)))
          ;; ... recurse into it. ...
          (evil-leap--add-to-labeled-targets!
           next-labeled-targets label target)
        ;; ... If it doesn't, create a new hash table, stored in
        ;; `labeled-targets' at key '?\s', containing nought but a back-link key
        ;; ('?\d')[1], and the given label/target pair[2].
        (ht-set! labeled-targets ?\s
                 (ht (?\d labeled-targets) ; [1]
                     (label target)))) ; [2]
    ;; The label does not exist, meaning we needn't muck around with the next
    ;; map.  Proceed normally with `ht-set!'!
    (ht-set! labeled-targets label target)))

(defun evil-leap--label-targets-safe (targets)
  "TODO returns a hash table mapping labels to targets"
  ;; 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 `auto-jump', to indicate that it can be
    ;; auto-jumped to.  The remaining targets are labeled as you'd expect.
    (ht-set! labeled-targets 'auto-jump (car targets))
    (dolist (target (cdr targets) labeled-targets)
      (let ((lbl (pop labels)))
        ;; (evil-leap--add-overlay-target! target lbl)
        (evil-leap--add-to-labeled-targets! labeled-targets lbl target)))))

(defun evil-leap--label-targets-unsafe (targets)
  "TODO returns a hash table mapping labels to targets"
  ;; TODO: space labels don't work
  (let ((labels (-cycle evil-leap-labels))
        (labeled-targets (ht-create 'eq)))
    (dolist (target targets labeled-targets)
      (let ((lbl (pop labels)))
        ;; (evil-leap--add-overlay-target! target lbl)
        (evil-leap--add-to-labeled-targets! labeled-targets lbl target)))))

(defun evil-leap--label-targets (targets)
  "TODO returns a hash table mapping labels to targets.  Labels are
represented by characters.  Adds overlays for labels"
  ;; Safe labels are preferred, but are not available when there are more
  ;; targets than safe labels.
  (let ((safe? (<= (length targets) (length evil-leap-safe-labels))))
    ;;                              ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
    ;; FIXME: I think this should be (+ 1 (length evil-leap-safe-labels)) to
    ;; account for the "anonymous label" given to the auto-jump target.
    (if safe?
        (evil-leap--label-targets-safe targets)
        (evil-leap--label-targets-unsafe targets))))

(defun evil-leap--update-further-overlays! (labeled-targets)
  (ht-each (lambda (k v)
             (cond ((eq k ?\s)
                    (evil-leap--update-further-overlays! v))
                   ((evil-leap-target-p v)
                    (evil-leap--add-overlay-target! v ?\s))
                   ;; Auto-jumps and back-links are met with no-ops.
                   (t nil)))
           labeled-targets))

(defun evil-leap--update-earlier-overlays! (labeled-targets)
  (ht-each (lambda (k v)
             (cond ((eq k ?\d)
                    (evil-leap--update-earlier-overlays! v))
                   ((evil-leap-target-p v)
                    (when-let ((overlay (evil-leap-target-overlay v)))
                      (delete-overlay overlay)))
                   ;; Auto-jumps and fore-links are met with no-ops.
                   (t nil)))
           labeled-targets))

;; REVIEW: This could be more efficient.  We needn't traverse /every/ target.
(defun evil-leap--update-target-overlays! (labeled-targets)
  "TODO Create or update overlays to visually present a set of targets'
associated labels."
  ;; TODO: blah
  (ht-each (lambda (k v)
             (cond
              ;; No-op; auto-jump targets are not labeled in the typical sense.
              ((eq k 'auto-jump)
               nil)

              ;; Label every further overlay.
              ((eq k ?\s)
               (evil-leap--update-further-overlays! v))

              ;; Delete every previous overlay.
              ((eq k ?\d)
               (evil-leap--update-earlier-overlays! v))

              ;; Targets are simply labeled with their label. }:D
              ((evil-leap-target-p v)
               (evil-leap--add-overlay-target! v k))))
           labeled-targets))

(defun evil-leap--euclidean-distance (x1 y1 x2 y2)
  (let* ((width (abs (- x1 x2)))
         (height (* (abs (- y1 y2))
                    evil-leap-character-aspect-ratio))
         (hypotenuse (sqrt (+ (* width width)
                              (* height height)))))
    hypotenuse))

(defun evil-leap--sort-by-euclidean-distance-from-point (targets)
  (let ((point-x (current-column))
        (point-y (line-number-at-pos)))
    (sort targets
          :lessp
          (lambda (target-1 target-2)
            (< (evil-leap--euclidean-distance
                point-x
                point-y
                (evil-leap-target-column target-1)
                (evil-leap-target-line target-1))
               (evil-leap--euclidean-distance
                point-x
                point-y
                (evil-leap-target-column target-2)
                (evil-leap-target-line target-2)))))))

(defun evil-leap--try-auto-jump (labeled-targets)
  (when-let ((auto-jump-target (ht-get labeled-targets 'auto-jump)))
    (funcall evil-leap-action auto-jump-target)))

(defun evil-leap-select-from-labeled-targets (labeled-targets)
  "Given LABELED-TARGETS, a hash table mapping labels to targets,
  - auto-jump to the first target, if possible;
  - read a key from the user;
  - if the key corresponds to a label, jump to it;
  - otherwise, let the input `fall through,' as if Leap were never here."
  ;; REVIEW: Should the return value of `evil-leap-action' be returned by us?
  ;; (with-output-to-temp-buffer (format "*select - %s*" (current-time))
  ;;   (pp labeled-targets))
  (evil-leap--try-auto-jump labeled-targets)
  (evil-leap--update-target-overlays! labeled-targets)
  (let ((given-key (evil-read-key)))
    (if-let ((selected-target (ht-get labeled-targets given-key)))
        ;; '?\s' and '?\d' are special targets that lead to alternative sets
        ;; of labeled targets; if we find another hash table, select from that
        ;; one instead.
        (if (ht-p selected-target)
            (evil-leap-select-from-labeled-targets selected-target)
          (funcall evil-leap-action selected-target))
      ;; If we are given a key that does not correspond to any label, we let
      ;; it 'fall through' to give it a proper run through Emacs' command
      ;; loop.  We do this as a formality in the general case, but it is
      ;; essential to the idea behind auto-jump.

      ;; REVIEW: Should the passthrough behaviour be configurable in the
      ;; non-auto-jump case?
      (progn (push given-key unread-command-events)
             nil))))


; Labels

(defun evil-leap--label-branch-targets! (branches)
  "Mutate BRANCHES by calling `evil-leap--label-targets' on each value, and
replacing it with the result."
  (ht-each (lambda (k tgts)
             (ht-set! branches k (evil-leap--label-targets tgts)))
           branches))

(defun evil-leap--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-targets)
     (unless (eq k second-char)
       (ht-each
        (lambda (_label target)
          ;; 1. A value in `labeled-targets' isn't always a target (e.g. entries
          ;;    at '?\s' and '?\d').
          ;; 2. If a target is an auto-jump candidate, its `overlay' slot is nil.
          (when-let ((overlay (and (evil-leap-target-p target)
                                   (evil-leap-target-overlay target))))
            (delete-overlay overlay)))
        labeled-targets)))
   branches))

(defun evil-leap--show-potential-targets (branches)
  (ht-each (lambda (_key labeled-targets)
             (evil-leap--update-target-overlays! labeled-targets))
           branches))


; Gathering

(defun evil-leap--insert-branch-target (table second-char target)
  (ht-set! table
           second-char
           (cons target (ht-get table second-char))))

(cl-defun evil-leap--gather-branches (first-char &key backward-p)
  "TODO Searches the scope (for maddy: currently, this just means the visible
portion of the buffer) for two-character pairs, consisting of FIRST-CHAR
followed by some SECOND-CHAR.  For each P = (FIRST-CHAR, SECOND-CHAR) pair
found, the returned hash table maps SECOND-CHAR to a list of targets
corresponding to each occurence of P."
  (let* ((start-of-visible (window-start))
         (end-of-visible (window-end))
         (pattern (rx-to-string `(seq ,first-char (group anychar))))
         (table (ht-create 'equal))
         ;; TODO: Clean this up. }:\
         (search (if backward-p
                     (lambda () (re-search-backward pattern start-of-visible t))
                   (lambda () (re-search-forward pattern end-of-visible t)))))
    (save-excursion
      (while (funcall search)
        ;; 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.
        ;;
        ;; REVIEW: Alternatively, we could call `forwrad-char' as the last
        ;; action in the loop.
        (save-excursion
          (goto-char (match-beginning 0))
          (let ((second-char (aref (match-string 1) 0)) ; string->char
                (target (evil-leap--target-at-point)))
            (evil-leap--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

(cl-defun evil-leap
    (&key targets)
  "TODO Something something something.

Keyword arguments
  :targets     TARGETS  A list of targets, or a Lisp procedure returning such a
                        list."
  (unwind-protect
      (evil-leap-select-from-labeled-targets
       (evil-leap--label-targets targets))
    ;; TODO: would it be faster to go through `labeled-targets' and unlabel them
    ;; ourselves?
    (evil-leap--remove-all-labels))
  (evil-leap--remove-all-labels))

;; REVIEW: Could we the preview/branch functionality be rewriten in terms of
;; higher-level functions?  Preferably ones included in the public API?
;;;###autoload (autoload 'evil-leap-directional "evil-leap" nil t)
(evil-define-motion evil-leap-directional (count backward-p)
  "TODO"
  :jump t
  :type 'exclusive
  (interactive "<c>")
  ;; FIXME: If the search pattern finds zero targets, `labeled-targets' ends up
  ;; being nil, which leads to an error in `evil-leap--select-from-labeled-targets'.
  (unwind-protect
      (let* ((first-char (evil-read-key))
             (branches (evil-leap--gather-branches first-char
                                                   :backward-p backward-p))
             (_ (progn (evil-leap--label-branch-targets! branches)
                       (evil-leap--show-potential-targets branches)))
             (second-char (evil-read-key))
             (_ (evil-leap--unlabel-other-branches second-char branches))
             (labeled-targets (ht-get branches second-char)))
        (evil-leap-select-from-labeled-targets labeled-targets))
    ;; TODO: would it be faster to go through `labeled-targets' and unlabel them
    ;; ourselves?
    (evil-leap--remove-all-labels))
  (evil-leap--remove-all-labels))

;;;###autoload (autoload 'evil-leap-forward "evil-leap" nil t)
(evil-define-motion evil-leap-forward (count)
  "TODO"
  :jump t
  :type 'exclusive
  (interactive "<c>")
  (evil-leap-directional count nil))

;;;###autoload (autoload 'evil-leap-backward "evil-leap" nil t)
(evil-define-motion evil-leap-backward (count)
  "TODO"
  :jump t
  :type 'exclusive
  (interactive "<c>")
  (evil-leap-directional count t))



(defvar evil-leap-mode-map
  (let ((m (make-sparse-keymap)))
    (evil-define-key* '(motion normal) m
      "s" #'evil-leap-forward
      "S" #'evil-leap-backward)
    m))

(define-minor-mode evil-leap-mode
  "Enables `evil-leap' in the current buffer.  This mode exists solely for the
associated keymap."
  :keymap 'evil-leap-mode-map)

(define-globalized-minor-mode evil-leap-global-mode
  evil-leap-mode
  (lambda () (evil-leap-mode 1)))



(provide 'evil-leap)
;;; evil-leap.el ends here