harehelper

;;; haredoc.el --- Haredoc Integration -*- lexical-binding: t -*-

;; Author: Lou Woell
;; Version: 0.1
;; Package-Requires: ((emacs "29.1") (f "0.21.0"))
;; URL: https://git.repetitions.de/harehelper/
;; Keywords: languages matching tools

;; This file is not part of GNU Emacs

;; 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 detai

;; 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:

;; `haredoc.el' provides an Emacs interface for `haredoc' using harehelper. The
;; main entry points are, `haredoc' and `haredoc/describe-thing-at-point', as
;; well as the `xref' backend.

;; To enable the default keymap in hare-mode, add `haredoc-nav-mode' to your
;; `hare-mode-hook':

;; `(add-hook 'hare-mode-hook #'haredoc-nav-mode)'

;; Requires the Harehelper executable. Search location for the binary can be
;; customized via `haredoc-default-helper-loc', `haredoc-default-helper-bin' or
;; `haredoc-helperbin' directly.

;;; TODO:

;; - melpa compatible setup
;; - imenu integration
;; - eldoc integration?

;;; Code:

(require 'f)
(require 'button)
(require 'project)
(require 'thingatpt)
(require 'ansi-color)
(require 'xref)

(defcustom haredoc-default-helper-bin "harehelper"
  "Default Name of the Harehelper binary.

Used to initialize `haredoc-default-helper-loc' and `haredoc-helperbin'."
  :type 'file
  :group 'haredoc)

