diff options
Diffstat (limited to 'lisp/hcel-source.el')
| -rw-r--r-- | lisp/hcel-source.el | 523 |
1 files changed, 0 insertions, 523 deletions
diff --git a/lisp/hcel-source.el b/lisp/hcel-source.el deleted file mode 100644 index 688fff1..0000000 --- a/lisp/hcel-source.el +++ /dev/null @@ -1,523 +0,0 @@ -;;; hcel-source.el --- displays Haskell module source. -*- lexical-binding: t; -*- - -;; Copyright (C) 2022 Yuchen Pei. -;; -;; This file is part of hcel. -;; -;; hcel is free software: you can redistribute it and/or modify it under -;; the terms of the GNU Affero General Public License as published by -;; the Free Software Foundation, either version 3 of the License, or -;; (at your option) any later version. -;; -;; hcel 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 Affero General -;; Public License for more details. -;; -;; You should have received a copy of the GNU Affero General Public -;; License along with hcel. If not, see <https://www.gnu.org/licenses/>. - -(require 'hcel-client) -(define-derived-mode hcel-mode special-mode "hcel" - "Major mode for exploring Haskell codebases" - (setq-local eldoc-documentation-strategy 'eldoc-documentation-compose-eagerly - eldoc-documentation-functions - '(hcel-eldoc-id-type hcel-eldoc-expression-type hcel-eldoc-docs) - imenu-create-index-function 'hcel-imenu-create-index - imenu-space-replacement " " - hcel-identifiers nil - hcel-declarations nil - hcel-occurrences nil - hcel-package-id nil - hcel-module-path nil - hcel-highlight-id nil)) -(defun hcel-buffer-name (package-id module-path) - (concat "*hcel " (hcel-format-package-id package-id "-") - "/" module-path "*")) - -(defun hcel-load-module-source (package-id module-path &optional force) - "Loads module source in a buffer and returns the buffer. - -When FORCE is non-nil, kill existing source buffer if any." - (let ((buffer-name (hcel-buffer-name package-id module-path))) - (when (or force (not (get-buffer buffer-name))) - (let ((json (hcel-api-module-info package-id module-path))) - (ignore-errors (kill-buffer buffer-name)) - (with-current-buffer (get-buffer-create buffer-name) - ;; (hcel-write-source-to-buffer (alist-get 'tokenizedLines json)) - (hcel-write-html-source-to-buffer (hcel-source-html json)) - (fontify-with-haskell-mode) - ;; it is important the setq of local vars are after the (hcel-mode) - ;; otherwise they may be rewritten - (hcel-mode) - (setq hcel-declarations (alist-get 'declarations json) - hcel-identifiers (alist-get 'identifiers json) - hcel-occurrences (alist-get 'occurrences json) - hcel-package-id package-id - hcel-module-path module-path) - (goto-char (point-min))))) - (get-buffer buffer-name))) - -(defun hcel-reload-module-source () - "Reloads current module source." - (interactive) - (if (equal major-mode 'hcel-mode) - (switch-to-buffer - (hcel-load-module-source hcel-package-id hcel-module-path t)) - (error "Not in hcel-mode!"))) -(define-key hcel-mode-map "g" 'hcel-reload-module-source) - -(defun hcel-load-module-location-info (location-info &optional no-jump) - "Load a module from exact location info. - -Example of LOCATION-INFO: - - \"locationInfo\": { - \"endColumn\": 14, - \"endLine\": 317, - \"moduleName\": \"Main\", - \"modulePath\": \"app/Server.hs\", - \"packageId\": { - \"name\": \"hcel\", - \"version\": \"0.1.0.0\" - }, - \"startColumn\": 5, - \"startLine\": 317, - \"tag\": \"ExactLocation\" - }, - -If NO-JUMP is non-nil, just open the source and does not jump to the location with pulsing. -" - (unless (string= (hcel-location-tag location-info) "ExactLocation") - (error "Location tag is not ExactLocation.")) - (when-let ((package-id (alist-get 'packageId location-info)) - (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)) - (buffer (hcel-load-module-source package-id module-path))) - (unless no-jump - (switch-to-buffer-other-window buffer) - (goto-line-column line-beg (1- col-beg)) - (pulse-momentary-highlight-region - (point) (save-excursion - (goto-line-column line-end (1- col-end)) - (point)) - 'next-error)) - buffer)) - -(defun hcel-switch-buffer () - (interactive) - (switch-to-buffer - (read-buffer - "Switch to buffer: " nil t - (lambda (buffer) - (equal - (buffer-local-value - 'major-mode - (get-buffer (if (stringp buffer) buffer (car buffer)))) - 'hcel-mode))))) -(define-key hcel-mode-map "b" 'hcel-switch-buffer) - -(defun hcel-lookup-occurrence-at-point () - (when-let ((occurrence (get-text-property (point) 'occurrence))) - (alist-get (intern occurrence) hcel-occurrences))) - -(defun hcel-get-location-info (id occ) - (or (when id (alist-get 'locationInfo id)) - ;; happens for import modules - (when occ (alist-get 'contents (alist-get 'sort occ))))) - -(defun hcel-occ-symbol-at-point () - (when-let* ((occ (get-text-property (point) 'occurrence)) - (splitted (split-string occ "-")) - (line (string-to-number (car splitted))) - (col-beg (string-to-number (cadr splitted))) - (col-end (string-to-number (caddr splitted)))) - (buffer-substring-line-column line (1- col-beg) line (1- col-end)))) - -(defun hcel-type-at-point () - (interactive) - (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 () - (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) - (interactive "r") - (when mark-active - (save-excursion - (let ((line-beg) (col-beg) (line-end) (col-end)) - (goto-char beg) - (setq line-beg (current-line) - col-beg (current-column)) - (goto-char end) - (setq line-end (current-line) - col-end (current-column)) - (when-let ((expr - (ignore-errors - (hcel-api-expressions hcel-package-id - hcel-module-path line-beg col-beg - line-end col-end)))) - (unless (length= expr 0) - (hcel-expression-and-type (elt expr (1- (length expr)))))))))) - -(defun hcel-outline-package-module () - (interactive) - (let ((package-id hcel-package-id) - (module-path hcel-module-path)) - (hcel) - (hcel-outline-goto-package package-id) - (hcel-outline-load-modules-at-point) - (hcel-outline-goto-module module-path) - (hcel-outline-load-identifiers-at-point))) -(define-key hcel-mode-map "O" 'hcel-outline-package-module) - -;; eldoc -(defun hcel-eldoc-id-type (cb) - (when-let ((symbol (hcel-occ-symbol-at-point)) - (doc (hcel-type-at-point)) - (docstring - (propertize - doc - 'package-id hcel-package-id - 'module-path hcel-module-path))) - (funcall cb docstring - :thing symbol - :face 'font-lock-variable-name-face) - (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) - (funcall cb docstring) - (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 - ((expr-and-type - (hcel-expressions-type (region-beginning) (region-end)))) - (setq this-command nil) - (funcall cb (cdr expr-and-type) - :thing (car expr-and-type) - :face 'font-lock-variable-name-face) - (with-current-buffer eldoc--doc-buffer - (hcel-minor-mode))))) - -;; highlight -(defface hcel-highlight-id '((t (:inherit underline))) - "Face for highlighting hcel identifier at point.") - -(defun hcel-highlight-update (unused unused unused) - ;; if mark is active, change of face will deactivate the mark in transient - ;; mark mode - (unless mark-active - (let ((id (get-text-property (point) 'identifier)) - (inhibit-read-only t)) - (when (not (string= hcel-highlight-id id)) - (hcel-highlight-stop hcel-highlight-id) - (hcel-highlight-start id) - (setq hcel-highlight-id id))))) - -(defun hcel-highlight-stop (id) - (when id - (save-excursion - (goto-char (point-min)) - (let ((match)) - (while (setq match - (text-property-search-forward 'identifier id 'string=)) - (font-lock--remove-face-from-text-property - (prop-match-beginning match) - (prop-match-end match) 'face 'hcel-highlight-id)))))) - -(defun hcel-highlight-start (id) - (when id - (save-excursion - (goto-char (point-min)) - (let ((match)) - (while (setq match - (text-property-search-forward 'identifier id 'string=)) - (add-face-text-property - (prop-match-beginning match) - (prop-match-end match) 'hcel-highlight-id)))))) - -(add-hook 'hcel-mode-hook 'cursor-sensor-mode) - -;; utilities -(defun hcel-write-source-line-to-buffer (line) - (mapc - (lambda (token) - (let* ((idInfo (alist-get 'idInfo token)) - (id (alist-get 'identifier idInfo)) - (occ (alist-get 'occurrence idInfo)) - (content (alist-get 'content token))) - (insert - (propertize content - 'identifier (unless (string= id "") id) - 'occurrence (unless (string= occ "") occ) - 'cursor-sensor-functions - (when id (list 'hcel-highlight-update)))))) - line)) - -(defun hcel-write-source-to-buffer (lines) - (mapc - (lambda (line) - (hcel-write-source-line-to-buffer (alist-get 'lineContents line)) - (insert "\n")) - lines)) - -(defun hcel-write-html-source-line-to-buffer (line) - (mapc - (lambda (span) - (let* ((id (dom-attr span 'data-identifier)) - (occ (dom-attr span 'data-occurrence)) - (content (dom-text span))) - (insert - (propertize content - 'identifier (unless (string= id "") id) - 'occurrence (unless (string= occ "") occ) - 'cursor-sensor-functions - (when id (list 'hcel-highlight-update)))))) - (dom-by-tag line 'span)) - (insert "\n")) - -(defun hcel-write-html-source-to-buffer (lines) - (mapc - 'hcel-write-html-source-line-to-buffer - lines)) - -(defun hcel-source-html (json) - (with-temp-buffer - (insert (alist-get 'sourceCodeHtml json)) - (dom-by-class - (libxml-parse-html-region (point-min) (point-max)) - "line-content"))) - -;; imenu -(defun hcel-imenu-create-index () - (unless (eq major-mode 'hcel-mode) - (error "Not in hcel-mode!")) - (mapcar - (lambda (decl) - (cons - (hcel-render-components - (alist-get 'components - (alist-get 'declType decl)) - (alist-get 'name decl)) - (progn (goto-line (alist-get 'lineNumber decl)) (point)))) - hcel-declarations)) -(define-key hcel-mode-map "j" 'imenu) - -;; xref -(add-hook 'hcel-mode-hook - (lambda () - (add-hook 'xref-backend-functions - #'hcel--xref-backend nil t))) -(defun hcel--xref-backend () 'hcel-xref) -(cl-defmethod xref-backend-definitions ((_backend (eql hcel-xref)) _identifiers) - (hcel-find-definition)) - -(defun hcel-find-definition () - (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 - '(hcel-outline-mode hcel-ids-mode) - "Major modes where hcel-minor mode can live in.") - -(defvar hcel-minor-mode-map - (let ((kmap (make-sparse-keymap))) - (define-key kmap (kbd "M-?") 'hcel-minor-find-references-at-point) - kmap)) - -(define-minor-mode hcel-minor-mode - "A minor mode for exploring haskell codebases." - :lighter " hcel-minor" - :after-hook - (if hcel-minor-mode - (if (and (not (memq major-mode hcel-minor-major-modes)) - (not (eq (current-buffer) eldoc--doc-buffer))) - (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) |