110 lines
3.1 KiB
Scheme
110 lines
3.1 KiB
Scheme
|
|
(module deriv-show mzscheme
|
|
(require (lib "mrpict.ss" "texpict")
|
|
(lib "utils.ss" "texpict")
|
|
(lib "match.ss")
|
|
(lib "pretty.ss")
|
|
(lib "class.ss")
|
|
(lib "mred.ss" "mred"))
|
|
(require "../model/deriv.ss")
|
|
|
|
(define code-size 12)
|
|
|
|
(define (draw deriv)
|
|
(define (redraw canvas dc)
|
|
(draw-pict the-pict dc 10 10))
|
|
(define f (new frame% (label "Derivation") (width 200) (height 200)))
|
|
(define c (new canvas%
|
|
(parent f)
|
|
(style '(hscroll vscroll))
|
|
(paint-callback redraw)))
|
|
(define _ (dc-for-text-size (new bitmap-dc%)))
|
|
(define the-pict (show deriv))
|
|
(send c init-auto-scrollbars 1000 1000 0.0 0.0)
|
|
(send f show #t))
|
|
|
|
;; code : syntax -> pict
|
|
(define (code stx)
|
|
(let ([out (open-output-string)])
|
|
(print (syntax-object->datum stx) out)
|
|
(text (get-output-string out) null code-size)))
|
|
|
|
;; show : Derivation -> pict
|
|
(define (show deriv)
|
|
(match deriv
|
|
[($ pderiv e1 e2 p)
|
|
(VJ (show-prule p)
|
|
(J e1 e2))]
|
|
[($ mderiv e1 e2 mrule next)
|
|
(let ([top (A (show-mrule mrule) (show next))]
|
|
[bottom (J e1 e2)])
|
|
(vc-append 5
|
|
top
|
|
(hline (max (pict-width top) (pict-width bottom)) 1)
|
|
bottom))]))
|
|
|
|
(define (VJ top bottom)
|
|
(color-frame
|
|
(if top
|
|
(vc-append 5
|
|
top
|
|
(hline (max (pict-width top) (pict-width bottom)) 1)
|
|
bottom)
|
|
(vc-append (hline (pict-width bottom) 1)
|
|
bottom))
|
|
"gray"))
|
|
|
|
(define (show-mrule rule)
|
|
(match rule
|
|
[($ mrule e1 e2 _ _ resolves locals)
|
|
(hb-append (code e1) (text " -> " null code-size) (code e2))]))
|
|
|
|
(define (J e1 e2)
|
|
(colorize (hb-append (code e1) (text " => " null code-size) (code e2)) "blue"))
|
|
(define (A . args)
|
|
(apply hb-append 10 args))
|
|
|
|
(define (show-prule pr)
|
|
(match pr
|
|
[($ p:define-values e1 e2 rs rhs)
|
|
(show rhs)]
|
|
[($ p:define-syntaxes e1 e2 rs rhs)
|
|
(show rhs)]
|
|
[($ p:if e1 e2 rs full? test then else)
|
|
(if full?
|
|
(A (show test) (show then) (show else))
|
|
(A (show test) (show then)))]
|
|
[($ p:wcm e1 e2 rs key value body)
|
|
(A (show key) (show value) (show body))]
|
|
[($ p:set! _ _ _ _ rhs)
|
|
(show rhs)]
|
|
[($ p:set!-macro _ _ _ inner)
|
|
(show inner)]
|
|
[($ p:begin _ _ _ lderiv)
|
|
(show-lderiv lderiv)]
|
|
[($ p:begin0 _ _ _ deriv0 lderiv)
|
|
(A (show deriv0) (show-lderiv lderiv))]
|
|
[($ p:#%app _ _ _ lderiv)
|
|
(show-lderiv lderiv)]
|
|
[($ p:lambda _ _ _ renames body)
|
|
(show-bderiv body)]
|
|
;; case-lambda
|
|
;; let-values
|
|
;; let*-values
|
|
;; letrec-values
|
|
;; letrec-syntaxes+values
|
|
[($ prule e1 e2 rs)
|
|
#f #;(text "" null code-size)]))
|
|
|
|
(define (show-lderiv ld)
|
|
(match ld
|
|
[($ lderiv es1 es2 derivs)
|
|
(vc-append 5
|
|
(apply A (map show derivs))
|
|
(J es1 es2))]))
|
|
|
|
(define (show-bderiv bd)
|
|
(colorize (text "block" null code-size) "red"))
|
|
|
|
)
|