;;; syd-lisp-lib.el -*- lexical-binding: t; -*-

(require 'general)
(require 'clj-lib)

(use-package smartparens
  :defer t)

(use-package evil-surround
  :defer t)

;; Include various lispy symbols as word constituents.
(dolist (c '(?- ?_ ?? ?! ?+ ?* ?/ ?: ?> ?< ?= ?&))
  (modify-syntax-entry c "w" lisp-data-mode-syntax-table))

;;;###autoload
(defvar-keymap syd-lisp-mode-map
  :doc "Keymap for `syd-lisp-mode'.")

;;;###autoload
(define-minor-mode syd-lisp-mode
  "A minor mode for editing lispy languages."
  :keymap syd-lisp-mode-map)

;;;###autoload
(defun syd-wrap-sexp (char)
  "Wrap the sexp at point (using `smartparens') with the pair corresponding to
CHAR (using `evil-surround').  Unlike other `evil-surround' operations, the
point will be preserved and the wrapped region will be re-indented."
  (interactive (evil-surround-input-char))
  (sp-get (sp-get-thing)
    (save-excursion
      (evil-surround-region :beg :end 'inclusive char)
      (indent-region :beg :end))))

;;;###autoload
(evil-define-motion syd-get-enclosing-sexp ()
  "Like `sp-get-enclosing-sexp', but with a slightly different meaning of
\"enclosing sexp\" that matches Vim-sexp's"
  (or (let ((sexp-at-point (sp-get-sexp)))
        (sp-get sexp-at-point
          (when (or (and :beg (= (point) :beg))
                    (and :end (= (point) (- :end 1))))
            sexp-at-point)))
      (let ((sp-enclosing-sexp (sp-get-enclosing-sexp)))
        (sp-get sp-enclosing-sexp
          (when :beg
            sp-enclosing-sexp)))))

;;;###autoload
(evil-define-motion syd-backward-up-sexp (count)
  "Move point to the opening bracket of the enclosing sexp.  The precise meaning
of \"enclosing sexp\" differs slightly from that used by Smartparens for the
sake of a more Vim-like feel inspired by vim-sexp."
  :type exclusive
  (dotimes (_ (or count 1))
    ;; REVIEW: Is there a better way to do this?  I'm slightly uncomfortable
    ;; calling two different `sp-get-*' functions.
    (or (sp-get (sp-get-sexp)
	  (when (and :end (= (point) (- :end 1)))
	    (goto-char :beg)))
	(sp-get (sp-get-enclosing-sexp)
	  (when :beg
	    (goto-char :beg))))))

;;;###autoload
(evil-define-motion syd-forward-up-sexp (&optional count)
  "Move point to the closing bracket of the enclosing sexp.  See
`syd-backward-up-sexp'."
  :type exclusive
  (dotimes (_ (or count 1))
    (or (sp-get (sp-get-sexp)
          (when (and :beg (= (point) :beg))
            (goto-char (- :end 1))))
        (sp-get (sp-get-enclosing-sexp)
          (when :end
            (if (= (point) (- :end 1))
                (sp-get (save-excursion (forward-char)
                                        (sp-get-enclosing-sexp))
                  (when :end
                    (goto-char (- :end 1))))
              (goto-char (- :end 1))))))))

;;;###autoload
(defun syd-get-top-level-sexp ()
  "Get the top-level sexp enclosing point.  Destructure with `sp-get'.'"
  ;; The end position returned by `bounds-of-thing-at-point' includes an
  ;; unpredictable amount of trailing whitespace, so we discard it and compute
  ;; our own figure.
  (let ((original-point (point)))
    (-when-let ((beg . _) (bounds-of-thing-at-point 'defun))
     (save-excursion
       (goto-char beg)
       ;; We can trust Smarparents to get the desired end position.
       (-let* ((top-level-sexp (sp-get-sexp))
               ((_ . end) (sp-get top-level-sexp (cons :beg :end))))
         ;; If the sexp is behind point, we aren't interested in it; find one
         ;; /ahead/ of point.
         (if (< original-point end)
             top-level-sexp
           (goto-char end)
           (sp-next-sexp)
           (sp-get-sexp)))))))

;;;###autoload
(defun syd-get-top-level-sexp-and-attached-comment-bounds ()
  "Get the bounds of top-level sexp enclosing point and the \"attached\"
comment, if there is one.  Returns nil or a pair (BEG . END)."
  (-when-let ((beg . end) (sp-get (syd-get-top-level-sexp) (cons :beg :end)))
    (let ((attached-comment-beg (save-excursion
                                  (goto-char beg)
                                  (syd-sexp--backward-attached-comment))))
      (cons (or attached-comment-beg beg)
            end))))

(evil-define-motion syd-forward-defun (count)
  :jump t
  (sp-get (syd-get-top-level-sexp)
    (goto-char :beg)
    (dotimes (_ (or count 1))
      (sp-next-sexp))))

(defvar syd-sexp-cleanup-operators '(evil-delete)
  "When `syd-evil-a-defun' is used in combination with one of these operators,
some cleanup will be performed.")

(defun syd-sexp--backward-attached-comment ()
  "Assuming point is on the opening delimiter of a sexp, move point backward to
the beginning of the \"attached\" comment."
  (let ((sexp-line (line-number-at-pos))
        (sexp-column (current-column)))
    (-when-let ((beg . _end) (save-excursion
                               (goto-line (- sexp-line 1))
                               (evil-forward-char sexp-column t)
                               (sp-get-comment-bounds)))
      (goto-char beg))))

;;;###autoload
(evil-define-text-object syd-evil-a-defun (count _beg _end _type)
  "Selects the enclosing top-level sexp.  With a COUNT of N, that many
consequtive top-level sexps will be selected.  TODO: Special care will be taken
to clean up whitespace following certain operators."
  :type inclusive
  (when (< count 0)
    (user-error "TODO: Negative count"))
  (-let ((cleanup-p (memq evil-this-operator syd-sexp-cleanup-operators))
         ((beg-0 . end-0)
          (syd-get-top-level-sexp-and-attached-comment-bounds)))
    (if (or (null count) (= count 1))
        (list beg-0 end-0)
      (goto-char end-0)
      (dotimes (_ (- count 1))
        (sp-next-sexp))
      (sp-get (sp-get-sexp)
        (list beg-0 :end)))))

;; IDEA: How about the inner-defun text object selects the defun /without/ the
;; comment?  Is that more useful, or less?  I can't think of the last time I've
;; needed the top-level sexp without the brackets.

;;;###autoload
(evil-define-text-object syd-evil-inner-defun (_count _beg _end _type)
  "Select the *content* of the enclosing top-level sexp, i.e. without the
delimiters."
  :type inclusive
  (sp-get (syd-get-top-level-sexp)
    (list (+ :beg 1)
          (- :end 1))))

(defun syd-sexp--forward-trailing-whitespace (sexp)
  "Move point to the end of the whitespace trailing after SEXP."
  (goto-char (sp-get sexp :end))
  (skip-chars-forward "[:blank:]")
  (when (= (char-after) ?\n)
    (forward-char)
    (skip-chars-forward "[:blank:]")))

(defun syd-sexp--backward-leading-whitespace (sexp)
  "Move point to the beginning of the whitespace preceding SEXP."
  (goto-char (sp-get sexp :beg))
  (skip-chars-backward "[:blank:]")
  (when (= (char-before) ?\n)
    (backward-char)
    (skip-chars-backward "[:blank:]")))

;;;###autoload
(evil-define-text-object syd-evil-a-form (count _beg _end _type)
  (let* ((cleanup-p (memq evil-this-operator syd-sexp-cleanup-operators))
         (sexp (syd-get-enclosing-sexp)))
    (if cleanup-p
        (save-excursion
          (if (syd-sexp--looking-at-last-p)
              (progn (syd-sexp--backward-leading-whitespace sexp)
                     (list (point) (sp-get sexp :end)))
            (syd-sexp--forward-trailing-whitespace sexp)
            (list (sp-get sexp :beg) (point))))
      (sp-get sexp (list :beg :end)))))

;;;###autoload
(evil-define-text-object syd-evil-inner-form (count _beg _end _type)
  (sp-get (syd-get-enclosing-sexp)
    (list (+ :beg 1) (- :end 1))))

;;;###autoload
(evil-define-command syd-open-sexp-below ()
  "Insert a newline with appropriate indentation after the enclosing sexp.  A
sexp-wise analogue to Evil's line-wise `evil-open-below'."
  :suppress-operator t
  (evil-with-single-undo
    ;; We want to add an additional blank line when operating at the top level.
    ;; Instead of parsing upward until we can no longer find an enclosing sexp, we
    ;; simply check if the opening bracket is on the first column.  This is not
    ;; very correct, but it's way less work (for myself and the CPU).  If we
    ;; switch to a tree-sitter–based parser, I'd love to switch to the correct
    ;; algorithm.
    (-let* (((beg . end) (sp-get (syd-get-enclosing-sexp) (cons :beg :end)))
            (col (save-excursion (goto-char beg) (current-column))))
      (goto-char end)
      (if (= col 0)
          (newline 2)
        (newline-and-indent))))
  (evil-insert-state 1))

;;;###autoload
(evil-define-command syd-open-sexp-above ()
  "Insert a newline with appropriate indentation above the enclosing sexp.  A
sexp-wise analogue to Evil's line-wise `evil-open-above'."
  :suppress-operator t
  (evil-with-single-undo
    (let ((beg (sp-get (syd-get-enclosing-sexp) :beg)))
      (goto-char beg)
      (syd-sexp--backward-attached-comment)
      (let ((col (current-column)))
        (save-excursion
          ;; We want to add an additional blank line when operating at the top
          ;; level.  Instead of parsing upward until we can no longer find an
          ;; enclosing sexp, we simply check if the opening bracket is on the
          ;; first column.  This is not very correct, but it's way less work (for
          ;; myself and the CPU).  If we switch to a tree-sitter–based parser, I'd
          ;; love to switch to the correct algorithm.
          (if (= col 0)
              (newline 2)
            (newline-and-indent)))
        (indent-to col)
        (evil-insert-state 1)))))

(defun syd-sexp-get-last-thing ()
  (-let (((enclosing-beg . enclosing-end)
          (sp-get (syd-get-enclosing-sexp) (cons :beg :end))))
    (save-excursion
      ;; Imperative andy. }:\
      (let (thing)
        (while (sp-get (syd-get-thing)
                 (and (< enclosing-beg :beg enclosing-end)
                      (< enclosing-beg :end enclosing-end))))))))

(defun syd-sexp--looking-at-last-p ()
  "Return non-nil if the sexp beginning at point is the last element of its
enclosing sexp."
  (save-excursion
    (let ((point-0 (point))
          (sexp (sp-get-enclosing-sexp)))
      (sp-next-sexp)
      (if sexp
          (or
           ;; If `sp-next-sexp' moved backwards, `point-0' was the last
           ;; element.
           (<= (point) point-0)
           ;; If `sp-next-sexp' moved outside of the previously-enclosing
           ;; sexp, `point-0' was final.
           (<= (sp-get sexp :end) (point)))
        ;; No enclosing sexp — we're looking at a top-level sexp.
        (= (point) point-0)))))

(defun syd-sexp--next-thing ()
  "Helper for `syd-sexo->'.  Find the next thing relative to the sexp assumed to
begin at point, and the region covering the closing delimiters."
  (save-excursion
    (condition-case err
        (cl-loop for relative-height from 0
                 while (syd-sexp--looking-at-last-p)
                 do (or (sp-backward-up-sexp)
                        ;; Nothing to slurp!
                        (signal 'top))
                 finally return (cons (sp-next-sexp) relative-height))
      (top nil))))

(defun syd-sexp--slurp-forward ()
  "Slurp forward.  Do not call this function directly; see `syd-sexp->'."
  ;; REVIEW: This is rather unoptimised when used with a count.
  (when-let* ((consumer (sp-get-sexp)))
    (goto-char (sp-get consumer :beg))
    (-if-let ((next-thing . relative-height) (syd-sexp--next-thing))
        (progn (goto-char (sp-get consumer :beg-in))
               (sp-forward-slurp-sexp (+ 1 relative-height))
               (sp-get (sp-get-enclosing-sexp)
                 (goto-char (- :end 1))))
      (user-error "ra"))))

(defun syd-sexp--barf-forward ()
  "Barf forward.  Do not call this function directly; see `syd-sexp-<'."
  (sp-forward-barf-sexp))

;;;###autoload
(evil-define-command syd-sexp-> (&optional count)
  (interactive "<c>")
  (evil-with-single-undo
    (when-let* ((sexp (sp-get-sexp)))
      (let ((fn (cond ((= (point) (sp-get sexp (- :end 1)))
                       #'syd-sexp--slurp-forward))))
        (dotimes (_ (or count 1))
          (funcall fn))))))

;;;###autoload
(evil-define-command syd-sexp-< (&optional count)
  (interactive "<c>")
  (evil-with-single-undo
    (when-let* ((sexp (sp-get-sexp)))
      (let ((fn (cond ((= (point) (sp-get sexp (- :end 1)))
                       #'syd-sexp--barf-forward))))
        (dotimes (_ (or count 1))
          (funcall fn))))))

(defun syd-sexp--looking-at-delimiter-p ()
  (sp-get (sp-get-sexp)
    (and (not (sp-point-in-string-or-comment))
         (or (= (point) :beg)
             (= (point) (- :end 1))))))

;; REVIEW: It might be neat to, iff the point is already in a comment/string,
;; goto delimiters that are also in comments/strings.  For now, let's just
;; ignore comments.
(defun syd-sexp--goto-delimiter (delimiter-type direction count)
  (let* ((point-0 (point))
         (delimiters (mapcar (clj-condp eq delimiter-type
                               ('opening #'car)
                               ('closing #'cdr))
                             sp-pair-list))
         (delimiter-regexp (rx-to-string `(or ,@delimiters)))
         (forward-p (clj-condp eq direction
                      ('forward t)
                      ('backward nil)
                      (t (error "todo errrrare"))))
         (move (lambda ()
                 ;; `forward-p' never changes between calls to `move'; we are
                 ;; doing many more checks than we need to.
                 (and (condition-case er
                          (prog1 t (when forward-p
                                     (forward-char)))
                        (end-of-buffer (throw 'no-move 'no-move)))
                      (if (if forward-p
                              (re-search-forward delimiter-regexp nil t)
                            (re-search-backward delimiter-regexp nil t))
                          (goto-char (match-beginning 0))
                        (throw 'no-move 'no-move))))))
    ;; If `syd-sexp--looking-at-delimiter-p' returns nil, we may be looking at
    ;; the right string of characters, but we are likely inside of a string,
    ;; or a comment, or something.  If we aren't at a "real" delimiter, move
    ;; again.
    (let ((r (catch 'no-move
               (dotimes (_ count)
                 (while (and (funcall move)
                             (not (syd-sexp--looking-at-delimiter-p))))))))
      (if (eq r 'no-move)
          (progn (goto-char point-0)
                 (user-error "Nowhere to go"))
        r))))

(evil-define-motion syd-sexp-forward-opening (count)
  (syd-sexp--goto-delimiter 'opening 'forward (or count 1)))

(evil-define-motion syd-sexp-backward-opening (count)
  (syd-sexp--goto-delimiter 'opening 'backward (or count 1)))

(evil-define-motion syd-sexp-forward-closing (count)
  (syd-sexp--goto-delimiter 'closing 'forward (or count 1)))

(evil-define-motion syd-sexp-backward-closing (count)
  (syd-sexp--goto-delimiter 'closing 'backward (or count 1)))

(defun syd-sexp-get-sexp-with-prefix ()
  (-when-let* ((thing (sp-get-thing))
               ;; TODO: Rewrite using :beg-prf
               ((beg . prefix) (sp-get thing (cons :beg :prefix)))
               (prefix-beg (- beg (length prefix))))
    ;; HACK: Relies on Smartparen's internal representation, which
    ;; they explicitly recommend against.  This could break at any
    ;; time!
    ;; Reminder that `plist-put' is an in-place update. }:)
    (plist-put thing :beg prefix-beg)
    (plist-put thing :prefix "")
    (goto-char prefix-beg)
    thing))

(evil-define-motion syd-sexp-next (count)
  "Like `sp-next-sexp', but prefixes will be considered as part of the sexp."
  ;; If point is resting on a prefix when `syd-sexp-next' is called,
  ;; `sp-next-sexp' will move to the beginning of the prefixed form.  This is
  ;; undesirable, as `syd-sexp-next' considers the prefix and the prefixed form
  ;; to be a single thing.  To get around this, we make sure to move point past
  ;; the prefixed sexp.
  (let ((count* (or count 1)))
    (when-let* ((_ (<= 0 count*))
                (first-prefixed-sexp (syd-sexp-get-sexp-with-prefix)))
      (sp-get first-prefixed-sexp
        (when (<= :beg (point) :end)
          (goto-char :end))))
    (let ((current-prefix-arg count*))
      (call-interactively #'sp-next-sexp)))
  (syd-sexp-get-sexp-with-prefix))

(evil-define-motion syd-sexp-previous (count)
  "Like `sp-next-sexp' (as if called with a negative count), but prefixes will
be considered as part of the sexp."
  (syd-sexp-next (- (or count 1))))

;;;###autoload
(evil-define-command syd-sexp-insert ()
  (evil-with-single-undo
    (sp-get (syd-get-enclosing-sexp)
      (goto-char (+ 1 :beg))
      (save-excursion (insert-char ?\s))
      (evil-insert-state 1))))

;;;###autoload
(evil-define-command syd-sexp-append ()
  (evil-with-single-undo
    (sp-get (syd-get-enclosing-sexp)
      (goto-char (- :end 1))
      (evil-insert-state 1))))

;; Text objects.
(general-def
  :keymaps 'syd-lisp-mode-map
  :states '(visual operator)
  "ad" #'syd-evil-a-defun
  "id" #'syd-evil-inner-defun
  "af" #'syd-evil-a-form
  "if" #'syd-evil-inner-form)

;; Bind editing commands in normal node, and motion commands in motion
;; mode.
(general-def
  :keymaps 'syd-lisp-mode-map
  :states 'normal
  ">" #'syd-sexp->
  "<" #'syd-sexp-<
  "M-w" #'syd-wrap-sexp
  "M-r" #'sp-raise-sexp
  "M-c" #'sp-clone-sexp
  "M-S" #'sp-split-sexp
  "M-J" #'sp-join-sexp
  "M-u" #'sp-splice-sexp-killing-backward
  "M-U" #'sp-splice-sexp-killing-around
  "M-v" #'sp-convolute-sexp
  "M-o" #'syd-open-sexp-below
  "M-O" #'syd-open-sexp-above
  "M-i" #'syd-sexp-insert
  "M-a" #'syd-sexp-append)

;; Bind editing commands in normal node, and motion commands in motion
;; mode.
(general-def
  :keymaps 'syd-lisp-mode-map
  :states 'motion
  "C-h" #'sp-backward-up-sexp
  "C-j" #'syd-sexp-next
  "C-k" #'syd-sexp-previous
  "C-l" #'sp-down-sexp
  "(" #'syd-backward-up-sexp
  ")" #'syd-forward-up-sexp
  "{" #'syd-sexp-backward-opening
  "}" #'syd-sexp-forward-opening
  "M-{" #'syd-sexp-backward-closing
  "M-}" #'syd-sexp-forward-closing)

(with-eval-after-load 'smartparens
  (setq
   ;; By default, Smartparens will move backwards to the initial character of
   ;; the enclosing expression, and only move forwards when the point is already
   ;; on that initial character.  This is not expected behaviour for an ex-Vim
   ;; user.
   sp-navigate-interactive-always-progress-point t))

(provide 'syd-lisp-lib)