From bf28ac7e4e8a80daae955fba5b02bbd2b0ea5d67 Mon Sep 17 00:00:00 2001 From: Yuchen Pei Date: Mon, 5 Sep 2022 15:27:00 +1000 Subject: Adding elisp client. --- lisp/hcel-outline.el | 195 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 195 insertions(+) create mode 100644 lisp/hcel-outline.el (limited to 'lisp/hcel-outline.el') diff --git a/lisp/hcel-outline.el b/lisp/hcel-outline.el new file mode 100644 index 0000000..b55c2b5 --- /dev/null +++ b/lisp/hcel-outline.el @@ -0,0 +1,195 @@ +;; -*- lexical-binding: t; -*- +(defvar hcel-outline-buffer-name "*hcel-outline*") +(defvar hcel-outline-indentation 2) + +(defvar hcel-outline-mode-map + (let ((kmap (make-sparse-keymap))) + (define-key kmap "n" 'outline-next-visible-heading) + (define-key kmap "p" 'outline-previous-visible-heading) + (define-key kmap "f" 'outline-forward-same-level) + (define-key kmap "F" 'hcel-outline-follow-mode) + (define-key kmap "b" 'outline-backward-same-level) + (define-key kmap "u" 'outline-up-heading) + (define-key kmap "\t" 'hcel-outline-toggle-children) + (define-key kmap "\r" 'hcel-outline-open-thing-at-point) + (define-key kmap "o" 'hcel-outline-open-thing-at-point-other-window) + (define-key kmap "q" 'quit-window) + kmap)) +(define-derived-mode hcel-outline-mode outline-mode "hcel-outline" + "Major mode for browsing Haskell codebases" + (setq-local package-filter nil + module-filter nil + outline-regexp "\\( *\\)." + outline-level (lambda () (1+ (/ (length (match-string 1)) + hcel-outline-indentation))) + buffer-read-only t)) + +(defun hcel () + (interactive) + (let ((buffer (get-buffer hcel-outline-buffer-name))) + (if buffer (switch-to-buffer buffer) + (switch-to-buffer (get-buffer-create hcel-outline-buffer-name)) + (save-excursion + (mapc + (lambda (package) + (insert + (concat (propertize + (hcel-format-package-id package) + 'thing 'package + 'package package + 'children-loaded nil) + "\n"))) + (hcel-api-packages))) + (hcel-outline-mode)))) + +(define-key hcel-mode-map "o" 'hcel) + +;; TODO: maybe remove +(defun hcel-outline-update-opened (package module-path) + "Update the outline tree depending on openness of packages and modules. + +If a package is opened outside of the outline mode (mainly source mode), then +update in the outline mode too." + (with-current-buffer hcel-outline-buffer-name + (save-excursion + (hcel-outline-goto-package package) + (hcel-outline-load-modules-at-point) + (hcel-outline-goto-module module-path) + (hcel-outline-load-identifiers-at-point)))) + +(defun hcel-outline-goto-package (package) + (goto-char (point-min)) + (re-search-forward + (format "^%s$" (hcel-format-package-id package))) + (beginning-of-line)) + +(defun hcel-outline-goto-module (module-path) + "Goto module, assuming point is on the package." + (re-search-forward + (format "^%s%s$" (make-string hcel-outline-indentation 32) module-path)) + (beginning-of-line)) + +(defun hcel-outline-goto-identifier (position) + "Goto identifier declared at POSITION, assuming point is on the module." + (text-property-search-forward 'position position)) + +(defun hcel-outline-load-modules-at-point () + (interactive) + (unless (eq (get-text-property (point) 'thing) 'package) + (error "Point is not at a package!")) + (unless (get-text-property (point) 'children-loaded) + (save-excursion + (let ((inhibit-read-only t) + (package (get-text-property (point) 'package))) + (put-text-property + (progn (beginning-of-line) (point)) + (progn (end-of-line) (point)) + 'children-loaded t) + (beginning-of-line 2) + (mapc + (lambda (module) + (insert + (propertize (concat + (make-string hcel-outline-indentation 32) module "\n") + 'thing 'module + 'package package + 'module-path module + 'folded t))) + (hcel-api-package-info package)))))) + +(defun hcel-outline-toggle-children () + (interactive) + (let ((thing (get-text-property (point) 'thing)) + (children-loaded (get-text-property (point) 'children-loaded))) + (cond (children-loaded (outline-toggle-children)) + ((eq thing 'package) (hcel-outline-load-modules-at-point)) + ((eq thing 'module) (hcel-outline-load-identifiers-at-point)) + (t nil)))) + +(defun hcel-outline-load-identifiers-at-point () + (interactive) + (unless (eq (get-text-property (point) 'thing) 'module) + (error "Point is not at a module!")) + (unless (get-text-property (point) 'children-loaded) + (save-excursion + (let* ((inhibit-read-only t) + (package-id (get-text-property (point) 'package)) + (module-path (get-text-property (point) 'module-path)) + (imenu-index)) + (put-text-property + (progn (beginning-of-line) (point)) + (progn (end-of-line) (point)) + 'children-loaded t) + (when (or (get-buffer (hcel-buffer-name package-id module-path)) + (y-or-n-p "Open module source?")) + (with-current-buffer + (hcel-load-module-source package-id module-path) + (setq imenu-index (save-excursion (hcel-imenu-create-index)))) + (beginning-of-line 2) + (mapc + (lambda (pair) + (insert + (propertize + (concat (make-string (* 2 hcel-outline-indentation) 32) + (car pair) + "\n") + 'thing 'identifier + 'package package-id + 'module-path module-path + 'position (cdr pair)))) + imenu-index)))))) + +(defun hcel-outline-open-module-source-at-point (&optional other-window) + (interactive) + (let ((props (text-properties-at (point)))) + (unless (eq (plist-get props 'thing) 'module) + (error "Point is not at a module!")) + (let ((buffer + (hcel-load-module-source + (plist-get props 'package) + (plist-get props 'module-path)))) + (hcel-outline-load-identifiers-at-point) + (if other-window + (switch-to-buffer-other-window buffer) + (switch-to-buffer buffer))))) + +(defun hcel-outline-open-identifier-at-point (&optional other-window) + (interactive) + (let ((props (text-properties-at (point)))) + (unless (eq (plist-get props 'thing) 'identifier) + (error "Point is not at an identifier!")) + (let ((buffer + (hcel-load-module-source + (plist-get props 'package) + (plist-get props 'module-path)))) + (if other-window + (switch-to-buffer-other-window buffer) + (switch-to-buffer buffer)) + (goto-char (plist-get props 'position))))) + +(defun hcel-outline-open-thing-at-point (&optional other-window) + (interactive) + (cond ((eq (get-text-property (point) 'thing) 'module) + (hcel-outline-open-module-source-at-point other-window)) + ((eq (get-text-property (point) 'thing) 'identifier) + (hcel-outline-open-identifier-at-point other-window)) + (t nil))) + +(defun hcel-outline-open-thing-at-point-other-window () + (interactive) + (let ((current-window (car (window-list)))) + (hcel-outline-open-thing-at-point t) + (select-window current-window))) + +(define-minor-mode hcel-outline-follow-mode + "Display modules and identifiers as point moves." + :after-hook + (if hcel-outline-follow-mode + (if (not (eq major-mode 'hcel-outline-mode)) + (error "Not in hcel-outline mode!") + (add-hook 'post-command-hook + 'hcel-outline-open-thing-at-point-other-window nil t)) + (remove-hook 'post-command-hook + 'hcel-outline-open-thing-at-point-other-window t))) + +(provide 'hcel-outline) -- cgit v1.2.3