add eldoc feature to hcel-minor

1 files changed, 113 insertions, 47 deletions

diff --git a/lisp/hcel-source.el b/lisp/hcel-source.el
index e8f91b8..587f2c2 100644
--- a/lisp/hcel-source.el
+++ b/lisp/hcel-source.el
@@ -102,18 +102,6 @@ If NO-JUMP is non-nil, just open the source and does not jump to the location wi
 		   'hcel-mode)))))
 (define-key hcel-mode-map "b" 'hcel-switch-buffer)
 
-(defun hcel-definition-site-at-point ()
-  "Call definitionSite for identifier at point.
-
-May cause error if the identifier has exact location."
-  (hcel-definition-site-location-info
-   (hcel-get-location-info (hcel-lookup-identifier-at-point)
-                           (hcel-lookup-occurrence-at-point))))
-
-(defun hcel-lookup-identifier-at-point ()
-  (when-let ((identifier (get-text-property (point) 'identifier)))
-    (alist-get (intern identifier) hcel-identifiers)))
-
 (defun hcel-lookup-occurrence-at-point ()
   (when-let ((occurrence (get-text-property (point) 'occurrence)))
     (alist-get (intern occurrence) hcel-occurrences)))
@@ -133,42 +121,61 @@ May cause error if the identifier has exact location."
 
 (defun hcel-type-at-point ()
   (interactive)
-  (let ((identifier (hcel-lookup-identifier-at-point)))
-    (when-let ((id-type
-                (or (alist-get 'idType identifier)
-                    (alist-get 'idOccType (hcel-lookup-occurrence-at-point)))))
-      (concat
-       (hcel-render-id-type id-type)
-       (when-let* ((external-id (alist-get 'externalId identifier))
-                   (splitted (split-string external-id "|"))
-                   (package-id (car splitted))
-                   (module-name (cadr splitted)))
-         (concat "\nDefined in: " package-id " " module-name ""))))))
-
-(defun hcel-hoogle-docs-at-point ()
-  (when-let* ((location-info
-               (hcel-get-location-info (hcel-lookup-identifier-at-point)
-                                       (hcel-lookup-occurrence-at-point)))
-              (package-id (alist-get 'packageId location-info))
+  (hcel-render-type-internal hcel-package-id hcel-module-path
+                             (get-text-property (point) 'identifier)))
+
+(defun hcel-render-type-internal (package-id module-path identifier)
+  (when (and package-id module-path identifier)
+    (let ((hcel-buffer (hcel-buffer-name package-id module-path)))
+      (when (get-buffer hcel-buffer)
+        (with-current-buffer hcel-buffer
+          (when-let* ((id (alist-get (intern identifier)  hcel-identifiers))
+                      (id-type
+                       (or (alist-get 'idType id)
+                           (alist-get 'idOccType
+                                      (hcel-lookup-occurrence-at-point)))))
+            (concat
+             (hcel-render-id-type id-type)
+             (when-let* ((external-id (alist-get 'externalId id))
+                         (splitted (split-string external-id "|"))
+                         (package-id (car splitted))
+                         (module-name (cadr splitted)))
+               (concat "\nDefined in: " package-id " " module-name "")))))))))
+
+(defun hcel-hoogle-docs-location-info (location-info)
+  (when-let* ((package-id (alist-get 'packageId location-info))
               (module-name (alist-get 'moduleName location-info))
               (entity (alist-get 'entity location-info))
               (name (alist-get 'name location-info)))
     (hcel-api-hoogle-docs package-id module-name entity name)))
 
 (defun hcel-id-docs-at-point ()
-  (when-let
-      ((docs
-        (or
-         ;; same module
-         (alist-get 'doc (hcel-lookup-identifier-at-point))
-         ;; other module
-         (alist-get 'documentation
-                    (ignore-errors (hcel-definition-site-at-point)))
-         ;; hoogle
-         (when-let ((hoogle-docs
-                     (ignore-errors (hcel-hoogle-docs-at-point))))
-           (when (length> hoogle-docs 0) (concat "Hoogle: " hoogle-docs))))))
-    (hcel-render-html docs)))
+  (hcel-id-docs-internal hcel-package-id hcel-module-path
+                         (get-text-property (point) 'identifier)))
+
+(defun hcel-id-docs-internal (package-id module-path identifier)
+  (when (and package-id module-path identifier)
+    (let ((hcel-buffer (hcel-buffer-name package-id module-path)))
+      (when (get-buffer hcel-buffer)
+        (with-current-buffer hcel-buffer
+          (when-let*
+              ((id (alist-get (intern identifier) hcel-identifiers))
+               (location-info (hcel-get-location-info id nil))
+               (docs
+                (or
+                 ;; same module
+                 (alist-get 'doc id)
+                 ;; other module
+                 (alist-get
+                  'documentation
+                  (ignore-errors
+                    (hcel-definition-site-location-info location-info)))
+                 ;; hoogle
+                 (when-let ((hoogle-docs
+                             (ignore-errors
+                               (hcel-hoogle-docs-location-info location-info))))
+                   (when (length> hoogle-docs 0) (concat "Hoogle: " hoogle-docs))))))
+            (hcel-render-html docs)))))))
 
 ;; TODO: multiple expressions
 (defun hcel-expressions-type (beg end)
@@ -185,8 +192,8 @@ May cause error if the identifier has exact location."
         (when-let ((expr
                     (ignore-errors
                       (hcel-api-expressions hcel-package-id
-                                        hcel-module-path line-beg col-beg
-                                        line-end col-end))))
+                                            hcel-module-path line-beg col-beg
+                                            line-end col-end))))
           (unless (length= expr 0)
             (hcel-expression-and-type (elt expr (1- (length expr))))))))))
 
@@ -215,6 +222,37 @@ May cause error if the identifier has exact location."
     (with-current-buffer eldoc--doc-buffer
       (hcel-minor-mode))))
 
+(defun hcel-minor-eldoc-id-type (cb)
+  (when-let* ((props (text-properties-at (point)))
+              (identifier (plist-get props 'internal-id))
+              (symbol (save-excursion
+                        (buffer-substring
+                         (progn
+                           (text-property-search-backward
+                            'internal-id identifier 'string=)
+                           (point))
+                         (progn
+                           (text-property-search-forward
+                            'internal-id identifier 'string=)
+                           (point)))))
+              (docstring
+               (cond ((eq major-mode 'hcel-outline-mode)
+                      (hcel-render-type-internal
+                       (plist-get props 'package-id)
+                       (plist-get props 'module-path)
+                       identifier))
+                     ((eq major-mode 'hcel-ids-mode)
+                      (hcel-render-type-internal
+                       (alist-get 'packageId (plist-get props 'location-info))
+                       (alist-get 'modulePath (plist-get props 'location-info))
+                       identifier))
+                     (t nil))))
+    (funcall cb docstring
+             :thing symbol
+             :face 'font-lock-variable-name-face)
+    (with-current-buffer eldoc--doc-buffer
+      (hcel-minor-mode))))
+
 (defun hcel-eldoc-docs (cb)
   (when-let ((docstring (hcel-id-docs-at-point)))
     (setq this-command nil)
@@ -222,6 +260,25 @@ May cause error if the identifier has exact location."
     (with-current-buffer eldoc--doc-buffer
       (hcel-minor-mode))))
 
+(defun hcel-minor-eldoc-docs (cb)
+  (when-let* ((props (text-properties-at (point)))
+              (docstring
+               (cond ((eq major-mode 'hcel-outline-mode)
+                      (hcel-id-docs-internal
+                       (plist-get props 'package-id)
+                       (plist-get props 'module-path)
+                       (plist-get props 'internal-id)))
+                     ((eq major-mode 'hcel-ids-mode)
+                      (hcel-id-docs-internal
+                       (alist-get 'packageId (plist-get props 'location-info))
+                       (alist-get 'modulePath (plist-get props 'location-info))
+                       (plist-get props 'internal-id)))
+                     (t nil))))
+    (setq this-command nil)
+    (funcall cb docstring)
+    (with-current-buffer eldoc--doc-buffer
+      (hcel-minor-mode))))
+
 (defun hcel-eldoc-expression-type (cb)
   (when mark-active
     (when-let
@@ -431,8 +488,17 @@ May cause error if the identifier has exact location."
   (if hcel-minor-mode
       (if (and (not (memq major-mode hcel-minor-major-modes))
                (not (eq (current-buffer) eldoc--doc-buffer)))
-          (error "Not in one of the supported modes (%s) or the eldoc buffer."
-                 (string-join (mapcar 'prin1-to-string hcel-minor-major-modes)
-                              ", ")))))
+          (progn
+            (hcel-minor-mode 0)
+            (error "Not in one of the supported modes (%s) or the eldoc buffer."
+                   (string-join (mapcar 'prin1-to-string hcel-minor-major-modes)
+                                ", ")))
+        (add-hook
+         'eldoc-documentation-functions #'hcel-minor-eldoc-docs nil t)
+        (add-hook
+         'eldoc-documentation-functions #'hcel-minor-eldoc-id-type nil t)
+        (setq-local eldoc-documentation-strategy 'eldoc-documentation-compose))
+    (remove-hook 'eldoc-documentation-functions #'hcel-minor-eldoc-id-type t)
+    (remove-hook 'eldoc-documentation-functions #'hcel-minor-eldoc-docs t)))
 
 (provide 'hcel-source)