;; -*- 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-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-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 (alist-get 'documentation (ignore-errors (hcel-definition-site-at-point))) ;; hoogle (when-let ((hoogle-docs (ignore-errors (hcel-hoogle-docs-at-point)))) (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)) (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))))))) ;; hcel-minor mode (defvar hcel-minor-major-modes '(hcel-outline-mode hcel-ids-mode eldoc-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." :after-hook (if hcel-minor-mode (if (not (memq major-mode hcel-minor-major-modes)) (error "Not in one of the following modes: %s" (string-join (mapcar 'prin1-to-string hcel-minor-major-modes) ", "))))) (provide 'hcel-source)