From ed8d52653554d97d22e19cf814e70ef5de4c612a Mon Sep 17 00:00:00 2001
From: Alexis King <lexi.lambda@gmail.com>
Date: Sat, 12 Sep 2015 22:25:08 -0700
Subject: [PATCH] Add pict/code/eval with typeset-interaction, a la
 scribble/eval

---
 pict-doc/info.rkt                    |  1 +
 pict-doc/pict/scribblings/code.scrbl | 44 +++++++++++++++++++++++++++-
 pict-lib/info.rkt                    |  4 ++-
 pict-lib/pict/code/eval.rkt          | 44 ++++++++++++++++++++++++++++
 4 files changed, 91 insertions(+), 2 deletions(-)
 create mode 100644 pict-lib/pict/code/eval.rkt

diff --git a/pict-doc/info.rkt b/pict-doc/info.rkt
index ba67cb0..373ddf5 100644
--- a/pict-doc/info.rkt
+++ b/pict-doc/info.rkt
@@ -8,6 +8,7 @@
                      "slideshow-doc"
                      "draw-lib"
                      "gui-lib"
+                     "scribble-doc"
                      "scribble-lib"
                      "slideshow-lib"
                      "pict-lib"
diff --git a/pict-doc/pict/scribblings/code.scrbl b/pict-doc/pict/scribblings/code.scrbl
index 1ffa3da..62809d2 100644
--- a/pict-doc/pict/scribblings/code.scrbl
+++ b/pict-doc/pict/scribblings/code.scrbl
@@ -3,8 +3,10 @@
           scribble/eval
           (for-label (except-in racket only drop)
                      pict/code
+                     pict/code/eval
                      pict
-                     racket/gui/base))
+                     racket/gui/base
+                     (only-in scribble/eval make-base-eval)))
 
 @(define stx-obj
   (tech #:doc '(lib "scribblings/reference/reference.scrbl") "syntax object"))
@@ -13,6 +15,7 @@
 @(interaction-eval #:eval ss-eval 
   (begin
    (require pict/code
+            pict/code/eval
             pict
             (for-syntax racket/base))
    (current-code-tt (lambda (s) (text s "monospace" 14)))
@@ -391,4 +394,43 @@ Mainly for backward compatibility: returns @racket[(if bl-pict
 
 @; ----------------------------------------
 
+@section{Typeseting Evaluation}
+
+@defmodule[pict/code/eval]
+
+@defproc[(typeset-interaction [#:eval eval procedure? (make-base-eval)]
+                              [stx syntax?] ...)
+         pict?]{
+
+Typesets syntax as Racket code, like @racket[typeset-code], but typesets each
+@racket[stx] like an expression in a REPL. Each @racket[stx] is prefixed with
+a prompt obtained via @racket[get-current-code-interaction-prompt]. Additionally,
+each @racket[stx] is evaluated with @racket[eval], and its result is typeset
+in a single color, as determined by @racket[current-result-color].}
+
+@defform[(interaction maybe-eval datum ...)
+         #:grammar
+         ([maybe-eval (code:line)
+                      (code:line #:eval eval-expr)])]{
+
+The macro form of @racket[typeset-interaction]. Each @racket[datum] will be
+evaluated with @racket[eval-expr] and typeset on a separate line.
+
+@(examples
+  #:eval ss-eval
+  (interaction
+   (+ 1 2 3)
+   (apply string-append '("Hello," " " "world!"))))}
+
+@defparam[get-current-code-interaction-prompt pict (-> pict?)]{
+
+A parameter used to access the pict that should be used as the prompt before each
+expression to evaluate in @racket[typeset-interaction].}
+
+@defparam[current-result-color color (or/c string? (is-a?/c color%))]{
+
+A parameter for the color of the results from @racket[typeset-interaction].}
+
+@; ----------------------------------------
+
 @(close-eval ss-eval)
diff --git a/pict-lib/info.rkt b/pict-lib/info.rkt
index b004904..ec77cab 100644
--- a/pict-lib/info.rkt
+++ b/pict-lib/info.rkt
@@ -5,7 +5,9 @@
 (define deps '("scheme-lib"
                "base"
                "compatibility-lib"
-               "draw-lib"))
+               "draw-lib"
+               "pict-lib"
+               "scribble-lib"))
 (define build-deps '("rackunit-lib"))
 
 (define pkg-desc "implementation (no documentation) part of \"pict\"")
diff --git a/pict-lib/pict/code/eval.rkt b/pict-lib/pict/code/eval.rkt
new file mode 100644
index 0000000..b54112b
--- /dev/null
+++ b/pict-lib/pict/code/eval.rkt
@@ -0,0 +1,44 @@
+#lang racket/base
+
+(require pict
+         pict/code
+         racket/class
+         racket/contract
+         racket/draw
+         (prefix-in scrbl: scribble/eval))
+
+(provide (contract-out
+          [current-result-color (parameter/c (or/c string? (is-a?/c color%)))]
+          [get-current-code-interaction-prompt (parameter/c (-> pict?))]
+          [typeset-interaction ([] [#:eval procedure?] #:rest (listof syntax?) . ->* . pict?)])
+         interaction)
+
+(define current-result-color
+  (make-parameter (make-color 0 0 175)))
+
+(define get-current-code-interaction-prompt
+  (make-parameter (λ () (parameterize ([code-colorize-enabled #f])
+                          (typeset-code #'>)))))
+
+(define (typeset-result stx)
+  (parameterize ([code-colorize-enabled #f])
+    (colorize (typeset-code stx) (current-result-color))))
+
+(define (typeset-evaluation stx #:eval eval)
+  (let ([typeset-expr (typeset-code stx)]
+        [result (eval stx)])
+    (if (void? result)
+        (code #,((get-current-code-interaction-prompt)) #,typeset-expr)
+        (code #,((get-current-code-interaction-prompt)) #,typeset-expr
+              #,(typeset-result (datum->syntax stx result))))))
+
+(define (typeset-interaction #:eval [eval (scrbl:make-base-eval)] . stxs)
+  (let ([evaluations (map (λ (stx) (typeset-evaluation stx #:eval eval)) stxs)])
+    (apply vl-append evaluations)))
+
+(define-syntax interaction
+  (syntax-rules ()
+    [(_ #:eval eval expr ...)
+     (typeset-interaction #:eval eval #'expr ...)]
+    [(_ expr ...)
+     (typeset-interaction #'expr ...)]))