path: root/lisp/hcel-source.el

;;; 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)