;;; my-elisp-eldoc-funcall.el ---            -*- lexical-binding: t; -*-

;; Copyright (C) 2022 AKIYAMA Kouhei

;; Author: AKIYAMA Kouhei <misohena@gmail.com>
;; Keywords: lisp, languages

;; This program is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.

;; This program is distributed in the hope that it will be useful,
;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;; GNU General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program.  If not, see <https://www.gnu.org/licenses/>.

;;; Commentary:

;; `elisp-eldoc-funcall'には`cl-defmethod'で定義したメソッドの引数表示
;; に問題があったので代わりとして作成しました。

;; - 全てのメソッドの引数列を表示します。
;; - 括弧で囲まれた一つの引数(VAR TYPE)を正しく一つとして扱います。
;; - &keyで定義したキーワード引数をより正しく処理します。

;; `cl-defun'で定義した関数もほぼ同じ問題があるのでこれにも対処します。
;; ただし通常の`defun'で定義した関数と区別が付かず問題の無い関数も新し
;; いやり方で処理してしまうのでこれまでうまく行っていたものがうまく行
;; かなくなるケースがあるかもしれません。

;; 例えば`setq'の[SYM VAL]...といった表記は私のやり方では正しく処理できないので
;; [ ] ... を検索してマッチしたら従来のやり方で処理するようにしてあります。
;; 他にもこのような事があるかもしれません。

;; 使い方:
;; (require 'cl-lib)
;; (autoload 'my-elisp-eldoc-funcall "my-elisp-eldoc-funcall")
;; (add-hook 'emacs-lisp-mode-hook
;;           (lambda ()
;;             (setq eldoc-documentation-functions
;;                   (cl-substitute
;;                    'my-elisp-eldoc-funcall
;;                    'elisp-eldoc-funcall
;;                    eldoc-documentation-functions))))

;;; Code:

(require 'cl-lib)
(require 'subr-x)

(defun my-elisp-eldoc-funcall (callback &rest _ignored)
  "Document function call at point.
Intended for `eldoc-documentation-functions' (which see)."
  (save-excursion
    (unless (nth 8 (syntax-ppss)) ;;When not in a comment
      (when-let* ((sexp-positions (or (my-elisp--beginning-of-sexp)
                                   (list (point))))
                  (sexp-index (1- (length sexp-positions)))
                  (sym (elisp--current-symbol))
                  (str (my-elisp-eldoc-funcall-arg-list-string
                        sym sexp-positions sexp-index)))
        (funcall
         callback
         str
         :thing sym
         :face (if (functionp sym)
                   'font-lock-function-name-face
                 'font-lock-keyword-face))))))

(defun my-elisp--beginning-of-sexp () ;;derived from elisp--beginning-of-sexp
  "Move to the beginning of the current sexp and return sub-sexp positions."
  (let ((parse-sexp-ignore-comments t)
        positions)
    (ignore-errors
      (progn
        ;; First account for the case the point is directly over a
        ;; beginning of a nested sexp.
        (ignore-errors
          (let ((p (point)))
            (forward-sexp -1)
            (forward-sexp 1)
            (when (< (point) p)
              (push p positions))))
        (while
            (let ((p (point)))
              (forward-sexp -1)
              (when (< (point) p)
                (push (point) positions))))))
    positions))

(defcustom my-elisp-eldoc-funcall-enabled t
  ""
  :type '(choice (const :tag "Enabled" t)
                 (const :tag "CL Method Only" 'cl-generic-only)
                 (const :tag "Disabled" nil))
  :group 'eldoc)

(defun my-elisp-eldoc-funcall-arg-list-string (sym sexp-positions sexp-index)
  (cond
   ;; Conventional method
   ((not my-elisp-eldoc-funcall-enabled)
    (elisp-get-fnsym-args-string sym sexp-index))
   ;; cl-generic
   ((when-let ((generic (cl--generic sym)))
      (cl-loop for method in (cl--generic-method-table generic)
               ;;for info = (cl--generic-method-info method)
               for info = (my-elisp-cl-generic-method-info method)
               for qual-string = (nth 0 info)
               when (string-empty-p qual-string)
               for arg-list = (nth 1 info)
               concat "\n"
               concat (or qual-string "")
               concat (my-elisp-format-cl-arg-list arg-list
                                                   sexp-positions
                                                   sexp-index))))
   ;; function or macro
   ((eq my-elisp-eldoc-funcall-enabled 'cl-generic-only)
    ;; Conventional method
    (elisp-get-fnsym-args-string sym sexp-index))
   (t
    (my-elisp-get-fnsym-args-string sym sexp-positions sexp-index))))

(defun my-elisp-format-cl-arg-list (arg-list sexp-positions sexp-index)
  (let* ((arg-list-info (ignore-errors (my-elisp-parse-cl-arg-list arg-list)))
         (vars-count     (or (nth 0 arg-list-info) 0))
         (optional-vars  (nth 1 arg-list-info))
         (rest-var-index (nth 2 arg-list-info))
         (key-spec       (nth 3 arg-list-info))
         ;;(allow-other-keys (car key-spec))
         (keywords (cdr key-spec))
         (optional-start (+ 1 vars-count))
         (rest-start (+ 1 vars-count (length optional-vars)))
         highlight-arg-indices)
    ;; Make highlight-arg-indices
    (cond
     ;; function name
     ((< sexp-index 1) )
     ;; required argument
     ((< sexp-index optional-start)
      (push (1- sexp-index) highlight-arg-indices))
     ;; optional argument
     ((< sexp-index rest-start)
      ;; &optional a &optional b のような表記があり得るので
      ;; 必ずoptional-varsからインデックス値を求める必要がある。
      (push (nth (- sexp-index optional-start) optional-vars)
            highlight-arg-indices))
     ;; rest or keyword argument
     (t
      (when-let ((kw-pos (nth (+ rest-start
                                 (logand (- sexp-index rest-start) -2))
                              sexp-positions))
                 (kw (progn
                       (goto-char kw-pos)
                       (sexp-at-point))))
        (when (eq (car-safe kw) 'quote)
          (setq kw (cadr kw)))
        (when (symbolp kw)
          ;;@todo 既に指定されているキーワードはハイライトしない。
          ;;      二つ目以降のキーワード指定は無効なので。
          (when-let ((kw-index (alist-get (symbol-name kw) keywords nil nil #'cl-equalp))) ;;大文字小文字を無視するためにcl-equalpを使う。cl-defun等はキーワードを勝手に大文字化してドキュメントに登録したりしなかったりするのでどうしようもない。
            (push kw-index highlight-arg-indices))))
      (when rest-var-index
        ;;@todo key-specがありallow-other-keysでは無く無効なキーワード
        ;;がある場合はrestをハイライトしない。それによってエラーを表現
        ;;する。いや、でも実行しないとキーワードが分からない場合がある
        ;;しなぁ。
        (push rest-var-index highlight-arg-indices))))
    ;; Make arg-list string
    (concat
     "("
     (cl-loop for i from 0
              for arg in arg-list
              for arg-str = (format "%S" arg)
              when (> i 0) concat " "
              concat (if (memq i highlight-arg-indices)
                         (propertize arg-str
                                     'face 'eldoc-highlight-function-argument)
                       arg-str))
     ")")))

(defun my-elisp-parse-cl-arg-list (arg-list)
  ;; (VAR...
  ;;  [&optional (VAR [INITFORM [SVAR]])...]
  ;;  [&rest|&body VAR]
  ;;  [&key (([KEYWORD] VAR) [INITFORM [SVAR]])... [&allow-other-keys]]
  ;;  [&aux (VAR [INITFORM])...])
  (when (memq '&environment arg-list)
    (error "&environment used incorrectly"))
  (cl-macrolet ((inc () `(progn (setq p (cdr p) ai (1+ ai)))))
    (let*
        ((p arg-list)
         (ai 0)
         (lambda-keywords '(&optional &rest &body &key &allow-other-keys
                                      &aux &whole))
         ;;@tood parse &whole?
         (vars-count
          (progn
            (while (and p (not (memq (car p) lambda-keywords)))
              (inc))
            ai))
         (optional-vars
          (let (lst)
            (while (eq (car p) '&optional) ;;while! see:`cl--do-arglist'
              (inc)
              (while (and p (not (memq (car p)  lambda-keywords)))
                (push ai lst)
                (inc)))
            (nreverse lst)))
         (rest-var-index
          (when (memq (car p) '(&rest &body))
            (inc)
            ;; VAR is optional and accepts lambda-keywords!
            ;; see:`cl--do-arglist'
            ;; (when (or (null p)
            ;;           (memq (car p) lambda-keywords))
            ;;   (message "Unexpected %s, expected VAR" (car p))
            ;;   (error "Malformed argument list ends with: %s" p))
            (if (null p)
                nil
              (inc)
              (1- ai))))
         (keyword-spec-p (eq (car p) '&key))
         (keywords
          (let (lst) ;; list of (key . i)
            (while (eq (car p) '&key) ;;while! see:`cl--do-arglist'
              (inc)
              (while (and p (not (memq (car p) lambda-keywords)))
                ;; KEYWORD => :KEYWORD
                ;; (KEYWORD [INITFORM [SVAR]])
                ;; ((KEYWORD VAR) [INITFORM [SVAR]])
                ;; (key . ai)のkeyはシンボルではなく文字列にする。
                ;; 後で大文字小文字を無視した比較がしたいので。
                (pcase (car p)
                  ((and (pred symbolp) key)
                   (push (cons (concat ":" (symbol-name key)) ai) lst))
                  (`(,(and (pred symbolp) key) . ,_)
                   (push (cons (concat ":" (symbol-name key)) ai) lst))
                  (`((,(and (pred symbolp) key) . ,_) . ,_)
                   (push (cons (symbol-name key) ai) lst))
                  (_
                   (message "Unexpected keyword pattern")
                   (error "Malformed argument list ends with: %s" p)))
                (inc)))
            (unless (memq (car p) '(nil &allow-other-keys &aux))
              (message
               "Unexpected %s, expected nil, &allow-other-keys or &aux" (car p))
              (error "Malformed argument list ends with: %s" p))
            (nreverse lst)))
         (allow-other-keys
          (when (and keyword-spec-p
                     (eq (car p) '&allow-other-keys))
            (inc))))
      ;; Ignore &aux
      (unless (memq (car p) '(nil &aux))
        (message "Unexpected %s, expected nil or &aux" (car p))
        (error "Malformed argument list ends with: %s" p))
      (list
       vars-count
       optional-vars
       rest-var-index
       (when keyword-spec-p
         (cons
          allow-other-keys
          keywords))))))


(defun my-elisp-cl-generic-method-info (method)
  ;; `cl--generic-method-info'の代わり。
  ;;
  ;; `cl--generic-method-info'は`help-function-arglist'を呼び出している。
  ;; しかし`help-function-arglist'は正しい引数名を返せない場合がある。
  ;; メソッドが&key等cl独自の表記を採用している場合。
  ;; `cl-defmethod'は&restや&key等が使われている時はdocstringを追加して本来の
  ;; 引数列を示すが、`help-function-arglistはdocstring'よりもclosureの引数列
  ;; を優先して取り出すため本来の引数列が取得できない。
  ;;
  ;; ここでは強制的にドキュメント文字列からarglistを取得させる。
  ;; ドキュメントが無いときは本来の関数を使う。
  ;; ドキュメントが無いときは関数の引数列から本来の引数列が取得できるとき。
  (cl-letf* ((old-help-function-arglist
              (symbol-function 'help-function-arglist))
             ((symbol-function 'help-function-arglist)
              (lambda (def &optional preserve-names)
                (or (my-elisp-cl-generic-method-help-function-arglist
                     def preserve-names)
                    (funcall old-help-function-arglist def preserve-names)))))
    (cl--generic-method-info method)))

(defun my-elisp-cl-generic-method-help-function-arglist (def &optional
                                                             _preserve-names)
  ;; `help-function-arglist'の代わり。
  ;; `help-function-arglist'内のdocstringから引数リストを取得するケースを
  ;; 再現している。
  (when-let ((doc (documentation def))
             (doc-arglist (car (help-split-fundoc doc 'fname))))
    (cdar (read-from-string doc-arglist)))) ;;downcase?

(defun my-elisp-help-function-arg-list (def &optional preserve-names)
  (or (my-elisp-cl-generic-method-help-function-arglist def preserve-names)
      (help-function-arglist def preserve-names)))


(defun my-elisp-get-fnsym-args-string (sym sexp-positions sexp-index)
  (cond
   ((not (and sym (symbolp sym) (fboundp sym))) nil)
   ;;@todo キャッシュ
   ;; ((and (eq sym (aref elisp--eldoc-last-data 0))
   ;;       (eq 'function (aref elisp--eldoc-last-data 2)))
   ;;  (aref elisp--eldoc-last-data 1))
   ((when-let ((advertised (gethash (indirect-function sym)
                                    advertised-signature-table t)))
      (when (listp advertised)
        (my-elisp-format-cl-arg-list advertised sexp-positions sexp-index))))
   ;; setqにあるような [ ] ... という表記には対応していないので見つけ次第
   ;; 元のやり方で処理する。
   ;;@todo むしろ &keyや分割代入や初期値が無い限り元のやり方にする？ 大文字小文字問題がある。
   ((when-let ((doc (car (help-split-fundoc
                          (condition-case nil (documentation sym t)
                            (invalid-function nil))
                          sym))))
      (when (string-match-p "\\[.+\\]\\|\\.\\.\\." doc)
        (elisp--highlight-function-argument
         sym
         (elisp-function-argstring (substitute-command-keys doc)) sexp-index))))
   ((when-let ((arg-list (my-elisp-help-function-arg-list sym)))
      (my-elisp-format-cl-arg-list arg-list sexp-positions sexp-index)))))

;; (setq ← [SYM VAL]...のような表記を使用している例。
;; (seq-filter ←cl-defgenericやcl-defmethodで定義している例。
;; (sit-for ←advertiseを使っている例。
;; (cl-parse-integer ←cl-defunで定義している例。
;; (cl-defun test-clfun (a b &optional (c 1) (d 2) &rest args &key e (f 1) ((g g-arg) 2) &allow-other-keys &aux (h 100)) (list a b c d e f g-arg h))


(provide 'my-elisp-eldoc-funcall)
;;; my-elisp-eldoc-funcall.el ends here