304 lines
11 KiB
Scheme
304 lines
11 KiB
Scheme
|
|
(module eval mzscheme
|
|
(require "manual.ss"
|
|
"struct.ss"
|
|
"scheme.ss"
|
|
"decode.ss"
|
|
(lib "class.ss")
|
|
(lib "file.ss")
|
|
(lib "string.ss"))
|
|
|
|
(provide interaction
|
|
interaction-eval
|
|
interaction-eval-show
|
|
schemeblock+eval
|
|
schememod+eval
|
|
def+int
|
|
defs+int
|
|
examples
|
|
examples*
|
|
defexamples
|
|
defexamples*
|
|
as-examples
|
|
|
|
current-int-namespace
|
|
eval-example-string
|
|
|
|
scribble-eval-handler)
|
|
|
|
(define current-int-namespace (make-parameter (current-namespace)))
|
|
(define scribble-eval-handler (make-parameter (lambda (c? x) (eval x))))
|
|
|
|
(define image-counter 0)
|
|
|
|
(define maxlen 60)
|
|
|
|
(define (interleave title expr-paras val-list+outputs)
|
|
(make-table
|
|
#f
|
|
(append
|
|
(if title (list (list (make-flow (list title)))) null)
|
|
(let loop ([expr-paras expr-paras]
|
|
[val-list+outputs val-list+outputs]
|
|
[first? #t])
|
|
(if (null? expr-paras)
|
|
null
|
|
(append
|
|
(list (list (let ([p (car expr-paras)])
|
|
(if (flow? p)
|
|
p
|
|
(make-flow (list p))))))
|
|
(if (string=? "" (cdar val-list+outputs))
|
|
null
|
|
(list
|
|
(list
|
|
(make-flow
|
|
(list
|
|
(let ([s (regexp-split #rx"\n"
|
|
(regexp-replace #rx"\n$"
|
|
(cdar val-list+outputs)
|
|
""))])
|
|
(if (= 1 (length s))
|
|
(make-paragraph
|
|
(list
|
|
(hspace 2)
|
|
(span-class "schemestdout" (car s))))
|
|
(make-table
|
|
#f
|
|
(map (lambda (s)
|
|
(list (make-flow (list (make-paragraph
|
|
(list
|
|
(hspace 2)
|
|
(span-class "schemestdout" s)))))))
|
|
s)))))))))
|
|
(if (string? (caar val-list+outputs))
|
|
;; Error result case:
|
|
(map
|
|
(lambda (s)
|
|
(list (make-flow (list (make-paragraph
|
|
(list
|
|
(hspace 2)
|
|
(span-class "schemeerror"
|
|
(italic s))))))))
|
|
(let sloop ([s (caar val-list+outputs)])
|
|
(if ((string-length s) . > . maxlen)
|
|
;; break the error message into multiple lines:
|
|
(let loop ([pos (sub1 maxlen)])
|
|
(cond
|
|
[(zero? pos) (cons (substring s 0 maxlen)
|
|
(sloop (substring s maxlen)))]
|
|
[(char-whitespace? (string-ref s pos))
|
|
(cons (substring s 0 pos)
|
|
(sloop (substring s (add1 pos))))]
|
|
[else (loop (sub1 pos))]))
|
|
(list s))))
|
|
;; Normal result case:
|
|
(let ([val-list (caar val-list+outputs)])
|
|
(if (equal? val-list (list (void)))
|
|
null
|
|
(map (lambda (v)
|
|
(list (make-flow (list (make-paragraph
|
|
(list
|
|
(hspace 2)
|
|
(span-class "schemeresult"
|
|
(to-element/no-color v))))))))
|
|
val-list))))
|
|
(loop (cdr expr-paras)
|
|
(cdr val-list+outputs)
|
|
#f)))))))
|
|
|
|
(define (do-eval s)
|
|
(syntax-case s (code:comment eval:alts)
|
|
[(code:line v (code:comment . rest))
|
|
(do-eval #'v)]
|
|
[(eval:alts p e)
|
|
(do-eval #'e)]
|
|
[else
|
|
(let ([o (open-output-string)])
|
|
(parameterize ([current-output-port o])
|
|
(with-handlers ([exn? (lambda (e)
|
|
(cons (exn-message e)
|
|
(get-output-string o)))])
|
|
(cons (let ([v (do-plain-eval s #t)])
|
|
(copy-value v (make-hash-table)))
|
|
(get-output-string o)))))]))
|
|
|
|
(define (install ht v v2)
|
|
(hash-table-put! ht v v2)
|
|
v2)
|
|
|
|
;; Since we evaluate everything in an interaction before we typeset,
|
|
;; copy each value to avoid side-effects.
|
|
(define (copy-value v ht)
|
|
(cond
|
|
[(and v (hash-table-get ht v #f))
|
|
=> (lambda (v) v)]
|
|
[(string? v) (install ht v (string-copy v))]
|
|
[(bytes? v) (install ht v (bytes-copy v))]
|
|
[(pair? v) (let ([p (cons #f #f)])
|
|
(hash-table-put! ht v p)
|
|
(set-car! p (copy-value (car v) ht))
|
|
(set-cdr! p (copy-value (cdr v) ht))
|
|
p)]
|
|
[(vector? v) (let ([v2 (make-vector (vector-length v))])
|
|
(hash-table-put! ht v v2)
|
|
(let loop ([i (vector-length v2)])
|
|
(unless (zero? i)
|
|
(let ([i (sub1 i)])
|
|
(vector-set! v2 i (copy-value (vector-ref v i) ht))
|
|
(loop i))))
|
|
v2)]
|
|
[(box? v) (let ([v2 (box #f)])
|
|
(hash-table-put! ht v v2)
|
|
(set-box! v2 (copy-value (unbox v) ht))
|
|
v2)]
|
|
[else v]))
|
|
|
|
(define (strip-comments stx)
|
|
(syntax-case stx (code:comment code:blank)
|
|
[((code:comment . _) . rest)
|
|
(strip-comments #'rest)]
|
|
[(a . b)
|
|
(datum->syntax-object stx
|
|
(cons (strip-comments #'a)
|
|
(strip-comments #'b))
|
|
stx
|
|
stx
|
|
stx)]
|
|
[code:blank #'(void)]
|
|
[else stx]))
|
|
|
|
|
|
(define (do-plain-eval s catching-exns?)
|
|
(parameterize ([current-namespace (current-int-namespace)])
|
|
(call-with-values (lambda () ((scribble-eval-handler) catching-exns? (strip-comments s))) list)))
|
|
|
|
(define-syntax interaction-eval
|
|
(syntax-rules ()
|
|
[(_ e) (#%expression
|
|
(begin (parameterize ([current-command-line-arguments #()])
|
|
(do-plain-eval (quote-syntax e) #f))
|
|
""))]))
|
|
|
|
|
|
(define (show-val v)
|
|
(span-class "schemeresult"
|
|
(to-element/no-color v)))
|
|
|
|
(define-syntax interaction-eval-show
|
|
(syntax-rules ()
|
|
[(_ e) (#%expression
|
|
(parameterize ([current-command-line-arguments #()])
|
|
(show-val (car (do-plain-eval (quote-syntax e) #f)))))]))
|
|
|
|
(define (eval-example-string s)
|
|
(eval (read (open-input-string s))))
|
|
|
|
(parameterize ([current-namespace (current-int-namespace)])
|
|
(eval `(define eval-example-string ,eval-example-string)))
|
|
|
|
(define-syntax schemeinput*
|
|
(syntax-rules (eval-example-string eval:alts)
|
|
[(_ (eval-example-string s))
|
|
(make-paragraph
|
|
(list
|
|
(hspace 2)
|
|
(tt "> ")
|
|
(span-class "schemevalue" (schemefont s))))]
|
|
[(_ (eval:alts a b)) (schemeinput* a)]
|
|
[(_ e) (schemeinput e)]))
|
|
|
|
(define-code schemeblock+line (to-paragraph/prefix (hspace 2)
|
|
(hspace 2)
|
|
(list " ")))
|
|
|
|
(define-syntax (schemedefinput* stx)
|
|
(syntax-case stx (eval-example-string define define-values define-struct)
|
|
[(_ (eval-example-string s))
|
|
#'(schemeinput* (eval-example-string s))]
|
|
[(_ (define . rest))
|
|
(syntax-case stx ()
|
|
[(_ e) #'(schemeblock+line e)])]
|
|
[(_ (define-values . rest))
|
|
(syntax-case stx ()
|
|
[(_ e) #'(schemeblock+line e)])]
|
|
[(_ (define-struct . rest))
|
|
(syntax-case stx ()
|
|
[(_ e) #'(schemeblock+line e)])]
|
|
[(_ (code:line (define . rest) . rest2))
|
|
(syntax-case stx ()
|
|
[(_ e) #'(schemeblock+line e)])]
|
|
[(_ e) #'(schemeinput e)]))
|
|
|
|
(define-syntax titled-interaction
|
|
(syntax-rules ()
|
|
[(_ t schemeinput* e ...)
|
|
(interleave t
|
|
(list (schemeinput* e) ...)
|
|
(map do-eval (list (quote-syntax e) ...)))]))
|
|
|
|
(define-syntax interaction
|
|
(syntax-rules ()
|
|
[(_ e ...) (titled-interaction #f schemeinput* e ...)]))
|
|
|
|
(define-syntax schemeblock+eval
|
|
(syntax-rules ()
|
|
[(_ e ...)
|
|
(#%expression
|
|
(begin (interaction-eval e) ...
|
|
(schemeblock e ...)))]))
|
|
|
|
(define-syntax schememod+eval
|
|
(syntax-rules ()
|
|
[(_ name e ...)
|
|
(#%expression
|
|
(begin (interaction-eval e) ...
|
|
(schememod name e ...)))]))
|
|
|
|
(define-syntax def+int
|
|
(syntax-rules ()
|
|
[(_ def e ...)
|
|
(make-splice (list (schemeblock+eval def)
|
|
(interaction e ...)))]))
|
|
|
|
(define-syntax defs+int
|
|
(syntax-rules ()
|
|
[(_ [def ...] e ...)
|
|
(make-splice (list (schemeblock+eval def ...)
|
|
(interaction e ...)))]))
|
|
|
|
(define example-title
|
|
(make-paragraph (list "Examples:")))
|
|
(define-syntax examples
|
|
(syntax-rules ()
|
|
[(_ e ...)
|
|
(titled-interaction example-title schemeinput* e ...)]))
|
|
(define-syntax examples*
|
|
(syntax-rules ()
|
|
[(_ example-title e ...)
|
|
(titled-interaction example-title schemeinput* e ...)]))
|
|
(define-syntax defexamples
|
|
(syntax-rules ()
|
|
[(_ e ...)
|
|
(titled-interaction example-title schemedefinput* e ...)]))
|
|
(define-syntax defexamples*
|
|
(syntax-rules ()
|
|
[(_ example-title e ...)
|
|
(titled-interaction example-title schemedefinput* e ...)]))
|
|
|
|
(define (do-splice l)
|
|
(cond
|
|
[(null? l) null]
|
|
[(splice? (car l)) (append (splice-run (car l))
|
|
(do-splice (cdr l)))]
|
|
[else (cons (car l) (do-splice (cdr l)))]))
|
|
|
|
(define as-examples
|
|
(case-lambda
|
|
[(t) (as-examples example-title t)]
|
|
[(example-title t)
|
|
(make-table #f
|
|
(list
|
|
(list (make-flow (list example-title)))
|
|
(list (make-flow (do-splice (list t))))))])))
|