path: root/hcel-source.el

;;; hcel-source.el --- displays Haskell module source. -*- 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 <https://www.gnu.org/licenses/>.

(require 'array)
(require 'dom)
(require 'hcel-client)
(require 'text-property-search)
(require 'json)
(require 'xref)

(defcustom hcel-font-lock-use-haskell-mode nil
  "If non-nil, will use haskell mode for haskell syntax highlight."
  :group 'hcel :type '(boolean))


(defface hcel-type-face '((t :inherit font-lock-type-face))
  "Face used to highlight types" :group 'hcel-faces)
(defface hcel-value-face '((t :inherit font-lock-variable-name-face))
  "Face used to highlight values" :group 'hcel-faces)
(defface hcel-comment-face '((t :inherit font-lock-comment-face))
  "Face used to highlight comments" :group 'hcel-faces)
(defface hcel-pragma-face '((t :inherit font-lock-preprocessor-face))
  "Face used to highlight pragmas" :group 'hcel-faces)

(defvar hcel-comment-re "^\\ *--.*$")
(defvar hcel-pragma-re "^\\ *{-# .*? #-}\\ *$")

(defvar-local hcel-identifiers nil)
(defvar-local hcel-package-id nil)
(defvar-local hcel-module-path nil)
(defvar-local hcel-highlight-id nil)

(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 " ")
  (cursor-sensor-mode 1)
  (add-hook 'xref-backend-functions #'hcel--xref-backend nil t))

(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)
                                            (alist-get 'occurrences json)
                                            (not hcel-font-lock-use-haskell-mode))
          (hcel-annotate-declarations (alist-get 'declarations json))
          (when hcel-font-lock-use-haskell-mode
            (hcel-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-identifiers (alist-get 'identifiers 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 (derived-mode-p '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)
      (hcel-goto-line-column line-beg (1- col-beg))
      (pulse-momentary-highlight-region
       (point) (save-excursion
                 (hcel-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)
		  (with-current-buffer (if (stringp buffer) buffer (car buffer))
		    (derived-mode-p 'hcel-mode))))))
(define-key hcel-mode-map "b" #'hcel-switch-buffer)

(defun hcel-get-location-info (identifier occurrence)
  (or (when identifier (alist-get 'locationInfo identifier))
      ;; happens for import modules
      (when occurrence (alist-get 'contents (alist-get 'sort occurrence)))))

(defun hcel-occ-symbol-at-point ()
  (when-let* ((col-beg (hcel-text-property-near-point 'span-begin))
              (col-end (hcel-text-property-near-point 'span-end)))
    (save-excursion
      (buffer-substring
       (progn (move-to-column col-beg) (point))
       (progn (move-to-column col-end) (point))))))

(defun hcel-type-at-point ()
  (interactive)
  (hcel-render-type-internal hcel-package-id hcel-module-path
                             (hcel-text-property-near-point 'internal-id)
                             (hcel-text-property-near-point 'occurrence)))

(defun hcel-render-type-internal (package-id module-path internal-id
                                             &optional occurrence)
  (when (and package-id module-path (or internal-id occurrence))
    (let ((hcel-buffer (hcel-buffer-name package-id module-path)))
      (when (get-buffer hcel-buffer)
        (with-current-buffer hcel-buffer
          (let* ((identifier (when internal-id
                       (alist-get (intern internal-id) hcel-identifiers)))
                 (id-type (or (alist-get 'idType identifier)
                              (alist-get 'idOccType occurrence))))
            (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-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
                         (hcel-text-property-near-point 'internal-id)))

(defun hcel-id-docs-internal (package-id module-path internal-id)
  (when (and package-id module-path internal-id)
    (let ((hcel-buffer (hcel-buffer-name package-id module-path)))
      (when (get-buffer hcel-buffer)
        (with-current-buffer hcel-buffer
          (when-let*
              ((identifier (alist-get (intern internal-id) hcel-identifiers))
               (location-info (hcel-get-location-info identifier nil))
               (docs
                (or
                 ;; same module
                 (alist-get 'doc identifier)
                 ;; 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 'hcel-tag-span-button-load-source)))))))

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

;; 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))
             (docstring
              (propertize
               doc
               'package-id hcel-package-id
               'module-path hcel-module-path)))
    (funcall cb docstring
             :thing symbol
             :face 'font-lock-variable-name-face)
    (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)
    (run-hooks 'hcel-eldoc-hook)))

(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)
      (run-hooks 'hcel-eldoc-hook))))

;; highlight
(defface hcel-highlight-id-face '((t (:inherit highlight)))
  "Face for highlighting hcel identifier at point."
  :group 'hcel-faces)

(defun hcel-highlight-update (&rest _)
  ;; if mark is active, change of face will deactivate the mark in transient
  ;; mark mode
  (unless mark-active
    (let ((id (get-text-property (point) 'internal-id))
          (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 'internal-id id 'string=))
          (font-lock--remove-face-from-text-property
           (prop-match-beginning match)
           (prop-match-end match) 'face 'hcel-highlight-id-face))))))

(defun hcel-highlight-start (id)
  (when id
    (save-excursion
      (goto-char (point-min))
      (let ((match))
        (while (setq match
                     (text-property-search-forward 'internal-id id 'string=))
          (add-face-text-property
           (prop-match-beginning match)
           (prop-match-end match) 'hcel-highlight-id-face))))))

;; utilities
(defun hcel-write-html-source-line-to-buffer (line occs font-lock)
  (mapc
   (lambda (span)
     (let* ((id (dom-attr span 'data-identifier))
            (position (dom-attr span 'data-occurrence))
            (splitted (when position (split-string position "-")))
            (occ (when position (alist-get (intern position) occs)))
            (tag (alist-get 'tag (alist-get 'sort occ)))
            (content (dom-text span)))
       (insert
        (propertize content
                    'internal-id (unless (string= id "") id)
                    'span-begin (when splitted
                                  (1- (string-to-number (cadr splitted))))
                    'span-end (when splitted
                                (1- (string-to-number (caddr splitted))))
                    'occurrence occ
                    'font-lock-face (when font-lock
                            (cond ((equal tag "TypeId") 'hcel-type-face)
                                  ((equal tag "ValueId") 'hcel-value-face)
                                  ((equal tag "ModuleId") 'hcel-type-face)
                                  ((string-match hcel-comment-re content)
                                   'hcel-comment-face)
                                  ((string-match hcel-pragma-re content)
                                   'hcel-pragma-face)
                                  (t nil)))
                    'cursor-sensor-functions
                    (when id (list #'hcel-highlight-update))))))
   (dom-by-tag line 'span))
  (insert "\n"))

(defun hcel-annotate-declarations (decls)
  (save-excursion
    (mapc
     (lambda (decl)
       (goto-char (point-min))
       (forward-line (1- (alist-get 'lineNumber decl)))
       (add-text-properties (point) (1+ (point))
                            (list 'declaration decl)))
     decls)))

(defun hcel-source-next-declaration ()
  (interactive)
  (beginning-of-line)
  (text-property-search-forward 'declaration nil t))
(define-key hcel-mode-map "n" #'hcel-source-next-declaration)

(defun hcel-source-previous-declaration ()
  (interactive)
  (beginning-of-line)
  (text-property-search-backward 'declaration nil t)
  (left-char))
(define-key hcel-mode-map "p" #'hcel-source-previous-declaration)

(defun hcel-write-html-source-to-buffer (lines occs font-lock)
  (mapc
   (lambda (line)
     (hcel-write-html-source-line-to-buffer line occs font-lock))
   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")))

(defun hcel-tag-span-button-load-source (marker)
  (hcel-load-module-location-info
   (hcel-to-exact-location
    (get-text-property marker 'location-info))))

;; imenu
(defun hcel-imenu-create-index ()
  (hcel-imenu-create-index-internal))

(defun hcel-imenu-create-index-internal (&optional exported-only)
  (unless (derived-mode-p 'hcel-mode)
    (error "Not in hcel-mode!"))
  (goto-char (point-min))
  (let ((index) (match) (exported))
    (while (setq match (text-property-search-forward 'declaration))
      (setq exported (eq (alist-get 'isExported (prop-match-value match)) t))
      (unless (and exported-only (not exported))
        (push (cons
               (propertize
                (hcel-render-components
                 (alist-get 'components
                            (alist-get 'declType (prop-match-value match)))
                 (alist-get 'name (prop-match-value match)))
                'exported exported)
               (1- (point)))
              index)))
    (reverse index)))
(define-key hcel-mode-map "j" #'imenu)

;; xref
(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
   (hcel-text-property-near-point 'internal-id)
   (hcel-text-property-near-point 'occurrence)))

(defun hcel-find-definition-internal (package-id module-path internal-id
                                                 &optional occurrence)
  (when (and package-id module-path (or internal-id 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 internal-id
                  (alist-get (intern internal-id) hcel-identifiers))
                occurrence)))
          (setq location-info (hcel-to-exact-location location-info))
          (let ((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
                         (hcel-goto-line-column line-beg col-beg)
                         (setq pos (1- (point)))
                         (hcel-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))))
                  ;; FIXME: error when trying to find definition for an empty
                  ;; string
                  (t nil))))))))

(provide 'hcel-source)
;;; hcel-source.el ends here.