;; -*- lexical-binding: t; -*-



(require 'ht)

(defun syd/jump-to-target (target)
  (goto-char (car target)))

(defvar syd/leap-action #'syd/jump-to-target)

(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.  Labels are
represented by characters.  Each target is a list of form (POS LINE COLUMN
WINDOW . XS)."
  ;; 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)).
    (if safe?
        (syd/label-targets-safe targets)
        (syd/label-targets-unsafe targets))))

(defun syd/do-auto-jump (labeled-targets)
  (when-let ((tgt-and-overlay (ht-get labeled-targets -1)))
    (funcall syd/leap-action (car tgt-and-overlay))))

(defun syd/select-from-labeled-targets (labeled-targets)
  (unwind-protect
      (progn
        (syd/do-auto-jump syd/leap-action labeled-targets)
        (if-let ((given-key (evil-read-key))
                 (selected-target-and-overlay (ht-get labeled-targets given-key)))
            (funcall syd/leap-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/target-at-point (&optional window)
  (list (point) (line-number-at-pos) (current-column) window))

(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))))
        (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 (syd/target-at-point)))
            (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/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 (_label 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))

(defun syd/leap ()
  )

(evil-define-motion syd/leap-forward (count)
  "TODO"
  :jump t
  :type 'exclusive
  (interactive)
  (let* ((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)))
    ;; TODO: would it be faster to go through `labeled-targets' and unlabel them
    ;; ourselves?
    (unwind-protect
        (syd/select-from-labeled-targets labeled-targets)
      (syd/remove-labels))
    (syd/remove-labels)))