diff options
Diffstat (limited to 'lisp')
| -rw-r--r-- | lisp/hcel-source.el | 160 |
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) |