(defcustom haredoc-default-helper-loc (expand-file-name haredoc-default-helper-bin
                                                        (f-dirname (macroexp-file-name)))
  "Default value for `haredoc-helperbin'.

Defaults to directory containing this source file."
  :type 'file
  :group 'haredoc)

(defcustom haredoc-helperbin
  (or (and (f-exists? haredoc-default-helper-loc)
           haredoc-default-helper-loc)
      (executable-find haredoc-default-helper-bin)
      (error "Harehelper executable not found."))
  "Location of the harehelper executable.

Defaults to `haredoc-default-helper-loc' if that exists, otherwise looks
for `haredoc-default-helper-bin' in `exec-path'."
  :type 'file
  :group 'haredoc)

(defconst haredoc-symbol-regex "[\\*&]*\\(\\(\\(\\sw\\|\\s_\\)+::\\)*\\(\\sw\\|\\s_\\)+\\)"
  "Regex matching hare identifiers. Explixcitely ignores leading * and &.")
(defconst haredoc-decl-regex "^\\(fn\\|type\\|def\\|const\\|let\\) ")
(defconst haredoc-link-regex "\\[\\[\\(.*?\\)\\]\\]" )

(defmacro haredoc|harehelper (&rest args)
  "Run harehelper with arguments ARGS."
  `(catch 'exit
     (process-lines-handling-status haredoc-helperbin
                                    (lambda (x)
                                      (unless (= x 0)
                                        (throw 'exit nil)))
                                    ,@args)))

(defun haredoc/root-dir ()
  "Return root directory of current project or \".\"."
  (interactive)
  (if-let ((p (project-current nil)))
      (expand-file-name (project-root p))
    "."))

(defun haredoc/get-modules ()
  "Return list of Hare modules."
  (haredoc|harehelper "-p" (haredoc/root-dir) "list-modules"))

(defun haredoc/read-module (&optional init)
  "Ask user to pick from a list of installed hare modules."
  (completing-read "Pick Module: " (haredoc/get-modules) nil nil init))

(defun haredoc/identifier-at-point ()
  "Return hare identifier of the form foo::bar at point, using
`haredoc-symbol-regex'."
  (let ((id (if (use-region-p) ;; Use region or the current word
                (buffer-substring-no-properties (region-beginning)
                                                (region-end))
              (thing-at-point-looking-at haredoc-symbol-regex)
              (match-string 1))))
    ;; resolve identifier
    (car (haredoc|harehelper "-p" (haredoc/root-dir)
                             "resolve" id
                             (buffer-file-name)))))

(define-button-type 'haredoc
  'action #'haredoc/button-action
  'help-echo (purecopy "mouse-1, RET: describe this"))

(define-button-type 'haredoc-module
  'action #'(lambda (x) (ignore x) (haredoc/widen))
  'help-echo (purecopy "mouse-1, RET: describe module"))

(define-button-type 'haredoc-back
  'action #'haredoc/back
  'help-echo (purecopy "go back"))

(define-button-type 'haredoc-forw
  'action #'haredoc/forward
  'help-echo (purecopy "go forward"))

(defun haredoc/button-action (button)
  (haredoc (button-get button :target)))

(defun haredoc/make-button (match-number module)
  (let* ((name (match-string match-number))
         (namespace? (string-match-p ".*::.*" name))
         (target (if namespace? name
                   (string-join (list module name) "::"))))
    (make-text-button (match-beginning match-number)
                      (match-end match-number)
                      :type 'haredoc
                      :target target)))

;; State variables for haredoc history.
(defvar-local haredoc-backward-stack '()
  "Stack for `haredoc/back'.")
(put 'haredoc-backward-stack 'permanent-local t)
(defvar-local haredoc-forward-stack '()
  "Stack for `haredoc/forward'.")
(put 'haredoc-forward-stack 'permanent-local t)
(defvar-local haredoc-stack-item nil
  "State variable for `haredoc/back' and `haredoc/forward'.")
(put 'haredoc-stack-item 'permanent-local t)

(defvar-local haredoc-current-ns nil
  "Namespace of the hare documentation shown in current `haredoc-mode'
buffer.

If currently showing documentation for a module, this is set to the
module name. See also `haredoc-parent-ns'.")
(put 'haredoc-current-ns 'permanent-local t)

(defvar-local haredoc-current-path nil
  "Hare identifier that produced the documentation currently shown in
`haredoc-mode' buffer.")
(put 'haredoc-current-path 'permanent-local t)

(defvar-local haredoc-parent-ns nil
  "Parent namespace of the hare documentation shown in the current
`haredoc-mode' buffer.

For everything but modules this will be equal to `haredoc-current-ns'.")
(put 'haredoc-parent-ns 'permanent-local t)

(defun haredoc/back (&optional args)
  "Go to previously shown hare documentation in current `haredoc-mode'
buffer. See also `haredoc/forward'."
  (interactive)
  (ignore args)
  (when-let ((item (pop haredoc-backward-stack)))
    (push haredoc-stack-item haredoc-forward-stack)
    (setq haredoc-stack-item nil)
    (haredoc item)))

(defun haredoc/forward (&optional args)
  "Inverse of `haredoc/back'."
  (interactive)
  (ignore args)
  (when-let ((item (pop haredoc-forward-stack)))
    (push haredoc-stack-item haredoc-backward-stack)
    (setq haredoc-stack-item nil)
    (haredoc item)))

;;;###autoload
(defun haredoc (id)
  "Run haredoc with hare identifier ID and present result in help buffer.
If called interactively, ask user for ID."
  (interactive (list (haredoc/read-module)))
  (when-let* ((id id)
              (components (string-split id "::" t))
              (loc (haredoc/get-location id))
              (path (xref-file-location-file (xref-item-location loc)))
              (parent-ns (if (length> components 1)
                             (string-join (butlast components) "::")
                           (car components)))
              (current-ns (if (f-directory? path)
                              (string-trim-right id "::")
                            parent-ns)))
    (when haredoc-stack-item
      (push haredoc-stack-item haredoc-backward-stack)
      (setq haredoc-forward-stack nil))
    (setq haredoc-stack-item id)

    (let ((buffer (get-buffer-create "*haredoc*"))
          (inhibit-read-only t))
      (with-current-buffer buffer
        (erase-buffer)
        (setq haredoc-current-path id
              haredoc-current-ns current-ns
              haredoc-parent-ns parent-ns)
        (ensure-empty-lines 1)

        (with-environment-variables
            (("FORCE_COLOR" "yes please")
             ("HAREPATH" (car (haredoc|harehelper "-p" (haredoc/root-dir)
                                                  "-P"))))
          (call-process "haredoc" nil t nil "-a" "-F" "tty" id))

        (ansi-color-apply-on-region (point-min) (point-max))

        (save-excursion
          (goto-char (point-min))
          (while (re-search-forward haredoc-link-regex nil t)
            (haredoc/make-button 1 current-ns))

          (goto-char (point-max))
          (when (or (length> components 1)
                    haredoc-backward-stack
                    haredoc-forward-stack)
            (ensure-empty-lines 2)
            (when haredoc-backward-stack
              (insert-text-button "[back]" :type 'haredoc-back)
              (insert "  "))
            (when (length> components 1)
              (insert-text-button "[up]" :type 'haredoc-module)
              (insert "  "))
            (when haredoc-forward-stack
              (insert-text-button "[forw]" :type 'haredoc-forw))
            (insert "\n")))

        (goto-char (point-min))
        (haredoc-mode)
        (display-buffer buffer)))))

;;;###autoload
(defun haredoc/describe-thing-at-point ()
  "Show documentation for hare identifier at point via `haredoc'."
  (interactive)
  (haredoc (haredoc/identifier-at-point)))

(defun haredoc/get-location (name)
  "Get the location of the declaration of hare identifier NAME by calling
the executable at `haredoc-helperbin'."
  (when-let* ((loc (car (haredoc|harehelper "-p" (haredoc/root-dir)
                                            "locate" name)))
              (loc (split-string loc ":"))
              (file (nth 0 loc))
              (line (string-to-number (nth 1 loc)))
              (col  (string-to-number (nth 2 loc)))
              (sum (or (nth 3 loc) name)))
    (xref-make sum (xref-make-hare-location file line col))))

;;;###autoload
(defun haredoc/goto-definition (&optional name)
  "Go to definition of hare identifier NAME.

See `haredoc/identifier-at-point' and `haredoc/get-location'."
  (interactive)
  (when-let* ((name (or name (haredoc/identifier-at-point)))
              (loc (haredoc/get-location name)))
    (xref-pop-to-location loc)))

(defun haredoc/next-decl ()
  "In `haredoc-mode' buffer, jump to next declaration."
  (interactive)
  (forward-line 1)
  (re-search-forward haredoc-decl-regex)
  (goto-char (match-end 0)))

(defun haredoc/prev-decl ()
  "In `haredoc-mode' buffer, jump to previous declaration."
  (interactive)
  (forward-line -1)
  (re-search-backward haredoc-decl-regex)
  (goto-char (match-end 0)))

(defun haredoc/widen ()
  "In `haredoc-mode' buffer, show documentation for namespace containing
currently documented identifier."
  (interactive)
  (haredoc haredoc-parent-ns))

(defun haredoc/get-decl-apt ()
  (let ((re (string-join (list haredoc-decl-regex
                               haredoc-symbol-regex))))
    (thing-at-point-looking-at re)
    (string-join (list haredoc-current-ns (match-string 2)) "::")))

(defun haredoc/narrow ()
  "In `haredoc-mode' buffer, narrow documentation to documentation of
declaration at point."
  (interactive)
  (haredoc (haredoc/get-decl-apt)))

(defun haredoc/goto-src ()
  "In `haredoc-mode' buffer, jump to source code of declaration at point."
  (interactive)
  (when (derived-mode-p 'haredoc-mode)
    (haredoc/goto-definition (haredoc/get-decl-apt))))

(defvar-keymap haredoc-map
  "C-c C-h" 'haredoc
  "C-c C-d" 'haredoc/describe-thing-at-point)

;;;###autoload
(define-minor-mode haredoc-nav-mode
  "Enable navigation of hare symbols and easy access to haredoc pages."
  :keymap haredoc-map
  :group 'haredoc
  (add-hook 'xref-backend-functions
            #'haredoc-xref-backend nil t))

(defvar-keymap haredoc-mode-map
  "C-c C-h" 'haredoc
  "s" 'haredoc/goto-src
  "<" 'haredoc/back
  ">" 'haredoc/forward
  "n" 'haredoc/next-decl
  "p" 'haredoc/prev-decl
  "d" 'haredoc/narrow
  "w" 'haredoc/widen)

(define-derived-mode haredoc-mode help-mode "🐇"
  "Major mode for navigating hare documentation."
  :group 'haredoc
  (setq header-line-format
        `((:propertize ,haredoc-current-path face bold))))

;;; xref backend

;;;###autoload
(defun haredoc-xref-backend ()
  "Xref backend for hare."
  (if (derived-mode-p 'hare-mode)
      'haredoc-xref
    nil))

(cl-defstruct (xref-hare-location
               (:constructor xref-make-hare-location (file line column))
               (:include xref-file-location))
  "Location in a Hare source file.

This specialized class is needed to get around some issues with how the
hare lexer counts position.")

(cl-defmethod xref-location-marker ((l xref-hare-location))
  (pcase-let (((cl-struct xref-file-location file line column) l))
    (with-current-buffer
        (or (get-file-buffer file)
            (let ((find-file-suppress-same-file-warnings t))
              (find-file-noselect file)))
      (save-restriction
        (widen)
        (save-excursion
          (goto-char (point-min))
          (ignore-errors
            ;; xref location may be out of date; it may be past the end of the
            ;; current file, or the file may have been deleted. Return a
            ;; reasonable location; the user will figure it out.
            (beginning-of-line line)
            ;; the hare lexer counts tabs as 8 columns so we have to use columns
            ;; instead of characters.
            (move-to-column column)
            ;; hack to get around the hare lexers weird location tracking.
            ;; Should probably be handeled in harehelper at some point.
            (while (looking-at-p "\n")
              (forward-line 1)
              (move-to-column column)))
          (point-marker))))))

(cl-defmethod xref-backend-identifier-at-point
  ((_backend (eql 'haredoc-xref)))
  (haredoc/identifier-at-point))

(cl-defmethod xref-backend-definitions ((_backend (eql 'haredoc-xref))
                                        symbol)
  (when-let* ((id symbol)
              (loc (haredoc/get-location id)))
    (list loc)))

(cl-defmethod xref-backend-identifier-completion-table
  ((_backend (eql 'haredoc-xref)))
  '())

(cl-defmethod xref-backend-references ((_backend (eql 'haredoc-xref))
                                       identifier)
  (let* ((lines (haredoc|harehelper "-p" (haredoc/root-dir)
                                    "find-references"
                                    identifier
                                    (haredoc/root-dir))))
    (mapcar (lambda (line)
              (let* ((loc (string-split line ": " t))
                     (summary (string-join (cdr loc) " "))
                     (loc (string-split (car loc) ":" t))
                     (file (nth 0 loc))
                     (line (string-to-number (nth 1 loc)))
                     (col (string-to-number (nth 2 loc))))
                (xref-make summary (xref-make-hare-location file line col))))
            lines)))

(provide 'haredoc)
;;; haredoc.el ends here