summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorjao <jao@gnu.org>2022-10-08 20:54:03 +0100
committerjao <jao@gnu.org>2022-10-08 20:54:03 +0100
commitdb4d645996d1c3da9d50504baa34f3c685cd3b83 (patch)
tree387a2deb75b2c8d987031cc57bbc72469a071aab
parent48427d4aecc6fed751d266673f1ce2ad57ddbcfc (diff)
downloadgeiser-chez-db4d645996d1c3da9d50504baa34f3c685cd3b83.tar.gz
geiser-chez-db4d645996d1c3da9d50504baa34f3c685cd3b83.tar.bz2
better display of evaluation results (dups, spurious compile msgs)
-rw-r--r--geiser-chez.el6
-rw-r--r--src/geiser/geiser.ss75
2 files changed, 39 insertions, 42 deletions
diff --git a/geiser-chez.el b/geiser-chez.el
index 7f29927..b179ef7 100644
--- a/geiser-chez.el
+++ b/geiser-chez.el
@@ -204,10 +204,8 @@ This function uses `geiser-chez-init-file' if it exists."
"Display an error found during evaluation with the given KEY and message MSG."
(when (stringp msg)
(save-excursion (insert msg))
- (geiser-edit--buttonize-files))
- (and (not key)
- (not (zerop (length msg)))
- msg))
+ (geiser-edit--buttonize-files)
+ (not (zerop (length msg)))))
;;; Keywords and syntax:
diff --git a/src/geiser/geiser.ss b/src/geiser/geiser.ss
index 6546579..0a7798b 100644
--- a/src/geiser/geiser.ss
+++ b/src/geiser/geiser.ss
@@ -9,10 +9,36 @@
geiser:macroexpand)
(import (chezscheme))
+ (define (call-with-result thunk)
+ (let ((output-string (open-output-string)))
+ (write
+ (call/cc
+ (lambda (k)
+ (with-exception-handler
+ (lambda (e)
+ (debug-condition e) ; save the condition for the debugger
+ (k `((result "")
+ (output . ,(with-output-to-string
+ (lambda () (display-condition e))))
+ (error (key . condition)))))
+ (lambda ()
+ (call-with-values
+ (lambda ()
+ (parameterize ((current-output-port output-string)) (thunk)))
+ (lambda result
+ `((result ,(with-output-to-string
+ (lambda ()
+ (pretty-print
+ (if (null? (cdr result)) (car result) result)))))
+ (output . ,(get-output-string output-string))))))))))
+ (newline)
+ (close-output-port output-string)))
+
(define (last-index-of str-list char idx last-idx)
(if (null? str-list)
last-idx
- (last-index-of (cdr str-list) char (+ 1 idx) (if (char=? char (car str-list)) idx last-idx))))
+ (last-index-of (cdr str-list) char (+ 1 idx)
+ (if (char=? char (car str-list)) idx last-idx))))
(define (obj-file-name name)
(let ((idx (last-index-of (string->list name) #\. 0 -1)))
@@ -22,8 +48,11 @@
(define (geiser:load-file filename)
(let ((output-filename (obj-file-name filename)))
- (maybe-compile-file filename output-filename)
- (load output-filename)))
+ (call-with-result
+ (lambda ()
+ (with-output-to-string
+ (lambda () (maybe-compile-file filename output-filename)))
+ (load output-filename)))))
(define string-prefix?
(lambda (x y)
@@ -35,50 +64,20 @@
(prefix? (fx+ i 1)))))))))
(define (geiser:completions prefix . rest)
- rest
(sort string-ci<?
(filter (lambda (el)
(string-prefix? prefix el))
- (map write-to-string (environment-symbols (interaction-environment))))))
+ (map write-to-string
+ (environment-symbols (interaction-environment))))))
(define (write-to-string x)
(with-output-to-string
(lambda ()
(write x))))
- (define (geiser:eval module form . rest)
- rest
- (let ((output-string (open-output-string)))
- (write
- (call/cc
- (lambda (k)
- (with-exception-handler
- (lambda (e)
- (debug-condition e) ; save the condition for the debugger
- (k `((result "")
- (output . ,(format "~a~%~a"
- (get-output-string output-string)
- (with-output-to-string
- (lambda ()
- (display-condition e)))))
- (error (key . geiser-debugger)))))
- (lambda ()
- (call-with-values
- ;; evaluate form, allow for multiple return values,
- ;; and capture output in output-string.
- (lambda ()
- (parameterize ((current-output-port output-string))
- (if module
- (eval form (environment module))
- (eval form))))
- (lambda result
- `((result ,(with-output-to-string
- (lambda ()
- (pretty-print
- (if (null? (cdr result)) (car result) result)))))
- (output . ,(get-output-string output-string))))))))))
- (newline)
- (close-output-port output-string)))
+ (define (geiser:eval module form)
+ (call-with-result
+ (lambda () (if module (eval form (environment module)) (eval form)))))
(define (geiser:module-completions prefix . rest)
(define (substring? s1 s2)