racket: displaying images also during evaluations

6 files changed, 109 insertions, 66 deletions

diff --git a/elisp/geiser-debug.el b/elisp/geiser-debug.el
index d7cf338..e5c13bf 100644
--- a/elisp/geiser-debug.el
+++ b/elisp/geiser-debug.el
@@ -1,6 +1,6 @@
 ;;; geiser-debug.el -- displaying debug information and evaluation results
 
-;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2009, 2010, 2011, 2012 Jose Antonio Ortega Ruiz
 
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the Modified BSD License. You should
@@ -42,6 +42,15 @@ has no effect."
   :group 'geiser-debug
   :type 'int)
 
+
+(geiser-custom--defcustom geiser-debug-auto-display-images-p t
+  "Whether to automatically invoke the external viewer to display
+images when they're evaluated.
+
+See also `geiser-repl-auto-display-images-p'."
+  :group 'geiser-debug
+  :type 'boolean)
+
 
 ;;; Debug buffer mode:
 
@@ -102,13 +111,26 @@ buffer.")
             (count-lines (point-min) (point-max)))
           geiser-debug-long-sexp-lines)))
 
-(defun geiser-debug--display-retort (what ret &optional res)
+(defun geiser-debug--insert-res (res)
+  (let ((begin (point)))
+    (insert res)
+    (let ((end (point)))
+      (goto-char begin)
+      (let ((no
+             (geiser-image--replace-images t
+                                           geiser-debug-auto-display-images-p)))
+        (goto-char end)
+        (newline 2)
+        (and no (> no 0))))))
+
+(defun geiser-debug--display-retort (what ret &optional res auto-p)
   (let* ((err (geiser-eval--retort-error ret))
          (key (geiser-eval--error-key err))
          (output (geiser-eval--retort-output ret))
          (impl geiser-impl--implementation)
          (module (geiser-eval--get-module))
-         (jump nil)
+         (dbg nil)
+         (img nil)
          (dir default-directory)
          (buffer (current-buffer))
          (debug (eq key 'geiser-debugger))
@@ -122,16 +144,14 @@ buffer.")
       (unless after
         (geiser-debug--display-error impl module nil what)
         (newline 2))
-      (when (and res (not err))
-        (insert res)
-        (newline 2))
-      (setq jump (geiser-debug--display-error impl module key output))
+      (setq img (when (and res (not err)) (geiser-debug--insert-res res)))
+      (setq dbg (geiser-debug--display-error impl module key output))
       (when after
         (goto-char (point-max))
         (insert "\nExpression evaluated was:\n\n")
         (geiser-debug--display-error impl module nil what))
       (goto-char (point-min)))
-    (when jump (geiser-debug--pop-to-buffer))))
+    (when (or img dbg) (geiser-debug--pop-to-buffer))))
 
 (defsubst geiser-debug--wrap-region (str)
   (format "(begin %s)" str))
diff --git a/elisp/geiser-image.el b/elisp/geiser-image.el
index 6b77ff3..f194e04 100644
--- a/elisp/geiser-image.el
+++ b/elisp/geiser-image.el
@@ -77,29 +77,33 @@ images in `geiser-image-cache-dir'."
   'action 'geiser-image--button-action
   'follow-link t)
 
+(defun geiser-image--insert-button (file)
+  (insert-text-button "[image]"
+                      :type 'geiser-image--button
+                      'face 'geiser-font-lock-image-button
+                      'geiser-image-file file
+                      'help-echo "Click to display image"))
+
 (defun geiser-image--replace-images (inline-images-p auto-p)
   "Replace all image patterns with actual images"
-  (with-silent-modifications
-    (save-excursion
-      (goto-char (point-min))
-      (while (re-search-forward "#<Image: \\([-+./_0-9a-zA-Z]+\\)>" nil t)
-        ;; can't pass a filename to create-image because emacs might
-        ;; not display it before it gets deleted (race condition)
-        (let* ((file (match-string 1))
-               (begin (match-beginning 0))
-               (end (match-end 0)))
-          (delete-region begin end)
-          (if (and inline-images-p (display-images-p))
-              (put-image (create-image file) begin "[image]")
-            (goto-char begin)
-            (insert-text-button "[image]"
-                                :type 'geiser-image--button
-                                'face 'geiser-font-lock-image-button
-                                'geiser-image-file file
-                                'help-echo "Click to display image")
-            (when auto-p (geiser-image--display file)))
-          (setq geiser-image-cache-dir (file-name-directory file))
-          (geiser-image--clean-cache))))))
+  (let ((seen 0))
+    (with-silent-modifications
+      (save-excursion
+        (goto-char (point-min))
+        (while (re-search-forward "\"?#<Image: \\([-+./_0-9a-zA-Z]+\\)>\"?" nil t)
+          (setq seen (+ 1 seen))
+          (let* ((file (match-string 1))
+                 (begin (match-beginning 0))
+                 (end (match-end 0)))
+            (delete-region begin end)
+            (if (and inline-images-p (display-images-p))
+                (put-image (create-image file) begin "[image]")
+              (goto-char begin)
+              (geiser-image--insert-button file)
+              (when auto-p (geiser-image--display file)))
+            (setq geiser-image-cache-dir (file-name-directory file))
+          (geiser-image--clean-cache)))))
+    seen))
 
 (defun geiser-view-last-image (n)
   "Open the last displayed image in the system's image viewer.
diff --git a/elisp/geiser-repl.el b/elisp/geiser-repl.el
index ddcc6b8..c8846ea 100644
--- a/elisp/geiser-repl.el
+++ b/elisp/geiser-repl.el
@@ -123,7 +123,9 @@ If you have a slow system, try to increase this time."
 
 (geiser-custom--defcustom geiser-repl-auto-display-images-p t
   "Whether to automatically invoke the external viewer to display
-images pooping up in the REPL."
+images popping up in the REPL.
+
+See also `geiser-debug-auto-display-images-p'."
   :type 'boolean
   :group 'geiser-repl)
 
diff --git a/scheme/racket/geiser/eval.rkt b/scheme/racket/geiser/eval.rkt
index 26ad959..9b510cf 100644
--- a/scheme/racket/geiser/eval.rkt
+++ b/scheme/racket/geiser/eval.rkt
@@ -1,6 +1,6 @@
 ;;; eval.rkt -- evaluation
 
-;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
+;; Copyright (C) 2009, 2010, 2011, 2012 Jose Antonio Ortega Ruiz
 
 ;; This program is free software; you can redistribute it and/or
 ;; modify it under the terms of the Modified BSD License. You should
@@ -18,7 +18,7 @@
          make-repl-reader)
 
 
-(require geiser/enter geiser/modules)
+(require geiser/enter geiser/modules geiser/images)
 (require errortrace/errortrace-lib)
 
 (define last-result (void))
@@ -37,10 +37,10 @@
 
 (define (write-value v)
   (with-output-to-string
-    (lambda () (write v))))
+    (lambda () (maybe-write-image v))))
 
 (define (set-last-result . vs)
-  (set! last-result `((result  ,@(map write-value vs)))))
+  (set! last-result `((result ,@(map write-value vs)))))
 
 (define (call-with-result thunk)
   (set-last-result (void))
diff --git a/scheme/racket/geiser/images.rkt b/scheme/racket/geiser/images.rkt
new file mode 100644
index 0000000..ddc0286
--- /dev/null
+++ b/scheme/racket/geiser/images.rkt
@@ -0,0 +1,46 @@
+;;; images.rkt -- support for image handline
+
+;; Copyright (C) 2012 Jose Antonio Ortega Ruiz
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the Modified BSD License. You should
+;; have received a copy of the license along with this program. If
+;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
+
+;; Authors: Michael Wilber, Jose Antonio Ortega Ruiz <jao@gnu.org>
+;; Start date: Sun Sep 2, 2012 18:54
+
+
+#lang racket/base
+
+(require racket/file file/convertible racket/pretty)
+(provide image-cache maybe-print-image maybe-write-image)
+
+(define image-cache
+  (let ([ensure-dir (lambda (dir)
+                      (if (path-string? dir)
+                          (begin (make-directory* dir)
+                                 (if (path? dir) (path->string dir) dir))
+                          (path->string (find-system-path 'temp-dir))))])
+    (make-parameter (ensure-dir #f) ensure-dir)))
+
+(define (save-tmpimage imgbytes)
+  ;; Save imgbytes to a new temporary file and return the filename
+  (define filename (make-temporary-file "geiser-img-~a.png" #f (image-cache)))
+  (with-output-to-file filename #:exists 'truncate
+                       (lambda () (display imgbytes)))
+  (format "#<Image: ~a>" filename))
+
+(define (maybe-save-image value)
+  (and (convertible? value)
+       ;; (The above could be problematic if a future version of racket
+       ;; suddenly decides it can "convert" strings to picts)
+       (save-tmpimage (convert value 'png-bytes))))
+
+(define (maybe-print-image value)
+  (cond [(maybe-save-image value) => (lambda (s) (printf "~a\n" s))]
+        [else (unless (void? value)
+                (pretty-print value))]))
+
+(define (maybe-write-image value)
+  (write (or (maybe-save-image value) value)))
diff --git a/scheme/racket/geiser/user.rkt b/scheme/racket/geiser/user.rkt
index 2eb0cb5..e9540b0 100644
--- a/scheme/racket/geiser/user.rkt
+++ b/scheme/racket/geiser/user.rkt
@@ -14,12 +14,10 @@
 (provide init-geiser-repl run-geiser-server start-geiser)
 
 (require (for-syntax racket/base)
-         file/convertible
          mzlib/thread
-         racket/file
-         racket/pretty
          racket/tcp
          geiser
+         geiser/images
          geiser/enter
          geiser/eval
          geiser/modules)
@@ -91,41 +89,14 @@
     (printf "racket@~a> "
             (namespace->module-name (current-namespace) (last-entered)))))
 
-(define image-cache
-  (let ([ensure-dir (lambda (dir)
-                      (if (path-string? dir)
-                          (begin (make-directory* dir)
-                                 (if (path? dir) (path->string dir) dir))
-                          (path->string (find-system-path 'temp-dir))))])
-    (make-parameter (ensure-dir #f) ensure-dir)))
-
 (define (geiser-prompt-read prompt)
   (make-repl-reader (geiser-read prompt)))
 
-(define (geiser-save-tmpimage imgbytes)
-  ;; Save imgbytes to a new temporary file and return the filename
-  (define filename (make-temporary-file "geiser-img-~a.png" #f (image-cache)))
-  (with-output-to-file filename #:exists 'truncate
-    (lambda () (display imgbytes)))
-  filename)
-
-(define (geiser-maybe-print-image value)
-  (cond
-   [(and (convertible? value)
-         (convert value 'png-bytes))
-    => (lambda (pngbytes)
-         ;; (The above could be problematic if a future version of racket
-         ;; suddenly decides it can "convert" strings to picts)
-         (printf "#<Image: ~a>\n" (geiser-save-tmpimage pngbytes)))]
-   [else
-    (unless (void? value)
-      (pretty-print value))]))
-
 (define (init-geiser-repl)
   (compile-enforce-module-constants #f)
   (current-load/use-compiled geiser-loader)
   (current-prompt-read (geiser-prompt-read geiser-prompt))
-  (current-print geiser-maybe-print-image))
+  (current-print maybe-print-image))
 
 (define (run-geiser-repl in out enforce-module-constants)
   (parameterize [(compile-enforce-module-constants enforce-module-constants)
@@ -134,7 +105,7 @@
                  (current-error-port out)
                  (current-load/use-compiled geiser-loader)
                  (current-prompt-read (geiser-prompt-read geiser-prompt))
-                 (current-print geiser-maybe-print-image)]
+                 (current-print maybe-print-image)]
     (read-eval-print-loop)))
 
 (define server-channel (make-channel))