#lang racket
(require [except-in lang/htdp-intermediate-lambda
#%app define lambda require #%module-begin let local define-struct check-expect let*])
(require [prefix-in isl:
[only-in lang/htdp-intermediate-lambda
define lambda require let local define-struct]])
(require test-engine/racket-tests)
(require syntax-color/scheme-lexer)
(require racket/pretty)
(require net/sendurl)
(require [only-in planet/resolver
resolve-planet-path])
(require [only-in planet/config
PLANET-DIR])
(require [only-in racket/runtime-path
define-runtime-path])
(require [only-in web-server/templates
include-template])
(require syntax/toplevel)
(require [for-syntax racket/port])
(require net/base64)
(provide let local let*)
(provide [rename-out (app-recorder #%app)
(check-expect-recorder check-expect)
(custom-define define)
(custom-lambda lambda)])
(provide [all-from-out lang/htdp-intermediate-lambda])
(provide [rename-out (isl:define define)
(isl:lambda lambda)
(isl:require require)
(ds-recorder define-struct)
(isl:let let)])
(provide show-trace trace->json #%module-begin)
(struct node (name formal result actual kids linum idx span) #:mutable #:transparent)
(struct wrapper (value id) #:transparent)
(define (unwrap x)
(if (wrapper? x)
(wrapper-value x)
x))
(define (wrap x)
(wrapper x (gensym "value")))
(define src (box ""))
(define (create-node n f a l i s)
(node n f 'no-result a empty l i s))
(define (add-kid n k)
(set-node-kids! n (cons k (node-kids n))))
(define current-call (make-parameter (create-node 'top-level empty empty 0 0 0)))
(define current-linum (make-parameter 0))
(define current-idx (make-parameter 0))
(define current-span (make-parameter 0))
(define ds-fun-names (box empty))
(define (register-ds name fields)
(let* ([name-s (symbol->string name)]
[name-s-d (string-append name-s
"-")])
(set-box! ds-fun-names
(append
(map string->symbol (list (string-append "make-" name-s)
(string-append name-s "?")))
(map (lambda (field)
(string->symbol
(string-append name-s-d
(symbol->string field))))
fields)
(unbox ds-fun-names)))))
(define-syntax (ds-recorder e)
(syntax-case e ()
[(define-struct name fields)
#'(begin (isl:define-struct name fields)
(register-ds 'name 'fields))]))
(define-syntax (check-expect-recorder e)
(with-syntax ([linum (syntax-line e)]
[idx (syntax-position e)]
[span (syntax-span e)]
[ce 'check-expect]
[actual 'actual]
[expected 'expected])
(syntax-case e ()
[(_ actualStx expectedStx)
#`(begin (define parent-node (create-node 'ce empty empty linum idx span))
(check-expect (let ([actual-node (create-node 'actual (list 'actualStx)
empty
#,(syntax-line #'actualStx)
#,(syntax-position #'actualStx)
#,(syntax-span #'actualStx))])
(add-kid parent-node actual-node)
(parameterize ([current-call actual-node])
(set-node-result! actual-node actualStx))
(when (not (apply equal?
(map node-result
(node-kids parent-node))))
(set-node-result! parent-node #f)
(set-node-kids! parent-node (reverse (node-kids parent-node)))
(add-kid (current-call) parent-node))
(node-result actual-node))
(let ([expected-node (create-node 'expected (list 'expectedStx)
empty
#,(syntax-line #'expectedStx)
#,(syntax-position #'expectedStx)
#,(syntax-span #'expectedStx))])
(add-kid parent-node expected-node)
(parameterize ([current-call expected-node])
(let [(result expectedStx)]
(set-node-result! expected-node result)
result)))))])))
(define-syntax (custom-lambda e)
(syntax-case e ()
[(_ args body)
(with-syntax ([lambda 'lambda])
#'(custom-lambda lambda args body))]
[(_ name (arg-expr ...) body)
#'(lambda (arg-expr ...)
(let ([n (create-node 'name empty (list arg-expr ...)
(current-linum) (current-idx) (current-span))])
(add-kid (current-call) n)
(parameterize ([current-call n])
(let ([result body])
(set-node-result! n result)
result))))]))
(define-syntax (custom-define e)
(syntax-case e ()
[(_ (fun-expr arg-expr ...) body)
#'(define fun-expr
(custom-lambda fun-expr (arg-expr ...) body))]
[(_ fun-expr (lambda arg-exprs body))
#'(custom-define (fun-expr arg-exprs) body)]
[(_ id val)
#'(define id val)]))
(define-syntax (app-recorder e)
(syntax-case e ()
[(_ fun-expr arg-expr ...)
(with-syntax ([linum (syntax-line e)]
[idx (syntax-position e)]
[span (syntax-span e)])
#'(parameterize ([current-linum linum]
[current-idx idx]
[current-span span])
(#%app fun-expr arg-expr ...)))
(identifier? #'fun-expr)
(let* ([binding (identifier-binding #'fun-expr)] [vals (if (list? binding)
(call-with-values
(lambda ()
(module-path-index-split (car binding)))
list)
binding)]
[linum (syntax-line e)]
[idx (syntax-position e)]
[span (syntax-span e)])
(with-syntax ([linum linum]
[idx idx]
[span span])
(if (or (equal? vals 'lexical)
(equal? vals '(#f #f)))
#`(if (or (member 'fun-expr (unbox ds-fun-names))
(struct-accessor-procedure? fun-expr))
(#%app fun-expr arg-expr ...)
(let ([n (create-node 'fun-expr '(arg-expr ...)
"nothing here yet!"
linum idx span)])
(begin
(add-kid (current-call) n)
(let* ([fun fun-expr]
[args (list arg-expr ...)])
(parameterize ([current-call n])
(begin
(set-node-actual! n args)
(let ([v (#%app apply fun args)])
(begin
(set-node-result! n v)
v))))))))
#'(#%app fun-expr arg-expr ...))))]))
(define (print-right t)
(node (node-formal t)
(node-result t)
(node-actual t)
(reverse (map print-right (node-kids t)))))
(define-syntax-rule (show-trace)
(print-right (current-call)))
(define (get-base64 img)
(base64-encode (convert img 'png-bytes)))
(define (json-image img)
(string-append "data:image/png;charset=utf-8;base64,"
(bytes->string/utf-8 (get-base64 img))))
(define (format-nicely x depth width literal)
(if (image? x)
(json-image x)
x
(format "~S"
(let [(p (open-output-string "out"))]
(parameterize [(pretty-print-columns width)
(pretty-print-depth depth)]
((if literal
pretty-print
pretty-display) x p))
(get-output-string p)))))
(define (node->json t)
(local [(define (format-list lst depth literal)
(string-append "["
(string-join (map (lambda (x)
(format-nicely x depth 40 literal))
lst)
",")
"]"))]
(format "{name: \"~a\",
formals: ~a,
formalsShort: ~a,
actuals: ~a,
actualsShort: ~a,
result: ~a,
resultShort: ~a,
linum: ~a,
idx: ~a,
span: ~a,
children: [~a]}"
(node-name t)
(format-list (node-formal t) #f #f)
(format-list (node-formal t) 4 #f)
(format-list (node-actual t) #f #t)
(format-list (node-actual t) 4 #t)
(format-nicely (node-result t) #f 40 #t)
(format-nicely (node-result t) 4 40 #t)
(node-linum t)
(node-idx t)
(node-span t)
(if (empty? (node-kids t))
""
(local ([define (loop k)
(if (empty? (rest k))
(first k)
(string-append (first k)
","
(loop (rest k))))])
(loop (map node->json (reverse (node-kids t)))))))))
(define-syntax-rule (trace->json)
(local [(define (range start end)
(build-list (- end start) (lambda (x) (+ start x))))
(define (lex-port p)
(let-values ([(str type junk start end) (scheme-lexer p)])
(if (eq? type 'eof)
empty
(cons (list type start end)
(lex-port p)))))
(define (colors src)
(foldl (lambda (vals hsh)
(foldl (lambda (num hsh)
(hash-set hsh (first vals)
(cons num
(hash-ref hsh (first vals) empty))))
hsh
(range (second vals)
(third vals))))
(hash)
(lex-port (open-input-string src))))]
(format "var theTrace = ~a\nvar code = ~S"
(node->json (current-call))
(unbox src))))
(define-for-syntax (print-expanded d)
(printf "~a\n"
(syntax->datum (local-expand d 'module (list)))))
(define (page json)
(let ([tracerCSS
(port->string (open-input-file (resolve-planet-path
'(planet tracer/tracer/tracer.css))))]
[jQuery
(port->string (open-input-file (resolve-planet-path
'(planet tracer/tracer/jquery.js))))]
[tracerJS
(port->string (open-input-file (resolve-planet-path
'(planet tracer/tracer/tracer.js))))]
[treeOfTrace json])
(include-template "index.html")))
(define-syntax (#%module-begin stx)
(syntax-case stx ()
[(_ source body ...)
#`(#%plain-module-begin
(set-box! src source)
body ...
(run-tests)
(display-results)
(send-url/contents (page (trace->json))))]))