DrDr changes based on emails after Check Up
svn: r16369
This commit is contained in:
Jay McCarthy
parent
194e496e13
commit
4333342fce
|
|
@ -1,143 +0,0 @@
|
|||
|
||||
(module browse-deriv mzscheme
|
||||
(require mzlib/class
|
||||
mzlib/plt-match
|
||||
mzlib/unit
|
||||
mred
|
||||
framework
|
||||
mrlib/hierlist)
|
||||
(require "../model/deriv.ss")
|
||||
(provide (all-defined))
|
||||
|
||||
(define-signature browser^ (make-browser))
|
||||
|
||||
(define-signature node^
|
||||
(;; type Node
|
||||
|
||||
;; node-children : Node -> (list-of Node)
|
||||
node-children
|
||||
|
||||
;; node-summary-string : Node -> string
|
||||
node-summary-string
|
||||
|
||||
;; node-display : Node text% -> void
|
||||
node-display
|
||||
))
|
||||
|
||||
(define deriv@
|
||||
(unit
|
||||
(import)
|
||||
(export node^)
|
||||
|
||||
;; Node = (union Derivation Transformation)
|
||||
|
||||
;; node-children
|
||||
(define (node-children node)
|
||||
(match node
|
||||
[(AnyQ mrule (e1 e2 tx next))
|
||||
(list tx next)]
|
||||
[(AnyQ transformation (e1 e2 rs me1 me2 locals))
|
||||
null]
|
||||
[(AnyQ p:define-syntaxes (e1 e2 rs rhs))
|
||||
(list rhs)]
|
||||
[(AnyQ p:define-values (e1 e2 rs rhs))
|
||||
(list rhs)]
|
||||
[(AnyQ p:if (e1 e2 rs full? test then else))
|
||||
(if full?
|
||||
(list test then else)
|
||||
(list test then))]
|
||||
[(AnyQ p:wcm (e1 e2 rs key value body))
|
||||
(list key value body)]
|
||||
[(AnyQ p:set! (e1 e2 rs id-rs rhs))
|
||||
(list rhs)]
|
||||
[(AnyQ p:set!-macro (e1 e2 rs deriv))
|
||||
(list deriv)]
|
||||
[(AnyQ p:begin (e1 e2 rs (AnyQ lderiv (es1 es2 derivs))))
|
||||
derivs]
|
||||
[(AnyQ p:begin0 (e1 e2 rs first (AnyQ lderiv (es1 es2 derivs))))
|
||||
(cons first derivs)]))
|
||||
|
||||
|
||||
;; node-summary-string
|
||||
(define (node-summary-string node)
|
||||
(match node
|
||||
[($ pderiv e1 e2 prule)
|
||||
"PDeriv"]
|
||||
[($ mderiv e1 e2 mrule next)
|
||||
"MDeriv"]
|
||||
|
||||
[($ mrule e1 e2 rs me1 me2 locals)
|
||||
"MRule"]
|
||||
[($ prule e1 e2 rs)
|
||||
"PRule"]))
|
||||
|
||||
;; node-display
|
||||
(define (node-display node text)
|
||||
'...)
|
||||
))
|
||||
|
||||
(define browser@
|
||||
(unit
|
||||
(import node^)
|
||||
(export browser^)
|
||||
|
||||
(define callback-hierlist%
|
||||
(class hierarchical-list%
|
||||
(init-field callback)
|
||||
(define/override (on-select i)
|
||||
(callback i))
|
||||
(super-new)))
|
||||
|
||||
(define browser%
|
||||
(class object%
|
||||
(init-field node)
|
||||
(super-new)
|
||||
|
||||
(define frame (new frame% (label "Derivation browser") (min-width 400) (min-height 400)))
|
||||
(define hpanel (new panel:horizontal-dragable% (parent frame)))
|
||||
(define treeview (new callback-hierlist% (parent hpanel)
|
||||
(callback (lambda (i) (on-item-select i)))))
|
||||
(define details (new text%))
|
||||
(define details-view (new editor-canvas% (parent hpanel) (editor details)))
|
||||
|
||||
(define current-node #f)
|
||||
(define node=>item (make-hash-table))
|
||||
(define item=>node (make-hash-table))
|
||||
|
||||
(define/private (init-tree)
|
||||
(let loop ([node node] [parent treeview])
|
||||
(let ([children (node-children node)])
|
||||
(let ([item (if (pair? children)
|
||||
(send parent new-list)
|
||||
(send parent new-item))])
|
||||
(hash-table-put! node=>item node item)
|
||||
(hash-table-put! item=>node item node)
|
||||
(send (send item get-editor)
|
||||
insert (node-summary-string node))
|
||||
(for-each (lambda (c) (loop c item)) children)
|
||||
(when (pair? children) (send item open))))))
|
||||
|
||||
(define/private (on-item-select item)
|
||||
(let ([node (hash-table-get item=>node item (lambda () #f))])
|
||||
(unless (eq? node current-node)
|
||||
(send details erase))
|
||||
(when node
|
||||
(node-display node details))))
|
||||
|
||||
(init-tree)
|
||||
(send frame show #t)
|
||||
(void)))
|
||||
|
||||
(define (make-browser node)
|
||||
(new browser% (node node)))))
|
||||
|
||||
|
||||
(define app@
|
||||
(compound-unit
|
||||
(import)
|
||||
(link [((NODE node^)) deriv@]
|
||||
[((BROWSER browser^)) browser@ NODE])
|
||||
(export BROWSER)))
|
||||
|
||||
(define-values/invoke-unit app@ (export browser^))
|
||||
)
|
||||
|
|
@ -1,109 +0,0 @@
|
|||
|
||||
(module deriv-show mzscheme
|
||||
(require texpict/mrpict
|
||||
texpict/utils
|
||||
mzlib/match
|
||||
mzlib/pretty
|
||||
mzlib/class
|
||||
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"))
|
||||
|
||||
)
|
||||
Loading…
Reference in New Issue
Block a user