Change behaviour of REPL output and highlighting

* Narrow font-lock syntax highlighting to only the
  active REPL input region.
* Mark REPL output read-only. This can be changed via the
  option `geiser-repl-read-only-output-p`.
* Mark REPL output with a user-definable face as
  `geiser-font-lock-repl-output`.
  Alternatively an option to syntax highlight REPL output
  is provided via the option `geiser-repl-highlight-output-p`.
  This applies scheme-mode syntax highlighting to any REPL
  output. Any additional hooks defined via scheme-mode-hook
  are also executed for highlighting this region.
* Remove some unwanted TABs in source files.

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