From c8caccbadb56fd20ac77d770b03bbe2307014038 Mon Sep 17 00:00:00 2001
From: Chaos Eternal <chaos@shlug.org>
Date: Thu, 24 Aug 2017 18:54:20 +0800
Subject: [PATCH] more reduction on geiser:eval, add test

---
 scheme/chez/geiser/geiser.ss | 58 +++++++++++++---------------
 scheme/chez/geiser/test.ss   | 90 ++++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 117 insertions(+), 31 deletions(-)
 create mode 100644 scheme/chez/geiser/test.ss

diff --git a/scheme/chez/geiser/geiser.ss b/scheme/chez/geiser/geiser.ss
index ca50295..8b9aba7 100644
--- a/scheme/chez/geiser/geiser.ss
+++ b/scheme/chez/geiser/geiser.ss
@@ -34,37 +34,33 @@
 		   (if module
 		       (eval form (environment module))
 		       (eval form))))
-	   (result-mid (call-with-values
-			   (lambda ()
-			     (call/cc
-			      (lambda (k)
-				(with-exception-handler
-				    (lambda (e)
-				      (k 'error e))
-				  (lambda ()
-				    (call-with-values
-					(lambda ()
-					  (body))
-				      (lambda (x . y)
-					(if (null? y)
-					    (k 'single x)
-					    (k 'multi (cons x y))))))))))
-			 (lambda (t v)
-			   (cons t v))))
-	   (result (if (eq? (car result-mid) 'error)
-		       ""
-		       (with-output-to-string
-			 (lambda ()
-			   (pretty-print (cdr result-mid))))))
-	   (error (if (eq? (car result-mid) 'error)
-		      (cons 'error (list
-				    (cons 'key
-					  (with-output-to-string
-					    (lambda () (display-condition (cdr result-mid)))))))
-		      '())))
-      (write `((result ,result)
-	       (output . "")
-	       ,error))
+	   (gen-result (lambda (result-mid is-error?)
+			 (if is-error?
+			     `((result "")
+			       (output . "")
+			       (error . ,(list
+					(cons 'key
+					      (with-output-to-string
+						(lambda ()
+						  (display-condition result-mid)))))))
+			     `((result ,(with-output-to-string
+					  (lambda ()
+					    (pretty-print result-mid))))
+			       (output . "")))))
+	   (result (call/cc
+		    (lambda (k)
+		      (with-exception-handler
+			  (lambda (e)
+			    (k (gen-result e #t)))
+			(lambda ()
+			  (call-with-values
+			      (lambda ()
+				(body))
+			    (lambda (x . y)
+			      (if (null? y)
+				  (k (gen-result x #f))
+				  (k (gen-result (cons x y) #f)))))))))))
+      (write result)
       (newline)))
 
   (define (geiser:module-completions prefix . rest)
diff --git a/scheme/chez/geiser/test.ss b/scheme/chez/geiser/test.ss
new file mode 100644
index 0000000..ac5503b
--- /dev/null
+++ b/scheme/chez/geiser/test.ss
@@ -0,0 +1,90 @@
+(import (geiser)
+	(chezscheme))
+
+
+(define-syntax get-result
+  (syntax-rules ()
+    ((_ form)
+     (with-output-to-string
+       (lambda ()
+	 (geiser:eval #f form))))))
+
+(define-syntax do-test
+  (syntax-rules ()
+    ((_ form result)
+     (assert
+      (equal?
+       (get-result form)
+       result)))))
+
+;; (something-doesnot-exist)
+;;=> Error: Exception: variable something-doesnot-exist is not bound
+(do-test
+ '(something-doesnot-exist)
+ "((result \"\") (output . \"\") (error (key . \"Exception: variable something-doesnot-exist is not bound\")))\n"
+ )
+
+;; (make-violation)
+;;=> #<condition &violation>
+(do-test
+ '(make-violation) 
+ "((result \"#<condition &violation>\\n\") (output . \"\"))\n")
+
+;; (values 1 2 3)
+;;==> (1 2 3)
+(do-test
+ '(values 1 2 3)
+ "((result \"(1 2 3)\\n\") (output . \"\"))\n")
+
+;; 1
+;;=> 1
+(do-test '1 "((result \"1\\n\") (output . \"\"))\n")
+
+
+;; '(case-lambda
+;;    [(x1 x2) (+ x1 x2)]
+;;    [(x1 x2 x3) (+ (+ x1 x2) x3)]
+;;    [(x1 x2 . rest)
+;;     ((letrec ([loop (lambda (x1 x2 rest)
+;; 		      (let ([x (+ x1 x2)])
+;; 			(if (null? rest)
+;; 			    x
+;; 			    (loop x (car rest) (cdr rest)))))])
+;;        loop)
+;;      x1
+;;      x2
+;;      rest)]
+;;    [(x1) (+ x1)]
+;;    [() (+)])
+#|=> (case-lambda
+  [(x1 x2) (+ x1 x2)]
+  [(x1 x2 x3) (+ (+ x1 x2) x3)]
+  [(x1 x2 . rest)
+   ((letrec ([loop (lambda (x1 x2 rest)
+                     (let ([x (+ x1 x2)])
+                       (if (null? rest)
+                           x
+                           (loop x (car rest) (cdr rest)))))])
+      loop)
+     x1
+     x2
+     rest)]
+  [(x1) (+ x1)]
+  [() (+)])
+  |#
+(do-test (quote '(case-lambda
+  [(x1 x2) (+ x1 x2)]
+  [(x1 x2 x3) (+ (+ x1 x2) x3)]
+  [(x1 x2 . rest)
+   ((letrec ([loop (lambda (x1 x2 rest)
+                     (let ([x (+ x1 x2)])
+                       (if (null? rest)
+                           x
+                           (loop x (car rest) (cdr rest)))))])
+      loop)
+     x1
+     x2
+     rest)]
+  [(x1) (+ x1)]
+  [() (+)])) "((result \"(case-lambda\\n  [(x1 x2) (+ x1 x2)]\\n  [(x1 x2 x3) (+ (+ x1 x2) x3)]\\n  [(x1 x2 . rest)\\n   ((letrec ([loop (lambda (x1 x2 rest)\\n                     (let ([x (+ x1 x2)])\\n                       (if (null? rest)\\n                           x\\n                           (loop x (car rest) (cdr rest)))))])\\n      loop)\\n     x1\\n     x2\\n     rest)]\\n  [(x1) (+ x1)]\\n  [() (+)])\\n\") (output . \"\"))\n")
+
-- 
2.11.4.GIT