diff options
Diffstat (limited to 'elisp')
| -rw-r--r-- | elisp/geiser-repl.el | 133 | ||||
| -rw-r--r-- | elisp/geiser-syntax.el | 36 |
2 files changed, 154 insertions, 15 deletions
diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el index f61aba5..3be37b7 100644 --- a/elisp/geiser-repl.el +++ b/elisp/geiser-repl.el @@ -26,6 +26,7 @@ (require 'comint) (require 'compile) (require 'scheme) +(require 'font-lock) ;;; Customization: @@ -98,6 +99,16 @@ change that." :type 'boolean :group 'geiser-repl) +(geiser-custom--defcustom geiser-repl-read-only-output-p t + "Whether the REPL's output should be read-only." + :type 'boolean + :group 'geiser-repl) + +(geiser-custom--defcustom geiser-repl-highlight-output-p nil + "Whether to syntax highlight REPL output." + :type 'boolean + :group 'geiser-repl) + (geiser-custom--defcustom geiser-repl-auto-indent-p t "Whether newlines for incomplete sexps are autoindented." :type 'boolean @@ -171,6 +182,9 @@ See also `geiser-debug-auto-display-images-p'." (geiser-custom--defface repl-input 'comint-highlight-input geiser-repl "evaluated input highlighting") +(geiser-custom--defface repl-output + 'font-lock-string-face geiser-repl "REPL output") + (geiser-custom--defface repl-prompt 'comint-highlight-prompt geiser-repl "REPL prompt") @@ -224,6 +238,9 @@ module command as a string") (defvar geiser-repl--repls nil) (defvar geiser-repl--closed-repls nil) +(defvar geiser-repl--last-output-start nil) +(defvar geiser-repl--last-output-end nil) + (make-variable-buffer-local (defvar geiser-repl--repl nil)) @@ -354,15 +371,91 @@ module command as a string") (defun geiser-repl--save-remote-data (address) (setq geiser-repl--address address) (setq header-line-format - (cond ((consp address) - (format "Host: %s Port: %s" - (geiser-repl--host) - (geiser-repl--port))) - ((stringp address) - (format "Socket: %s" address)) - (t nil)))) + (cond ((consp address) + (format "Host: %s Port: %s" + (geiser-repl--host) + (geiser-repl--port))) + ((stringp address) + (format "Socket: %s" address)) + (t nil)))) + +(defun geiser-repl--fontify-output-region (beg end) + "Apply highlighting to a REPL output region." + (remove-text-properties beg end '(font-lock-face nil face nil)) + (if geiser-repl-highlight-output-p + (geiser-syntax--fontify-syntax-region beg end) + (geiser-repl--fontify-plaintext beg end))) + +(defun geiser-repl--fontify-plaintext (start end) + "Fontify REPL output plainly." + (add-text-properties + start end + '(font-lock-fontified t + fontified t + font-lock-multiline t + font-lock-face geiser-font-lock-repl-output))) + + +(defun geiser-repl--narrow-to-prompt () + "Narrow to active prompt region and return t, otherwise returns nil." + (let* ((proc (get-buffer-process (current-buffer))) + (pmark (and proc (process-mark proc))) + (intxt (when (>= (point) (marker-position pmark)) + (save-excursion + (if comint-eol-on-send + (if comint-use-prompt-regexp + (end-of-line) + (goto-char (field-end)))) + (buffer-substring pmark (point))))) + (prompt-beg (marker-position pmark)) + (prompt-end (+ prompt-beg (length intxt)))) + (when (> (length intxt) 0) + (narrow-to-region prompt-beg prompt-end) + t))) + +(defun geiser-repl--wrap-fontify-region-function (beg end &optional loudly) + (save-restriction + (when (geiser-repl--narrow-to-prompt) + (let ((font-lock-dont-widen t)) + (font-lock-default-fontify-region (point-min) (point-max) nil))))) + +(defun geiser-repl--wrap-unfontify-region-function (beg end &optional loudly) + (save-restriction + (when (geiser-repl--narrow-to-prompt) + (let ((font-lock-dont-widen t)) + (font-lock-default-unfontify-region (point-min) (point-max)))))) (defun geiser-repl--output-filter (txt) + (let ((mark-output nil)) + (save-excursion + (goto-char (point-max)) + (re-search-backward comint-prompt-regexp) + ;; move to start of line to prevent accidentally marking a REPL prompt + (move-to-column 0) + ;; Only mark output which: + ;; a) is not on the REPL output line + ;; b) has at least one character + ;; + ;; This makes the magic number for distance 3 -- as the newline + ;; after executing expression is also counted. This is due to the point + ;; being set before comint-send-input. + ;; + ;; Restriction a) applies due to our inability to distinguish between + ;; output from the REPL, and the REPL prompt output. + (let ((distance (- (point) geiser-repl--last-output-start))) + (when (> distance 2) + (setq mark-output t) + (set-marker geiser-repl--last-output-end (point))))) + (when mark-output + (with-silent-modifications + (add-text-properties (1+ geiser-repl--last-output-start) + geiser-repl--last-output-end + `(read-only ,geiser-repl-read-only-output-p)) + (geiser-repl--fontify-output-region (1+ geiser-repl--last-output-start) + geiser-repl--last-output-end) + (font-lock-ensure geiser-repl--last-output-start + geiser-repl--last-output-end)))) + (geiser-con--connection-update-debugging geiser-repl--connection txt) (geiser-image--replace-images geiser-repl-inline-images-p geiser-repl-auto-display-images-p) @@ -415,10 +508,10 @@ module command as a string") (let* ((name (geiser-repl--repl-name impl)) (buff (current-buffer)) (args (cond ((consp address) (list address)) - ((stringp address) '(())) - (t `(,(geiser-repl--binary impl) - nil - ,@(geiser-repl--arglist impl)))))) + ((stringp address) '(())) + (t `(,(geiser-repl--binary impl) + nil + ,@(geiser-repl--arglist impl)))))) (condition-case err (if (and address (stringp address)) ;; Connect over a Unix-domain socket. @@ -619,10 +712,12 @@ If SAVE-HISTORY is non-nil, save CMD in the REPL history." (insert (field-string-no-properties pos)))) (defun geiser-repl--send-input () + (set-marker geiser-repl--last-output-start (point-max)) + (let* ((proc (get-buffer-process (current-buffer))) (pmark (and proc (process-mark proc))) (intxt (and pmark (buffer-substring pmark (point)))) - (eob (point-max))) + (eob (point-max))) (when intxt (and geiser-repl-forget-old-errors-p (not (geiser-repl--is-debugging)) @@ -637,9 +732,9 @@ If SAVE-HISTORY is non-nil, save CMD in the REPL history." (interactive) (let ((p (point))) (cond ((< p (geiser-repl--last-prompt-start)) - (if (geiser-repl--is-input) - (geiser-repl--grab-input) - (ignore-errors (compile-goto-error)))) + (if (geiser-repl--is-input) + (geiser-repl--grab-input) + (ignore-errors (compile-goto-error)))) ((let ((inhibit-field-text-motion t)) (end-of-line) (<= (geiser-repl--nesting-level) 0)) @@ -677,6 +772,8 @@ buffer." "Major mode for interacting with an inferior scheme repl process. \\{geiser-repl-mode-map}" (scheme-mode-variables) + (set (make-local-variable 'geiser-repl--last-output-start) (point-marker)) + (set (make-local-variable 'geiser-repl--last-output-end) (point-marker)) (set (make-local-variable 'face-remapping-alist) '((comint-highlight-prompt geiser-font-lock-repl-prompt) (comint-highlight-input geiser-font-lock-repl-input))) @@ -693,6 +790,12 @@ buffer." (geiser-completion--setup t) (setq geiser-smart-tab-mode-string "") (geiser-smart-tab-mode t) + + (setq-local font-lock-fontify-region-function + #'geiser-repl--wrap-fontify-region-function) + (setq-local font-lock-unfontify-region-function + #'geiser-repl--wrap-unfontify-region-function) + ;; enabling compilation-shell-minor-mode without the annoying highlighter (compilation-setup t)) diff --git a/elisp/geiser-syntax.el b/elisp/geiser-syntax.el index 64b366f..3cc875c 100644 --- a/elisp/geiser-syntax.el +++ b/elisp/geiser-syntax.el @@ -495,6 +495,42 @@ implementation-specific entries for font-lock-keywords.") (font-lock-flush beg end) (with-no-warnings (font-lock-fontify-region beg end))))) +;; derived from org-src-font-lock-fontify-block (org-src.el) +(defun geiser-syntax--fontify-syntax-region (start end) + "Fontify region as Scheme." + (let ((string (buffer-substring-no-properties start end)) + (modified (buffer-modified-p)) + (buffer-undo-list t) + (geiser-buffer (current-buffer))) + (with-current-buffer + (get-buffer-create " *geiser-repl-fontification*") + (let ((inhibit-modification-hooks nil)) + (erase-buffer) + ;; Add string and a final space to ensure property change. + (insert string " ")) + ;; prevent geiser prompt + (let ((geiser-default-implementation + (or geiser-default-implementation + (car geiser-active-implementations)))) + (scheme-mode)) + (font-lock-ensure) + (let ((pos (point-min)) next) + (while (setq next (next-property-change pos)) + ;; Handle additional properties from font-lock, so as to + ;; preserve, e.g., composition. + (dolist (prop (cons 'face font-lock-extra-managed-props)) + (let ((new-prop (get-text-property pos prop)) + (start-point (+ start (1- pos))) + (end-point (1- (+ start next)))) + (put-text-property start-point end-point prop new-prop geiser-buffer))) + (setq pos next)))) + (add-text-properties + start end + '(font-lock-fontified t + fontified t + font-lock-multiline t)) + (set-buffer-modified-p modified))) + (defun geiser-syntax--scheme-str (str) (save-current-buffer (set-buffer (geiser-syntax--font-lock-buffer)) |