aboutsummaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--README.org53
-rw-r--r--lisp/hc.el58
-rw-r--r--lisp/hcel-client.el161
-rw-r--r--lisp/hcel-haddorg.el46
-rw-r--r--lisp/hcel-outline.el215
-rw-r--r--lisp/hcel-results.el393
-rw-r--r--lisp/hcel-source.el523
-rw-r--r--lisp/hcel-utils.el169
8 files changed, 13 insertions, 1605 deletions
diff --git a/README.org b/README.org
index 5d6b3f7..f5447dc 100644
--- a/README.org
+++ b/README.org
@@ -1,9 +1,12 @@
#+title: hcel
-hcel is a fork of [[https://github.com/alexwl/haskell-code-explorer][Haskell Code Explorer]], it works with GHC-9.2.2 with
+hcel is an indexer and a server of Haskell packages. It serves
+indexed packages through JSON API.
+
+It is a fork of [[https://github.com/alexwl/haskell-code-explorer][Haskell Code Explorer]], and works with GHC-9.2.2 with
Cabal-3.6.2.0, and possibly other adjacent versions.
-It also comes with an emacs binding.
+It also has an emacs client.
* Install
@@ -33,7 +36,7 @@ can be removed to save space. To launch the app, run
haskell-code-server -p /path/to/package1 -p /path/to/package2 ...
#+end_src
-and the app will be available at localhost:3000.
+and the server will be available at localhost:3000.
You can also hook up a local hoogle for documentation lookup:
@@ -43,48 +46,18 @@ hoogle server
haskell-code-server -p /path/to/package1 -p /path/to/package2 --use-hoogle-api --hoogle-api https://hoogle.localhost/ --disable-hoogle-api-cert-check
#+end_src
-For the readme of the original version, see README.md.original in the
-project tree, also available at
-https://g.ypei.me/hcel.git/tree/README.md.original.
-
-* Difference from the original version
-
-The indexer of this version looks for all build targets, including
-testsuites and benchmarks, in the .cabal file, therefore you'll need
-to build them all before indexing, otherwise the indexer will complain
-about missing files.
-
* Emacs binding
-You may find an emacs client under the ~lisp~ directory. It covers
- almost all features in the js client, and more:
-
-- Jump to definition (using xref)
-- Find references (based on compilation mode)
-- Search identifiers in a package or globally (based on compilation mode)
-- Highlight the identifier at point
-- Browse packages, modules and identifiers in an outline mode buffer
-- Eldoc integration, showing type and documentation of the identifier
- at point, or the selected expression.
-- Syntax highlight (requires haskell-mode)
-
-To start, start a server, and set the endpoint:
-
-#+begin_src elisp
-(require 'hc)
-(setq hcel-endpoint "localhost:8080")
-#+end_src
+The may find an emacs client called hc.el at
+ <https://g.ypei.me/hc.el.git>.
-Then run command ~hcel~ to browse in a hcel-outline mode buffer, or
-~hcel-package~ to select a package and module in the minibuffer.
+The original haskell-code-explorer has a web client, but this will be
+removed in favour of serving the Emacs client.
* Contact and Copyright
-The original haskell-code-explorer is written by Alexey Kiryushin
-(alexey.a.kiryushin@gmail.com), hosted at [[https://github.com/alexwl/haskell-code-explorer][github]].
-
-This fork is maintained by Yuchen Pei (id@ypei.org).
+hcel is maintained by Yuchen Pei (id@ypei.org).
-The original work is under the [[https://www.gnu.org/licenses/license-list.html#Expat][expat license]], while the changes by
-Yuchen Pei are covered by [[https://www.gnu.org/licenses/agpl-3.0.en.html][GNU AGPLv3+]]. You may find the license text
+The original [[https://github.com/alexwl/haskell-code-explorer][haskell-code-explorer]] is under the [[https://www.gnu.org/licenses/license-list.html#Expat][expat license]], whereas
+the changes are covered by [[https://www.gnu.org/licenses/agpl-3.0.en.html][GNU AGPLv3+]]. You may find the license text
in a file named COPYING.agpl3 in the project tree. As a combination,
this work as a whole is covered by the terms of [[https://www.gnu.org/licenses/agpl-3.0.en.html][GNU AGPLv3+]] ([[https://www.gnu.org/licenses/gpl-faq.html#WhatDoesCompatMean][why?]]).
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
- "&amp;" "&"
- (replace-regexp-in-string
- "&#39;" "'"
- (replace-regexp-in-string
- "&quot;" "\""
- (replace-regexp-in-string
- "&gt;" ">"
- (replace-regexp-in-string
- "&lt;" "<" 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)
generated by cgit v1.2.3 (git 2.39.1) at 2024-12-24 03:29:37 +0000