first commit, moving out of hcel.

1 files changed, 523 insertions, 0 deletions

diff --git a/hcel-source.el b/hcel-source.el
new file mode 100644
index 0000000..688fff1
--- /dev/null
+++ b/hcel-source.el
@@ -0,0 +1,523 @@
+;;; 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)