suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

DrDr changes based on emails after Check Up

Browse Source 
svn: r16369
This commit is contained in:
Jay McCarthy 2009-10-19 19:26:19 +00:00
parent 194e496e13
commit 4333342fce
2 changed files with 0 additions and 252 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

143
collects/macro-debugger/view/browse-deriv.ss
View File

@ -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^))
)

109
collects/macro-debugger/view/show-deriv.ss
View File

@ -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"))
)