diff options
author | Yuchen Pei <hi@ypei.me> | 2022-09-19 10:39:54 +1000 |
---|---|---|
committer | Yuchen Pei <hi@ypei.me> | 2022-09-19 10:39:54 +1000 |
commit | 2240c4885c0663883ee013ffcc1419518b65d3cf (patch) | |
tree | 77f252b2825e3dead21e5640169c998b6d92b16a /lisp | |
parent | 551d006f34192f0606fe27446711821f210c451d (diff) |
moving the emacs client out. updated readme
Diffstat (limited to 'lisp')
-rw-r--r-- | lisp/hc.el | 58 | ||||
-rw-r--r-- | lisp/hcel-client.el | 161 | ||||
-rw-r--r-- | lisp/hcel-haddorg.el | 46 | ||||
-rw-r--r-- | lisp/hcel-outline.el | 215 | ||||
-rw-r--r-- | lisp/hcel-results.el | 393 | ||||
-rw-r--r-- | lisp/hcel-source.el | 523 | ||||
-rw-r--r-- | lisp/hcel-utils.el | 169 |
7 files changed, 0 insertions, 1565 deletions
diff --git a/lisp/hc.el b/lisp/hc.el deleted file mode 100644 index f6239f6..0000000 --- a/lisp/hc.el +++ /dev/null @@ -1,58 +0,0 @@ -;;; hc.el --- Haskell codebase explorer -*- lexical-binding: t; -*- - -;; Author: Yuchen Pei <id@ypei.org> -;; Maintainer: Yuchen Pei <id@ypei.org> -;; Created: 2022 -;; Version: 0 -;; Keywords: haskell -;; Package-Requires: ((emacs "28") (haskell-mode)) -;; Package-Type: multi -;; Homepage: https://g.ypei.me/hcel.git - -;; 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-source) -(require 'hcel-outline) -(require 'hcel-results) -(require 'hcel-utils) - -(defun hcel-package (package-id) - "Select a package, followed by selecting a module to display the source." - (interactive - (list - (completing-read "Select package: " - (mapcar 'hcel-format-package-id - (hcel-api-packages))))) - (call-interactively (hcel-module-selector (hcel-parse-package-id package-id)))) - -(defun hcel-module () - "Select a module to display source." - (interactive) - (call-interactively - (hcel-module-selector hcel-package-id))) - -(defun hcel-module-selector (package-id) - (lambda (module-path) - (interactive - (list - (completing-read "Select module: " - (hcel-list-modules package-id)))) - (switch-to-buffer - (hcel-load-module-source package-id module-path)))) - -(provide 'hc) diff --git a/lisp/hcel-client.el b/lisp/hcel-client.el deleted file mode 100644 index 1aa0d0f..0000000 --- a/lisp/hcel-client.el +++ /dev/null @@ -1,161 +0,0 @@ -;;; hcel-client.el --- talks to a haskell-code-server. -*- 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/>. - -(defcustom hcel-endpoint "localhost:8080" - "hcel endpoint" - :group 'hcel) -(defcustom hcel-indexed-dir "/.haskell-code-explorer" - "hcel indexed dir" - :group 'hcel) - -(defvar hcel-client-buffer-name "*hcel-client*") - -(defun hcel-api-packages () - (let ((packages - (hcel-url-fetch-json (concat hcel-endpoint "/api/packages")))) - (mapcan - (lambda (package) - (mapcar - (lambda (version) (list (cons 'name (alist-get 'name package)) - (cons 'version version))) - (alist-get 'versions package))) - packages))) - -(defun hcel-api-package-info (package-id) - (mapcar - (lambda (tuple) - (prin1-to-string (car tuple) t)) - (alist-get - 'modules - (hcel-url-fetch-json (concat - hcel-endpoint "/files/" (hcel-format-package-id package-id "-") - hcel-indexed-dir "/packageInfo.json"))))) - -(defun hcel-api-definition-site - (package-id component-id module-name entity name) - (hcel-url-fetch-json - (concat hcel-endpoint "/api/definitionSite/" - (hcel-format-package-id package-id "-") - "/" component-id "/" module-name "/" entity "/" name))) - -(defun hcel-definition-site-location-info (approx-location-info) - "Call definitionSite with info from an approximate location." - (when (string= (hcel-location-tag approx-location-info) "ExactLocation") - (error "An ExactLocation supplied.")) - (when-let* ((package-id (alist-get 'packageId approx-location-info)) - (component-id (alist-get 'componentId approx-location-info)) - (module-name (alist-get 'moduleName approx-location-info)) - (entity (alist-get 'entity approx-location-info)) - (name (alist-get 'name approx-location-info))) - (hcel-api-definition-site package-id component-id module-name entity name))) - -(defun hcel-api-module-info (package-id module-path) - (hcel-url-fetch-json - (concat - hcel-endpoint "/files/" (hcel-format-package-id package-id "-") - hcel-indexed-dir - "/" (replace-regexp-in-string "/" "%252F" module-path) ".json.gz") - t)) - -(defun hcel-api-expressions - (package-id module-path line-beg col-beg line-end col-end) - (hcel-url-fetch-json - (concat - hcel-endpoint "/api/expressions/" (hcel-format-package-id package-id "-") - "/" (replace-regexp-in-string "/" "%2F" module-path) - "/" (number-to-string (1+ line-beg)) - "/" (number-to-string (1+ col-beg)) - "/" (number-to-string (1+ line-end)) - "/" (number-to-string (1+ col-end))))) - -(defun hcel-api-hoogle-docs (package-id module-name entity name) - (hcel-url-fetch-json - (concat hcel-endpoint "/api/hoogleDocs/" - (hcel-format-package-id package-id "-") "/" - module-name "/" entity "/" name))) - -(defun hcel-format-pagination-query (page per-page) - (when (or page per-page) - (concat "?" - (string-join - (list - (when page (concat "page=" page)) - (when per-page (concat "per_page=" per-page))) - (when (and page per-page) "&"))))) - -(defun hcel-api-references (package-id name &optional page per-page) - (hcel-url-fetch-json - (concat hcel-endpoint "/api/references/" - (hcel-format-package-id package-id "-") "/" - name - (hcel-format-pagination-query page per-page)))) - -(defun hcel-api-identifiers (scope query package-id &optional page per-page - with-header) - (hcel-url-fetch-json - (concat hcel-endpoint - (if (eq scope 'global) - "/api/globalIdentifiers/" - (concat "/api/identifiers/" - (hcel-format-package-id package-id "-") - "/")) - query - (hcel-format-pagination-query page per-page)) - nil with-header)) - -(defun hcel-api-global-references (name) - (hcel-url-fetch-json (concat hcel-endpoint "/api/globalReferences/" name))) - -(defun hcel-parse-http-header (text) - (let ((status) (fields)) - (with-temp-buffer - (insert text) - (goto-char (point-min)) - (re-search-forward "^HTTP.*\\([0-9]\\{3\\}\\).*$") - (setq status (match-string 1)) - (while (re-search-forward "^\\(.*?\\): \\(.*\\)$" nil t) - (push (cons (intern (match-string 1)) (match-string 2)) fields))) - (list (cons 'status status) (cons 'fields fields)))) - -(defun hcel-url-fetch-json (url &optional decompression with-header) - (with-current-buffer (get-buffer-create hcel-client-buffer-name) - (goto-char (point-max)) - (insert "[" (current-time-string) "] Request: " url "\n")) - (with-current-buffer (url-retrieve-synchronously url t) - (let ((header) (status) (fields) (json)) - (delete-http-header) - (setq header (hcel-parse-http-header (car kill-ring)) - status (alist-get 'status header) - fields (alist-get 'fields header)) - (with-current-buffer hcel-client-buffer-name - (insert "[" (current-time-string) "] Response: " status "\n")) - (when decompression - (call-process-region (point) (point-max) "gunzip" t t t) - (goto-char (point-min))) - (call-interactively 'delete-trailing-whitespace) - (if (string= status "200") - (unless (= (point) (point-max)) - (if with-header - (list - (cons 'header fields) - (cons 'json (json-read))) - (json-read))) - (error "HTTP error: %s" (buffer-substring (point) (point-max))))))) - -(provide 'hcel-client) diff --git a/lisp/hcel-haddorg.el b/lisp/hcel-haddorg.el deleted file mode 100644 index ad797e0..0000000 --- a/lisp/hcel-haddorg.el +++ /dev/null @@ -1,46 +0,0 @@ -;; -*- 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-source) -(require 'hcel-client) -(require 'hcel-utils) - -(defun hcel-haddorg-to-hcel-definition () - (interactive) - (save-excursion - (org-back-to-heading t) - (let* ((id (org-entry-get (point) "CUSTOM_ID")) - (splitted (split-string id "/")) - (module-name (car splitted)) - (entity (if (equal "v" (cadr splitted)) "Val" "Typ")) - (name (caddr splitted)) - (package) (unparsed) (package-id)) - (goto-char (point-min)) - (setq package (org-entry-get (point) "ITEM")) - (setq package-id - (hcel-parse-package-id - (progn - (string-match "^\\(.*?\\)\\(:.*\\)?$" package) - (match-string 1 package)) - "-")) - (hcel-load-module-location-info - (alist-get 'location - (hcel-api-definition-site - package-id "lib" module-name entity name)))))) - -(provide 'hcel-haddorg) diff --git a/lisp/hcel-outline.el b/lisp/hcel-outline.el deleted file mode 100644 index a46db14..0000000 --- a/lisp/hcel-outline.el +++ /dev/null @@ -1,215 +0,0 @@ -;;; hcel-outline.el --- shows package-module-identifier hierarchy in an outline mode -*- 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/>. - -(defvar hcel-outline-buffer-name "*hcel-outline*") -(defvar hcel-outline-indentation 2) - -(defvar hcel-outline-mode-map - (let ((kmap (make-sparse-keymap))) - (define-key kmap "n" 'outline-next-visible-heading) - (define-key kmap "p" 'outline-previous-visible-heading) - (define-key kmap "f" 'outline-forward-same-level) - (define-key kmap "F" 'hcel-outline-follow-mode) - (define-key kmap "b" 'outline-backward-same-level) - (define-key kmap "u" 'outline-up-heading) - (define-key kmap "\t" 'hcel-outline-toggle-children) - (define-key kmap "\r" 'hcel-outline-open-thing-at-point) - (define-key kmap "o" 'hcel-outline-open-thing-at-point-other-window) - (define-key kmap "q" 'quit-window) - kmap)) -(define-derived-mode hcel-outline-mode outline-mode "hcel-outline" - "Major mode for browsing Haskell codebases" - (setq-local package-filter nil - module-filter nil - outline-regexp "\\( *\\)." - outline-level (lambda () (1+ (/ (length (match-string 1)) - hcel-outline-indentation))) - buffer-read-only t)) -(add-hook 'hcel-outline-mode-hook 'hcel-minor-mode) - -(defun hcel () - (interactive) - (let ((buffer (get-buffer hcel-outline-buffer-name))) - (if buffer (switch-to-buffer buffer) - (switch-to-buffer (get-buffer-create hcel-outline-buffer-name)) - (save-excursion - (mapc - (lambda (package-id) - (insert - (concat (propertize - (hcel-format-package-id package-id) - 'thing 'package - 'package-id package-id - 'children-loaded nil) - "\n"))) - (hcel-api-packages))) - (hcel-outline-mode)))) - -(define-key hcel-mode-map "o" 'hcel) - -;; TODO: maybe remove -(defun hcel-outline-update-opened (package-id module-path) - "Update the outline tree depending on openness of packages and modules. - -If a package is opened outside of the outline mode (mainly source mode), then -update in the outline mode too." - (with-current-buffer hcel-outline-buffer-name - (save-excursion - (hcel-outline-goto-package package-id) - (hcel-outline-load-modules-at-point) - (hcel-outline-goto-module module-path) - (hcel-outline-load-identifiers-at-point)))) - -(defun hcel-outline-goto-package (package-id) - (goto-char (point-min)) - (re-search-forward - (format "^%s$" (hcel-format-package-id package-id))) - (beginning-of-line)) - -(defun hcel-outline-goto-module (module-path) - "Goto module, assuming point is on the package." - (re-search-forward - (format "^%s%s$" (make-string hcel-outline-indentation 32) module-path)) - (beginning-of-line)) - -(defun hcel-outline-goto-identifier (position) - "Goto identifier declared at POSITION, assuming point is on the module." - (text-property-search-forward 'position position)) - -(defun hcel-outline-load-modules-at-point () - (interactive) - (unless (eq (get-text-property (point) 'thing) 'package) - (error "Point is not at a package!")) - (unless (get-text-property (point) 'children-loaded) - (save-excursion - (let ((inhibit-read-only t) - (package-id (get-text-property (point) 'package-id))) - (put-text-property - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point)) - 'children-loaded t) - (beginning-of-line 2) - (mapc - (lambda (module) - (insert - (propertize (concat - (make-string hcel-outline-indentation 32) module "\n") - 'thing 'module - 'package-id package-id - 'module-path module - 'folded t))) - (hcel-api-package-info package-id)))))) - -(defun hcel-outline-toggle-children () - (interactive) - (let ((thing (get-text-property (point) 'thing)) - (children-loaded (get-text-property (point) 'children-loaded))) - (cond (children-loaded (outline-toggle-children)) - ((eq thing 'package) (hcel-outline-load-modules-at-point)) - ((eq thing 'module) (hcel-outline-load-identifiers-at-point)) - (t nil)))) - -(defun hcel-outline-load-identifiers-at-point () - (interactive) - (unless (eq (get-text-property (point) 'thing) 'module) - (error "Point is not at a module!")) - (unless (get-text-property (point) 'children-loaded) - (save-excursion - (let* ((inhibit-read-only t) - (package-id (get-text-property (point) 'package-id)) - (module-path (get-text-property (point) 'module-path)) - (imenu-index)) - (put-text-property - (progn (beginning-of-line) (point)) - (progn (end-of-line) (point)) - 'children-loaded t) - (when (or (get-buffer (hcel-buffer-name package-id module-path)) - (y-or-n-p "Open module source?")) - (with-current-buffer - (hcel-load-module-source package-id module-path) - (setq imenu-index (save-excursion (hcel-imenu-create-index)))) - (beginning-of-line 2) - (mapc - (lambda (pair) - (insert - (propertize - (concat (make-string (* 2 hcel-outline-indentation) 32) - (car pair) - "\n") - 'thing 'identifier - 'package-id package-id - 'module-path module-path - 'position (cdr pair)))) - imenu-index)))))) - -(defun hcel-outline-open-module-source-at-point (&optional other-window) - (interactive) - (let ((props (text-properties-at (point)))) - (unless (eq (plist-get props 'thing) 'module) - (error "Point is not at a module!")) - (let ((buffer - (hcel-load-module-source - (plist-get props 'package-id) - (plist-get props 'module-path)))) - (hcel-outline-load-identifiers-at-point) - (if other-window - (switch-to-buffer-other-window buffer) - (switch-to-buffer buffer))))) - -(defun hcel-outline-open-identifier-at-point (&optional other-window) - (interactive) - (let ((props (text-properties-at (point)))) - (unless (eq (plist-get props 'thing) 'identifier) - (error "Point is not at an identifier!")) - (let ((buffer - (hcel-load-module-source - (plist-get props 'package-id) - (plist-get props 'module-path)))) - (if other-window - (switch-to-buffer-other-window buffer) - (switch-to-buffer buffer)) - (goto-char (plist-get props 'position))))) - -(defun hcel-outline-open-thing-at-point (&optional other-window) - (interactive) - (cond ((eq (get-text-property (point) 'thing) 'module) - (hcel-outline-open-module-source-at-point other-window)) - ((eq (get-text-property (point) 'thing) 'identifier) - (hcel-outline-open-identifier-at-point other-window)) - (t nil))) - -(defun hcel-outline-open-thing-at-point-other-window () - (interactive) - (let ((current-window (car (window-list)))) - (hcel-outline-open-thing-at-point t) - (select-window current-window))) - -(define-minor-mode hcel-outline-follow-mode - "Display modules and identifiers as point moves." - :lighter " hcel-outline-follow" - :after-hook - (if hcel-outline-follow-mode - (if (not (eq major-mode 'hcel-outline-mode)) - (error "Not in hcel-outline mode!") - (add-hook 'post-command-hook - 'hcel-outline-open-thing-at-point-other-window nil t)) - (remove-hook 'post-command-hook - 'hcel-outline-open-thing-at-point-other-window t))) - -(provide 'hcel-outline) diff --git a/lisp/hcel-results.el b/lisp/hcel-results.el deleted file mode 100644 index 5f27b6a..0000000 --- a/lisp/hcel-results.el +++ /dev/null @@ -1,393 +0,0 @@ -;;; hc-results.el --- Shows query results in a compilation mode -*- 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/>. - -;;; Commentary: - -;; hcel-results provides functions for hcel modes derived from -;; compilation-mode. - -;;; Code: - -(defun hcel-results-next-error-no-open (n) - (interactive "p") - (hcel-results-next-error-internal n)) - -(defun hcel-results-previous-error-no-open (n) - (interactive "p") - (hcel-results-next-error-no-open (- n))) - -(defun hcel-results-next-error-internal (n &optional reset) - (interactive "p") - (if reset - (progn - (goto-char (point-min)) - (hcel-results-next-error-internal 1 nil)) - (if (> n 0) - (dotimes (unused n) - (condition-case nil - (progn - (goto-char (next-single-property-change (point) 'match-line)) - (unless (get-text-property (point) 'match-line) - (goto-char - (next-single-property-change (point) 'match-line)))) - (error (hcel-results-next-page)))) - (dotimes (unused (- n)) - (condition-case nil - (progn - (goto-char (previous-single-property-change (point) 'match-line)) - (unless (get-text-property (point) 'match-line) - (goto-char - (previous-single-property-change (point) 'match-line)))) - (error (hcel-results-previous-page))))))) - -(defun hcel-results-next-error (n &optional reset) - (interactive "p") - (hcel-results-next-error-internal n reset) - (hcel-results-open)) - -(defun hcel-results-open () - (interactive) - ;; TODO: arrow not working - (compilation-set-overlay-arrow (selected-window)) - (hcel-load-module-location-info (get-text-property (point) 'location-info))) - -(defun hcel-results-next-page () - (interactive) - (unless (memq major-mode '(hcel-refs-mode hcel-ids-mode)) - (error "Not in hcel-refs or hcel-ids mode: %S" major-mode)) - (when (= hcel-results-page-number hcel-results-max-page-number) - (error "Already on the last page.")) - (setq hcel-results-page-number (1+ hcel-results-page-number)) - (cond ((eq major-mode 'hcel-refs-mode) (hcel-refs-update-references)) - ((eq major-mode 'hcel-ids-mode) (hcel-ids-update)) - (t (error "wrong major mode: %S" major-mode))) - (hcel-results-next-error-internal 1)) - -(defun hcel-results-previous-page () - (interactive) - (unless (memq major-mode '(hcel-refs-mode hcel-ids-mode)) - (error "Not in hcel-refs or hcel-ids mode: %S" major-mode)) - (when (= hcel-results-page-number 1) - (error "Already on the first page.")) - (setq hcel-results-page-number (1- hcel-results-page-number)) - (cond ((eq major-mode 'hcel-refs-mode) (hcel-refs-update-references)) - ((eq major-mode 'hcel-ids-mode) (hcel-ids-update)) - (t (error "wrong major mode: %S" major-mode))) - (goto-char (point-max)) - (hcel-results-next-error-internal -1)) - -;; hcel-refs-mode -(defcustom hcel-refs-per-page 50 - "hcel refs number of results per page." - :group 'hcel-refs) - -(define-compilation-mode hcel-refs-mode "hcel-refs" - "Major mode for showing references" - (setq-local next-error-function 'hcel-results-next-error - hcel-refs-id nil - hcel-refs-package-id nil - hcel-results-page-number nil - hcel-results-max-page-number nil)) - -(define-key hcel-refs-mode-map (kbd "M-n") - 'hcel-results-next-error-no-open) - -(define-key hcel-refs-mode-map (kbd "M-p") - 'hcel-results-previous-error-no-open) - -(defun hcel-refs-update-references () - "Find references and update the current hcel-refs-mode buffer." - (unless (eq major-mode 'hcel-refs-mode) - (error "Not in hcel-refs mode!")) - (let ((inhibit-read-only t) - (modules-refs - (hcel-api-references - hcel-refs-package-id hcel-refs-id - (number-to-string hcel-results-page-number) - (number-to-string hcel-refs-per-page)))) - (erase-buffer) - (insert (format "References of %s, Page %d of %d.\n" - (hcel-refs-format-id hcel-refs-id) - hcel-results-page-number hcel-results-max-page-number)) - (mapc - (lambda (module-refs) - (let ((module-path (alist-get 'name module-refs)) - (refs (alist-get 'references module-refs))) - (insert "References in " - (hcel-format-package-id hcel-refs-package-id "-") - " " module-path ": \n") - (mapc - (lambda (ref) - (insert - "--\n" - (propertize - (hcel-unquote-html - (alist-get 'sourceCodeHtml ref)) - 'location-info (hcel-id-src-span-to-location-info - hcel-refs-package-id module-path - (alist-get 'idSrcSpan ref))))) - refs))) - modules-refs) - (goto-char (point-min)) - (while (re-search-forward "<b>\\(.*?\\)</b>" nil t) - (replace-match - (propertize (match-string 1) 'font-lock-face 'match)) - (save-excursion - (add-text-properties (progn (beginning-of-line) (point)) - (progn (end-of-line) (point)) - (list 'match-line t))))) - (goto-char (point-min))) - -(defun hcel-refs-reload () - (interactive) - (hcel-refs-update-references)) -(define-key hcel-refs-mode-map "g" 'hcel-refs-reload) - -(define-key hcel-refs-mode-map "f" 'hcel-results-next-page) - -(define-key hcel-refs-mode-map "b" 'hcel-results-previous-page) - -(defun hcel-refs-buffer-name (id) - (format "*hcel-refs %s*" (hcel-refs-format-id id))) - -(defun hcel-refs-format-id (id) - (let* ((tuple (split-string id "|"))) - (format "%s (%s %s)" - (cadddr tuple) (car tuple) (cadr tuple)))) - -(defun hcel-refs-update-references-package () - "Find references and update the current hcel-refs buffer. - -Start by choosing a package." - (interactive) - (unless (eq major-mode 'hcel-refs-mode) - (error "Not in hcel-refs mode!")) - (let* ((global-refs (hcel-api-global-references hcel-refs-id)) - (name (cadddr (split-string hcel-refs-id "|"))) - (package-id-and-count - (split-string - (completing-read - (format "References of %s from: " name) - (mapcar (lambda (pkg-count) - (format "%s (%s)" - (alist-get 'packageId pkg-count) - (alist-get 'count pkg-count))) - global-refs)))) - (package-id (car package-id-and-count)) - (count (string-to-number (substring (cadr package-id-and-count) 1 -1))) - (max-page-number (1+ (/ count hcel-refs-per-page)))) - (setq hcel-refs-package-id (hcel-parse-package-id package-id "-") - hcel-results-page-number 1 - hcel-results-max-page-number max-page-number) - (hcel-refs-update-references))) -(define-key hcel-refs-mode-map "P" 'hcel-refs-update-references-package) - -(defun hcel-find-references-at-point () - "Find references of the identifier at point." - (interactive) - (hcel-find-references-internal hcel-package-id hcel-module-path - (get-text-property (point) 'identifier))) -(define-key hcel-mode-map (kbd "M-?") 'hcel-find-references-at-point) - -(defun hcel-minor-find-references-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-references-internal - (plist-get props 'package-id) - (plist-get props 'module-path) - (plist-get props 'internal-id))) - ((eq major-mode 'hcel-ids-mode) - (hcel-find-references-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-references-internal (package-id module-path identifier) - (when (and package-id module-path identifier) - (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 - (when-let* ((id (alist-get - 'externalId - (alist-get (intern identifier) hcel-identifiers))) - (buffer-name (hcel-refs-format-id id))) - (with-current-buffer (get-buffer-create buffer-name) - (hcel-refs-mode) - (setq hcel-refs-id id) - (hcel-refs-update-references-package)) - (switch-to-buffer-other-window buffer-name)))))) -;; hcel-ids-mode -(defcustom hcel-ids-per-page 20 - "hcel-ids mode number of results per page." - :group 'hcel-ids) -(defcustom hcel-ids-live-per-page 10 - "hcel-ids live search results per page." - :group 'hcel-ids) -(define-compilation-mode hcel-ids-mode "hcel-ids" - "Major mode for showing identifiers" - (setq-local next-error-function 'hcel-results-next-error - hcel-ids-scope nil - hcel-ids-query nil - hcel-ids-package-id nil - hcel-results-page-number nil - hcel-results-max-page-number nil)) -(add-hook 'hcel-ids-mode-hook 'hcel-minor-mode) - -(defun hcel-ids-update () - (unless (eq major-mode 'hcel-ids-mode) - (error "Not in hcel-ids mode!")) - (when (and (eq hcel-ids-scope 'package) (not hcel-ids-package-id)) - (error "No package-id supplied for identifiers call!")) - (let* ((inhibit-read-only t) - (results - (hcel-api-identifiers - hcel-ids-scope hcel-ids-query hcel-ids-package-id - (number-to-string hcel-results-page-number) - (number-to-string hcel-ids-per-page) - t))) - (erase-buffer) - (setq hcel-results-max-page-number - (1+ (/ (string-to-number - (alist-get 'X-Total-Count - (alist-get 'header results))) - hcel-ids-per-page))) - (insert (format "Results of %s, Page %d of %d.\n" - hcel-ids-query hcel-results-page-number - hcel-results-max-page-number)) - (mapc - (lambda (result) - (let* ((location-info (alist-get 'locationInfo result)) - (doc (hcel-render-html - (or (alist-get 'doc result) - (alist-get 'documentation - (ignore-errors - (hcel-definition-site-location-info - location-info))))))) - (insert "--\n") - (insert (propertize - (format "%s :: %s\n" - (alist-get 'demangledOccName result) - (hcel-render-id-type (alist-get 'idType result))) - 'location-info location-info - 'match-line t)) - (insert (format "Defined in %s %s\n" - (hcel-format-package-id - (alist-get 'packageId location-info) "-") - (alist-get 'modulePath location-info))) - (when doc (insert doc)))) - (alist-get 'json results)) - (goto-char (point-min)))) - -(defun hcel-ids-reload () - (interactive) - (hcel-ids-update)) -(define-key hcel-ids-mode-map "g" 'hcel-ids-reload) - -(define-key hcel-ids-mode-map (kbd "M-n") - 'hcel-results-next-error-no-open) -(define-key hcel-ids-mode-map (kbd "M-p") - 'hcel-results-previous-error-no-open) -(define-key hcel-ids-mode-map "f" 'hcel-results-next-page) -(define-key hcel-ids-mode-map "b" 'hcel-results-previous-page) - -(defun hcel-ids-update-query (query) - "Search for identities matching query." - (interactive (list (progn - (unless (eq major-mode 'hcel-ids-mode) - (error "Not in hcel-ids mode!")) - (read-string "Query: " hcel-ids-query)))) - (setq hcel-ids-query query - hcel-results-page-number 1) - (hcel-ids-update)) -(define-key hcel-ids-mode-map "s" 'hcel-ids-update-query) - -(defun hcel-ids-buffer-name (scope query) - (format "*hcel-ids-%S %s*" scope query)) - -;; Caching results to prevent to many hits -(defvar hcel-ids--minibuffer-saved-query nil) -(defvar hcel-ids--minibuffer-saved-results nil) - -(defun hcel-ids-minibuffer-collection (scope query &optional package-id) - (when (and (eq scope 'package) (not package-id)) - (error "No package-id supplied for identifiers call!")) - (unless (length= query 0) - (if (string= hcel-ids--minibuffer-saved-query query) - hcel-ids--minibuffer-saved-results - (setq hcel-ids--minibuffer-saved-query query - hcel-ids--minibuffer-saved-results - (mapcar - (lambda (result) - (propertize - (alist-get 'demangledOccName result) - 'location-info (alist-get 'locationInfo result))) - (hcel-api-identifiers - scope query package-id nil - (number-to-string hcel-ids-live-per-page)))) - hcel-ids--minibuffer-saved-results))) - -(defun hcel-global-ids-minibuffer-collection (query unused unused) - (hcel-ids-minibuffer-collection 'global query)) - -(defun hcel-package-ids-minibuffer-collection (package-id) - (lambda (query unused unused) - (hcel-ids-minibuffer-collection 'package query package-id))) - -(defun hcel-ids (scope query &optional package-id) - (if (length= hcel-ids--minibuffer-saved-results 1) - (hcel-load-module-location-info - (with-temp-buffer - (insert (car hcel-ids--minibuffer-saved-results)) - (get-text-property (point-min) 'location-info))) - (let ((buffer-name (hcel-ids-buffer-name scope query))) - (with-current-buffer (get-buffer-create buffer-name) - (hcel-ids-mode) - (setq hcel-ids-scope scope - hcel-ids-package-id package-id) - (hcel-ids-update-query query)) - (switch-to-buffer buffer-name)))) - -(defun hcel-global-ids (query) - (interactive (list - (let ((minibuffer-allow-text-properties t)) - (completing-read "Search for identifier globally: " - 'hcel-global-ids-minibuffer-collection)))) - (hcel-ids 'global query)) -(define-key hcel-mode-map "I" 'hcel-global-ids) - -(defun hcel-package-ids (query) - (interactive (list - (let ((minibuffer-allow-text-properties t) - (package-id hcel-package-id)) - (unless (eq major-mode 'hcel-mode) - (error "Not in hcel-mode!")) - (completing-read - (format "Search for identifier in %s: " - (hcel-format-package-id package-id "-")) - (hcel-package-ids-minibuffer-collection package-id))))) - (hcel-ids 'package query hcel-package-id)) -(define-key hcel-mode-map "i" 'hcel-package-ids) - -(provide 'hcel-results) 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) diff --git a/lisp/hcel-utils.el b/lisp/hcel-utils.el deleted file mode 100644 index 18e1062..0000000 --- a/lisp/hcel-utils.el +++ /dev/null @@ -1,169 +0,0 @@ -;;; hc-utils.el --- Commonly used utilities -*- 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/>. - -;; data conversions -(defun hcel-parse-package-id (package-id &optional divider) - (unless (stringp divider) (setq divider " ")) - (string-match (format "^\\(.*\\)%s\\(.*\\)$" divider) package-id) - (list (cons 'name (match-string 1 package-id)) - (cons 'version (match-string 2 package-id)))) - -(defun hcel-location-tag (location-info) - "Gets the tag of LOCATION-INFO." - (alist-get 'tag location-info)) - -(defun hcel-approx-to-exact-location (approx-location-info) - "Fetch exact location given approximate location. - -Example of approximate location: - - \"locationInfo\": { - \"componentId\": \"exe-haskell-code-server\", - \"entity\": \"Typ\", - \"haddockAnchorId\": \"PackageInfo\", - \"moduleName\": \"HaskellCodeExplorer.Types\", - \"name\": \"PackageInfo\", - \"packageId\": { - \"name\": \"haskell-code-explorer\", - \"version\": \"0.1.0.0\" - }, - \"tag\": \"ApproximateLocation\" - }" - (alist-get 'location - (hcel-definition-site-location-info approx-location-info))) - -(defun hcel-id-src-span-to-location-info (package-id module-path id-src-span) - "Converts an idSrcSpan to an exact location. - -Example of an idSrcSpan: - - \"idSrcSpan\": { - \"endColumn\": 43, - \"line\": 228, - \"modulePath\": \"src/HaskellCodeExplorer/Types.hs\", - \"startColumn\": 26 - } -" - (list - (cons 'packageId package-id) - (cons 'modulePath module-path) - (cons 'startLine (alist-get 'line id-src-span)) - (cons 'startColumn (alist-get 'startColumn id-src-span)) - (cons 'endLine (alist-get 'line id-src-span)) - (cons 'endColumn (alist-get 'endColumn id-src-span)) - (cons 'tag "ExactLocation"))) - -(defun hcel-expression (expr) - (when-let* ((span (alist-get 'srcSpan expr)) - (line-beg (alist-get 'line (alist-get 'start span))) - (col-beg (alist-get 'column (alist-get 'start span))) - (line-end (alist-get 'line (alist-get 'end span))) - (col-end (alist-get 'column (alist-get 'end span)))) - (buffer-substring-line-column line-beg (1- col-beg) line-end (1- col-end)))) - -;; buffers and strings manipulation -(defun goto-line-column (line column) - (goto-line line) - (move-to-column column)) - -(defun hcel-unquote-html (html) - (replace-regexp-in-string - "&" "&" - (replace-regexp-in-string - "'" "'" - (replace-regexp-in-string - """ "\"" - (replace-regexp-in-string - ">" ">" - (replace-regexp-in-string - "<" "<" html)))))) - -(defun buffer-substring-line-column (line-beg col-beg line-end col-end) - (save-excursion - (buffer-substring - (progn (goto-line-column line-beg col-beg) (point)) - (progn (goto-line-column line-end col-end) (point))))) - -(defun fontify-with-haskell-mode () - "Fontify using haskell-mode" - (require 'haskell) - (let ((text (buffer-string))) - (with-temp-buffer - (haskell-mode) - (insert text) - (if (fboundp 'font-lock-ensure) - (font-lock-ensure) - (with-no-warnings (font-lock-fontify-buffer))) - (setq text (buffer-substring (point-min) (point-max)))) - (erase-buffer) - (insert text))) - -(defun remove-html-markup (html) - (replace-regexp-in-string - "<.*?>" "" - (replace-regexp-in-string "</p>" "\n\n" html))) - -(defun fill-string (text) - (with-temp-buffer - (insert text) - (fill-region (point-min) (point-max)) - (buffer-substring (point-min) (point-max)))) - -;; string formatting -(defun hcel-format-package-id (package &optional divider) - (unless (stringp divider) (setq divider " ")) - (concat (alist-get 'name package) divider (alist-get 'version package))) - -(defun hcel-render-components (components &optional name) - (when (or components name) - (concat (when name (replace-regexp-in-string "\n" " " name)) - (when components - (concat (when name " :: ") - (replace-regexp-in-string - "\n" " " (mapconcat - (lambda (component) - (propertize - (or (alist-get 'name component) - (alist-get 'contents component)) - 'internal-id (alist-get 'internalId component))) - components - ""))))))) - -(defun hcel-render-id-type (id-type) - (concat - (hcel-render-components (alist-get 'components id-type)) - (when-let ((expanded (hcel-render-components - (alist-get 'componentsExpanded id-type)))) - (concat "\nExpands to: " expanded)))) - -(defun hcel-expression-and-type (expr) - "Returns a pair of expression text and its type text." - (when-let ((expression (hcel-expression expr)) - (type (hcel-render-id-type - (alist-get 'exprType (alist-get 'info expr))))) - (cons expression type))) - -(defun hcel-render-html (html) - (when html - (with-temp-buffer - (insert html) - (shr-render-region (point-min) (point-max)) - (buffer-string)))) - -(provide 'hcel-utils) |