From f1c952f0b88904eadafd63f677df989f9f81a866 Mon Sep 17 00:00:00 2001
From: Yuchen Pei <hi@ypei.me>
Date: Tue, 6 Sep 2022 12:25:11 +1000
Subject: adding support for find definition in hcel-minor mode

---
 lisp/hcel-source.el | 90 ++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 65 insertions(+), 25 deletions(-)

(limited to 'lisp/hcel-source.el')

diff --git a/lisp/hcel-source.el b/lisp/hcel-source.el
index 31a17e1..e8f91b8 100644
--- a/lisp/hcel-source.el
+++ b/lisp/hcel-source.el
@@ -348,31 +348,71 @@ May cause error if the identifier has exact location."
   (hcel-find-definition))
 
 (defun hcel-find-definition ()
-  (let* ((location-info
-          (hcel-get-location-info (hcel-lookup-identifier-at-point)
-                                  (hcel-lookup-occurrence-at-point))))
-    (when (string= (hcel-location-tag location-info) "ApproximateLocation")
-      (setq location-info (hcel-approx-to-exact-location location-info)))
-    (let ((module-path (alist-get 'modulePath location-info))
-          (line-beg (alist-get 'startLine location-info))
-          (col-beg (alist-get 'startColumn location-info))
-          (line-end (alist-get 'endLine location-info))
-          (col-end (alist-get 'endColumn location-info)))
-      (cond ((string= (hcel-location-tag location-info) "ExactLocation")
-             (let ((pos) (len)
-                   (buffer (hcel-load-module-location-info location-info t)))
-               (with-current-buffer buffer
-                 (save-excursion
-                   (goto-line-column line-beg col-beg)
-                   (setq pos (1- (point)))
-                   (goto-line-column line-end col-end)
-                   (setq len (- (point) pos 1))))
-               (list (xref-make-match
-                      "hcel match"
-                      (xref-make-buffer-location buffer pos)
-                      len))))
-            (t
-             (error "unimplemented: %s" (hcel-location-tag location-info)))))))
+  (hcel-find-definition-internal
+   hcel-package-id hcel-module-path
+   (get-text-property (point) 'identifier)
+   (get-text-property (point) 'occurrence)))
+
+(add-hook 'hcel-minor-mode-hook
+          (lambda ()
+            (add-hook 'xref-backend-functions
+                      #'hcel-minor--xref-backend nil t)))
+(defun hcel-minor--xref-backend () 'hcel-minor-xref)
+(cl-defmethod xref-backend-definitions ((_backend (eql hcel-minor-xref)) _identifiers)
+  (hcel-minor-find-definition-at-point))
+(defun hcel-minor-find-definition-at-point ()
+  (interactive)
+  (let ((props (text-properties-at (point))))
+    (cond ((or (eq major-mode 'hcel-outline-mode)
+               (eq (current-buffer) eldoc--doc-buffer))
+           (hcel-find-definition-internal
+            (plist-get props 'package-id)
+            (plist-get props 'module-path)
+            (plist-get props 'internal-id)))
+          ((eq major-mode 'hcel-ids-mode)
+           (hcel-find-definition-internal
+            (alist-get 'packageId (plist-get props 'location-info))
+            (alist-get 'modulePath (plist-get props 'location-info))
+            (plist-get props 'internal-id)))
+          (t (error "%S not supported and not in eldoc doc buffer." major-mode)))))
+
+(defun hcel-find-definition-internal (package-id module-path identifier
+                                                 &optional occurrence)
+  (when (and package-id module-path (or identifier occurrence))
+    (let ((hcel-buffer (hcel-buffer-name package-id module-path)))
+      (when (or (get-buffer hcel-buffer)
+                (and (y-or-n-p "Open module source?")
+                     (hcel-load-module-source
+                      package-id module-path))))
+      (with-current-buffer hcel-buffer
+        (let ((location-info
+               (hcel-get-location-info
+                (when identifier
+                  (alist-get (intern identifier) hcel-identifiers))
+                (when occurrence
+                  (alist-get (intern occurrence) hcel-occurrences)))))
+          (when (string= (hcel-location-tag location-info) "ApproximateLocation")
+            (setq location-info (hcel-approx-to-exact-location location-info)))
+          (let ((module-path (alist-get 'modulePath location-info))
+                (line-beg (alist-get 'startLine location-info))
+                (col-beg (alist-get 'startColumn location-info))
+                (line-end (alist-get 'endLine location-info))
+                (col-end (alist-get 'endColumn location-info)))
+            (cond ((string= (hcel-location-tag location-info) "ExactLocation")
+                   (let ((pos) (len)
+                         (buffer (hcel-load-module-location-info location-info t)))
+                     (with-current-buffer buffer
+                       (save-excursion
+                         (goto-line-column line-beg col-beg)
+                         (setq pos (1- (point)))
+                         (goto-line-column line-end col-end)
+                         (setq len (- (point) pos 1))))
+                     (list (xref-make-match
+                            "hcel match"
+                            (xref-make-buffer-location buffer pos)
+                            len))))
+                  (t
+                   (error "unimplemented: %s" (hcel-location-tag location-info))))))))))
 
 ;; hcel-minor mode
 (defvar hcel-minor-major-modes
-- 
cgit v1.2.3