From 1699e7873395703720c607a0254909aece16bae7 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Fri, 23 Sep 2022 16:45:36 +1000 Subject: Separating out hcel-minor mode to avoid recursive requires --- hcel-client.el | 20 ++++++++ hcel-minor.el | 143 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ hcel-outline.el | 19 ++++++-- hcel-results.el | 18 +------ hcel-source.el | 123 +++--------------------------------------------- hcel-utils.el | 20 -------- hcel.el | 3 ++ 7 files changed, 189 insertions(+), 157 deletions(-) create mode 100644 hcel-minor.el diff --git a/hcel-client.el b/hcel-client.el index 3af6882..532fc88 100644 --- a/hcel-client.el +++ b/hcel-client.el @@ -68,6 +68,26 @@ (name (alist-get 'name approx-location-info))) (hcel-api-definition-site package-id component-id module-name entity name))) +(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-api-module-info (package-id module-path) (hcel-url-fetch-json (concat diff --git a/hcel-minor.el b/hcel-minor.el new file mode 100644 index 0000000..b507ef4 --- /dev/null +++ b/hcel-minor.el @@ -0,0 +1,143 @@ +;;; hcel-minor.el --- hcel-minor mode for definitions, references and eldoc. -*- lexical-binding: t; -*- + +;; Copyright (C) 2022 Free Software Foundation, Inc. +;; +;; 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 . + +(require 'hcel-source) +(require 'hcel-results) +(require 'hcel-outline) + +(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" + (add-hook 'xref-backend-functions + #'hcel-minor--xref-backend nil t) + (cond + ((null hcel-minor-mode) + (remove-hook 'eldoc-documentation-functions #'hcel-minor-eldoc-id-type t) + (remove-hook 'eldoc-documentation-functions #'hcel-minor-eldoc-docs t)) + ((not (or (apply 'derived-mode-p hcel-minor-major-modes) + (eq (current-buffer) eldoc--doc-buffer))) + (setq hcel-minor-mode nil) + (error "Not in one of the supported modes (%s) or the eldoc buffer." + (mapconcat #'prin1-to-string hcel-minor-major-modes + ", "))) + (t + (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)))) + +(defun hcel-minor-find-references-at-point () + (interactive) + (cond ((or (derived-mode-p 'hcel-outline-mode) + (eq (current-buffer) eldoc--doc-buffer)) + (hcel-find-references-internal + (hcel-text-property-near-point 'package-id) + (hcel-text-property-near-point 'module-path) + (hcel-text-property-near-point 'internal-id))) + ((derived-mode-p 'hcel-ids-mode) + (hcel-find-references-internal + (alist-get 'packageId (hcel-text-property-near-point 'location-info)) + (alist-get 'modulePath (hcel-text-property-near-point 'location-info)) + (hcel-text-property-near-point 'internal-id))) + (t (error "%S not supported and not in eldoc doc buffer." major-mode)))) + +(defun hcel-minor-eldoc-id-type (cb) + (when-let* ((identifier (hcel-text-property-near-point '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 ((derived-mode-p 'hcel-outline-mode) + (hcel-render-type-internal + (hcel-text-property-near-point 'package-id) + (hcel-text-property-near-point 'module-path) + identifier)) + ((derived-mode-p 'hcel-ids-mode) + (hcel-render-type-internal + (alist-get 'packageId (hcel-text-property-near-point 'location-info)) + (alist-get 'modulePath (hcel-text-property-near-point '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 1)))) + +(defun hcel-minor-eldoc-docs (cb) + (when-let* ((docstring + (cond ((derived-mode-p 'hcel-outline-mode) + (hcel-id-docs-internal + (hcel-text-property-near-point 'package-id) + (hcel-text-property-near-point 'module-path) + (hcel-text-property-near-point 'internal-id))) + ((derived-mode-p 'hcel-ids-mode) + (hcel-id-docs-internal + (alist-get 'packageId (hcel-text-property-near-point 'location-info)) + (alist-get 'modulePath (hcel-text-property-near-point 'location-info)) + (hcel-text-property-near-point 'internal-id))) + (t nil)))) + (setq this-command nil) + (funcall cb docstring) + (with-current-buffer eldoc--doc-buffer + (hcel-minor-mode)))) + +(add-hook 'hcel-ids-mode-hook (lambda () (hcel-minor-mode 1))) +(add-hook 'hcel-outline-mode-hook (lambda () (hcel-minor-mode 1))) + +(add-hook 'hcel-eldoc-hook (lambda () + (with-current-buffer eldoc--doc-buffer + (hcel-minor-mode 1)))) + +(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) + (cond ((or (derived-mode-p 'hcel-outline-mode) + (eq (current-buffer) eldoc--doc-buffer)) + (hcel-find-definition-internal + (hcel-text-property-near-point 'package-id) + (hcel-text-property-near-point 'module-path) + (hcel-text-property-near-point 'internal-id))) + ((derived-mode-p 'hcel-ids-mode) + (hcel-find-definition-internal + (alist-get 'packageId (hcel-text-property-near-point 'location-info)) + (alist-get 'modulePath (hcel-text-property-near-point 'location-info)) + (hcel-text-property-near-point 'internal-id))) + (t (error "%S not supported and not in eldoc doc buffer." major-mode)))) + +(provide 'hcel-minor) diff --git a/hcel-outline.el b/hcel-outline.el index 962e5aa..a192e07 100644 --- a/hcel-outline.el +++ b/hcel-outline.el @@ -20,6 +20,7 @@ (require 'hcel-utils) (require 'hcel-source) (require 'outline) +(require 'text-property-search) (defvar hcel-outline-buffer-name "*hcel-outline*") (defvar hcel-outline-indentation 2) @@ -42,8 +43,7 @@ (setq-local outline-regexp "\\( *\\)." outline-level (lambda () (1+ (/ (length (match-string 1)) hcel-outline-indentation))) - buffer-read-only t) - (hcel-minor-mode 1)) + buffer-read-only t)) (defun hcel () (interactive) @@ -62,9 +62,22 @@ "\n"))) (hcel-api-packages))) (hcel-outline-mode)))) - (define-key hcel-mode-map "o" #'hcel) +(defun hcel-outline-package-module () + (interactive) + (unless (derived-mode-p 'hcel-mode) + (error "Not in hcel mode!")) + (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) + + ;; TODO: maybe remove (defun hcel-outline-update-opened (package-id module-path) "Update the outline tree depending on openness of packages and modules. diff --git a/hcel-results.el b/hcel-results.el index 6d6c2c9..3ebee43 100644 --- a/hcel-results.el +++ b/hcel-results.el @@ -212,21 +212,6 @@ Start by choosing a package." (hcel-text-property-near-point 'identifier))) (define-key hcel-mode-map (kbd "M-?") #'hcel-find-references-at-point) -(defun hcel-minor-find-references-at-point () - (interactive) - (cond ((or (derived-mode-p 'hcel-outline-mode) - (eq (current-buffer) eldoc--doc-buffer)) - (hcel-find-references-internal - (hcel-text-property-near-point 'package-id) - (hcel-text-property-near-point 'module-path) - (hcel-text-property-near-point 'internal-id))) - ((derived-mode-p 'hcel-ids-mode) - (hcel-find-references-internal - (alist-get 'packageId (hcel-text-property-near-point 'location-info)) - (alist-get 'modulePath (hcel-text-property-near-point 'location-info)) - (hcel-text-property-near-point '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))) @@ -258,8 +243,7 @@ Start by choosing a package." (define-compilation-mode hcel-ids-mode "hcel-ids" "Major mode for showing identifiers" - (setq-local next-error-function #'hcel-results-next-error) - (hcel-minor-mode 1)) + (setq-local next-error-function #'hcel-results-next-error)) (defun hcel-ids-update () (unless (derived-mode-p 'hcel-ids-mode) diff --git a/hcel-source.el b/hcel-source.el index f6e5d55..905950c 100644 --- a/hcel-source.el +++ b/hcel-source.el @@ -20,8 +20,7 @@ (require 'array) (require 'dom) (require 'hcel-client) -(require 'hcel-outline) -(require 'hcel-results) +(require 'text-property-search) (require 'xref) (defvar-local hcel-identifiers nil) @@ -223,18 +222,9 @@ the location with pulsing. (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 +(defvar hcel-eldoc-hook nil) + (defun hcel-eldoc-id-type (cb) (when-let ((symbol (hcel-occ-symbol-at-point)) (doc (hcel-type-at-point)) @@ -246,63 +236,13 @@ the location with pulsing. (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* ((identifier (hcel-text-property-near-point '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 ((derived-mode-p 'hcel-outline-mode) - (hcel-render-type-internal - (hcel-text-property-near-point 'package-id) - (hcel-text-property-near-point 'module-path) - identifier)) - ((derived-mode-p 'hcel-ids-mode) - (hcel-render-type-internal - (alist-get 'packageId (hcel-text-property-near-point 'location-info)) - (alist-get 'modulePath (hcel-text-property-near-point '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)))) + (run-hooks 'hcel-eldoc-hook))) (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* ((docstring - (cond ((derived-mode-p 'hcel-outline-mode) - (hcel-id-docs-internal - (hcel-text-property-near-point 'package-id) - (hcel-text-property-near-point 'module-path) - (hcel-text-property-near-point 'internal-id))) - ((derived-mode-p 'hcel-ids-mode) - (hcel-id-docs-internal - (alist-get 'packageId (hcel-text-property-near-point 'location-info)) - (alist-get 'modulePath (hcel-text-property-near-point 'location-info)) - (hcel-text-property-near-point 'internal-id))) - (t nil)))) - (setq this-command nil) - (funcall cb docstring) - (with-current-buffer eldoc--doc-buffer - (hcel-minor-mode)))) + (run-hooks 'hcel-eldoc-hook))) (defun hcel-eldoc-expression-type (cb) (when mark-active @@ -313,8 +253,7 @@ the location with pulsing. (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))))) + (run-hooks 'hcel-eldoc-hook)))) ;; highlight (defface hcel-highlight-id '((t (:inherit underline))) @@ -432,24 +371,6 @@ the location with pulsing. (hcel-text-property-near-point 'identifier) (hcel-text-property-near-point 'occurrence))) -(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) - (cond ((or (derived-mode-p 'hcel-outline-mode) - (eq (current-buffer) eldoc--doc-buffer)) - (hcel-find-definition-internal - (hcel-text-property-near-point 'package-id) - (hcel-text-property-near-point 'module-path) - (hcel-text-property-near-point 'internal-id))) - ((derived-mode-p 'hcel-ids-mode) - (hcel-find-definition-internal - (alist-get 'packageId (hcel-text-property-near-point 'location-info)) - (alist-get 'modulePath (hcel-text-property-near-point 'location-info)) - (hcel-text-property-near-point '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)) @@ -487,37 +408,5 @@ the location with pulsing. (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" - (add-hook 'xref-backend-functions - #'hcel-minor--xref-backend nil t) - (cond - ((null hcel-minor-mode) - (remove-hook 'eldoc-documentation-functions #'hcel-minor-eldoc-id-type t) - (remove-hook 'eldoc-documentation-functions #'hcel-minor-eldoc-docs t)) - ((not (or (apply 'derived-mode-p hcel-minor-major-modes) - (eq (current-buffer) eldoc--doc-buffer))) - (setq hcel-minor-mode nil) - (error "Not in one of the supported modes (%s) or the eldoc buffer." - (mapconcat #'prin1-to-string hcel-minor-major-modes - ", "))) - (t - (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)))) - (provide 'hcel-source) ;;; hcel-source.el ends here. diff --git a/hcel-utils.el b/hcel-utils.el index 6d44a4c..3bd8841 100644 --- a/hcel-utils.el +++ b/hcel-utils.el @@ -28,26 +28,6 @@ "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. diff --git a/hcel.el b/hcel.el index 43da466..885668d 100644 --- a/hcel.el +++ b/hcel.el @@ -26,6 +26,9 @@ ;; You should have received a copy of the GNU Affero General Public ;; License along with hcel. If not, see . +(require 'hcel-minor) +(require 'hcel-outline) +(require 'hcel-results) (require 'hcel-source) (require 'hcel-utils) -- cgit v1.2.3