From bf28ac7e4e8a80daae955fba5b02bbd2b0ea5d67 Mon Sep 17 00:00:00 2001
From: Yuchen Pei <hi@ypei.me>
Date: Mon, 5 Sep 2022 15:27:00 +1000
Subject: Adding elisp client.

---
 lisp/hcel-source.el | 359 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 359 insertions(+)
 create mode 100644 lisp/hcel-source.el

(limited to 'lisp/hcel-source.el')

diff --git a/lisp/hcel-source.el b/lisp/hcel-source.el
new file mode 100644
index 0000000..c397387
--- /dev/null
+++ b/lisp/hcel-source.el
@@ -0,0 +1,359 @@
+;; -*- lexical-binding: t; -*-
+(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-definition-site-at-point ()
+  "Call definitionSite for identifier at point.
+
+May cause error if the identifier has exact location."
+  (hcel-definition-site-location-info
+   (hcel-get-location-info (hcel-lookup-identifier-at-point)
+                           (hcel-lookup-occurrence-at-point))))
+
+(defun hcel-lookup-identifier-at-point ()
+  (when-let ((identifier (get-text-property (point) 'identifier)))
+    (alist-get (intern identifier) hcel-identifiers)))
+
+(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)
+  (let ((identifier (hcel-lookup-identifier-at-point)))
+    (when-let ((id-type
+                (or (alist-get 'idType identifier)
+                    (alist-get 'idOccType (hcel-lookup-occurrence-at-point)))))
+      (concat
+       (hcel-render-id-type id-type)
+       (when-let* ((external-id (alist-get 'externalId identifier))
+                   (splitted (split-string external-id "|"))
+                   (package-id (car splitted))
+                   (module-name (cadr splitted)))
+         (concat "\nDefined in: " package-id " " module-name ""))))))
+
+(defun hcel-hoogle-docs-at-point ()
+  (when-let* ((location-info
+               (hcel-get-location-info (hcel-lookup-identifier-at-point)
+                                       (hcel-lookup-occurrence-at-point)))
+              (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 ()
+  (when-let
+      ((docs
+        (or
+         ;; same module
+         (alist-get 'doc (hcel-lookup-identifier-at-point))
+         ;; other module
+         (when-let
+             ((definition (ignore-errors (hcel-definition-site-at-point))))
+           (alist-get 'documentation definition))
+         ;; hoogle
+         (when-let ((hoogle-docs
+                     (ignore-errors (hcel-hoogle-docs-at-point))))
+           (when (length> hoogle-docs 0) (concat "Hoogle: " hoogle-docs))))))
+    (with-temp-buffer
+      (insert docs)
+      (shr-render-region (point-min) (point-max))
+      (buffer-string))))
+
+;; 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))
+             (docstring
+              (hcel-type-at-point)))
+    (funcall cb docstring
+             :thing symbol
+             :face 'font-lock-variable-name-face)))
+
+(defun hcel-eldoc-docs (cb)
+  (when-let ((docstring (hcel-id-docs-at-point)))
+    (setq this-command nil)
+    (funcall cb docstring)))
+
+(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))))
+
+;; 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 ()
+  (let* ((location-info
+          (hcel-get-location-info (hcel-lookup-identifier-at-point)
+                                  (hcel-lookup-occurrence-at-point))))
+    (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)))))))
+
+(provide 'hcel-source)
-- 
cgit v1.2.3