aboutsummaryrefslogtreecommitdiff
path: root/lisp
diff options
context:
space:
mode:
authorYuchen Pei <hi@ypei.me>2022-09-06 14:21:23 +1000
committerYuchen Pei <hi@ypei.me>2022-09-06 14:21:23 +1000
commit7997c1f9668a08888ef7d0afb5c41cf4039ba6d4 (patch)
treeb8f0ce55935492c641bcaf646982289b85bd0e48 /lisp
parentf1c952f0b88904eadafd63f677df989f9f81a866 (diff)
add eldoc feature to hcel-minor
Diffstat (limited to 'lisp')
-rw-r--r--lisp/hcel-source.el160
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)