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

macro-stepper: track phase of binders, definites

Browse Source 
original commit: 3936a4071771a8f40f457e760cf529511ab673de
This commit is contained in:
Ryan Culpepper 2010-11-09 16:13:34 -07:00
parent 186dfbe1e4
commit bd5be74aae
5 changed files with 77 additions and 70 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
collects/macro-debugger/model/reductions-config.rkt
View File

@ -2,6 +2,7 @@
(require (for-syntax racket/base)
racket/contract
racket/match
"../util/eomap.rkt"
"deriv-util.rkt"
"stx-util.rkt"
"context.rkt"
@ -33,8 +34,8 @@
[big-context (parameter/c big-context/c)]
[marking-table (parameter/c (or/c hash? false/c))]
[current-binders (parameter/c (listof identifier?))]
[current-definites (parameter/c (listof identifier?))]
[current-binders (parameter/c (listof identifier?))]
[current-definites (parameter/c eomap?)] ;; eomap[identifier => phase-level]
[current-binders (parameter/c hash?)] ;; hash[identifier => phase-level]
[current-frontier (parameter/c (listof syntax?))]
[sequence-number (parameter/c (or/c false/c exact-nonnegative-integer?))]
[phase (parameter/c exact-nonnegative-integer?)]
@ -80,11 +81,11 @@
;; marking-table
(define marking-table (make-parameter #f))
;; current-binders : parameterof (listof identifier)
(define current-binders (make-parameter null))
;; current-binders : parameter of hash[identifier => phase-level]
(define current-binders (make-parameter #f))
;; current-definites : parameter of (list-of identifier)
(define current-definites (make-parameter null))
;; current-definites : parameter of eomap[identifier => phase-level]
(define current-definites (make-parameter #f))
;; current-frontier : parameter of (list-of syntax)
(define current-frontier (make-parameter null))
@ -149,11 +150,12 @@
(define (learn-definites ids)
(current-definites
(append ids (current-definites))))
(eomap-set* (current-definites) ids (phase))))
(define (learn-binders ids)
(current-binders
(append ids (current-binders))))
(for/fold ([binders (current-binders)]) ([id (in-list ids)])
(hash-set binders id (phase)))))
(define (get-frontier) (or (current-frontier) null))

10
collects/macro-debugger/model/reductions.rkt
View File

@ -1,5 +1,6 @@
#lang racket/base
(require racket/match
"../util/eomap.rkt"
"stx-util.rkt"
"deriv-util.rkt"
"deriv.rkt"
@ -15,10 +16,13 @@
(let-values ([(steps binders definites estx exn) (reductions+ d)])
steps))
;; reductions+ : WDeriv -> (list-of step) (list-of identifier) ?stx ?exn
;; Binders = hasheq[identifier => phase-level]
;; Definites = eomap[identifier => phase-level]
;; reductions+ : WDeriv -> (list-of step) Binders Definites ?stx ?exn
(define (reductions+ d)
(parameterize ((current-definites null)
(current-binders null)
(parameterize ((current-definites (empty-eomap))
(current-binders #hasheq())
(current-frontier null)
(hides-flags (list (box #f)))
(sequence-number 0))

26
collects/macro-debugger/syntax-browser/text.rkt
View File

@ -85,7 +85,6 @@
(define text:arrows<%>
(interface (text:hover-drawings<%>)
add-arrow
add-question-arrow
add-billboard))
;; Mixins
@ -234,12 +233,6 @@
add-hover-drawing
find-wordbreak)
(define/public (add-arrow from1 from2 to1 to2 color)
(internal-add-arrow from1 from2 to1 to2 color #f))
(define/public (add-question-arrow from1 from2 to1 to2 color)
(internal-add-arrow from1 from2 to1 to2 color #t))
(define/public (add-billboard pos1 pos2 str color-name)
(define color (send the-color-database find-color color-name))
(let ([draw
@ -266,7 +259,7 @@
(draw-text str (+ x dx mini) (+ y dy mini adj-y))))))))])
(add-hover-drawing pos1 pos2 draw)))
(define/private (internal-add-arrow from1 from2 to1 to2 color-name question?)
(define/public (add-arrow from1 from2 to1 to2 color-name label where)
(define color (send the-color-database find-color color-name))
(define tack-box (box #f))
(unless (and (= from1 to1) (= from2 to2))
@ -274,7 +267,8 @@
(lambda (text dc left top right bottom dx dy)
(let-values ([(startx starty) (range->mean-loc from1 from2)]
[(endx endy) (range->mean-loc to1 to2)]
[(fw fh _d _v) (send dc get-text-extent "x")])
[(fw fh _d _v) (send dc get-text-extent "x")]
[(lw lh ld _V) (send dc get-text-extent (or label "x"))])
(with-saved-pen&brush dc
(with-saved-text-config dc
(send dc set-pen color 1 'solid)
@ -287,16 +281,16 @@
endx
(+ endy (/ fh 2))
dx dy)
(when question?
(let* ([?x (+ endx dx fw)]
[?y (- (+ endy dy) fh)])
(when label
(let* ([lx (+ endx dx fw)]
[ly (- (+ endy dy) fh)])
(send* dc
(set-brush billboard-brush)
(set-font (?-font dc))
(set-font (billboard-font dc))
(set-text-foreground color)
(draw-rounded-rectangle (- ?x _d) (- ?y _d)
(+ fw _d _d) (+ fh _d _d))
(draw-text "?" ?x ?y))))))))])
(draw-rounded-rectangle (- lx ld) (- ly ld)
(+ lw ld ld) (+ lh ld ld))
(draw-text label lx ly))))))))])
(add-hover-drawing from1 from2 draw tack-box)
(add-hover-drawing to1 to2 draw tack-box))))

63
collects/macro-debugger/syntax-browser/widget.rkt
View File

@ -14,6 +14,7 @@
"properties.rkt"
"text.rkt"
"util.rkt"
"../util/eomap.rkt"
"../util/mpi.rkt")
(provide widget%)
@ -106,9 +107,9 @@
(send -text change-style clickback-style a b)))))
(define/public (add-syntax stx
#:binders [binders null]
#:binders [binders #f]
#:shift-table [shift-table #f]
#:definites [definites null]
#:definites [definites #f]
#:hi-colors [hi-colors null]
#:hi-stxss [hi-stxss null]
#:substitutions [substitutions null])
@ -138,53 +139,59 @@
(send/i display display<%> highlight-syntaxes hi-stxs hi-color))
;; Underline binders (and shifted binders)
(send/i display display<%> underline-syntaxes
(append (apply append (map get-shifted binders))
binders))
(let ([binder-list (hash-map binders (lambda (k v) k))])
(append (apply append (map get-shifted binder-list))
binder-list)))
(send display refresh)
;; Make arrows (& billboards, when enabled)
(when (send config get-draw-arrows?)
(define definite-table (make-hasheq))
(for ([definite (in-list definites)])
(hash-set! definite-table definite #t)
(when shift-table
(for ([shifted-definite (in-list (hash-ref shift-table definite null))])
(hash-set! definite-table shifted-definite #t))))
(define (definite-phase id)
(and definites
(or (eomap-ref definites id #f)
(for/or ([shifted (in-list (hash-ref shift-table id null))])
(eomap-ref definites shifted #f)))))
(define binder-table (make-free-id-table))
(for ([binder (in-list binders)])
(free-id-table-set! binder-table binder binder))
(define phase-binder-table (make-hash))
(define (get-binder-table phase)
(hash-ref! phase-binder-table phase (lambda () (make-free-id-table #:phase phase))))
(for ([(binder phase) (in-hash binders)])
(free-id-table-set! (get-binder-table phase) binder binder))
(define (get-binders id)
(let ([binder (free-id-table-ref binder-table id #f)])
(define (get-binders id phase)
(define (for-one-table table id)
(let ([binder (free-id-table-ref table id #f)])
(cond [(not binder) null]
[shift-table (cons binder (get-shifted binder))]
[else (list binder)])))
(cond [phase (for-one-table (get-binder-table phase) id)]
[else
(apply append
(for/list ([table (in-hash-values phase-binder-table)])
(for-one-table table id)))]))
(for ([id (in-list (send/i range range<%> get-identifier-list))])
(define definite? (hash-ref definite-table id #f))
(define phase (definite-phase id))
(when #f ;; DISABLED
(add-binding-billboard offset range id definite?))
(for ([binder (in-list (get-binders id))])
(add-binding-billboard offset range id phase))
(for ([binder (in-list (get-binders id phase))])
(for ([binder-r (in-list (send/i range range<%> get-ranges binder))])
(for ([id-r (in-list (send/i range range<%> get-ranges id))])
(add-binding-arrow offset binder-r id-r definite?))))))
(add-binding-arrow offset binder-r id-r phase))))))
(void)))
(define/private (add-binding-arrow start binder-r id-r definite?)
(if definite?
(define/private (add-binding-arrow start binder-r id-r phase)
;; phase = #f means not definite binding (ie, "?" arrow)
(send -text add-arrow
(+ start (car binder-r))
(+ start (cdr binder-r))
(+ start (car id-r))
(+ start (cdr id-r))
"blue")
(send -text add-question-arrow
(+ start (car binder-r))
(+ start (cdr binder-r))
(+ start (car id-r))
(+ start (cdr id-r))
"purple")))
(if phase "blue" "purple")
(cond [(equal? phase 0) #f]
[phase (format "phase ~s" phase)]
[else "?"])
(if phase 'end 'start)))
(define/private (add-binding-billboard start range id definite?)
(match (identifier-binding id)

14
collects/macro-debugger/view/step-display.rkt
View File

@ -84,8 +84,8 @@
(show-poststep step shift-table)]))
(define/public (add-syntax stx
#:binders [binders null]
#:definites [definites null]
#:binders [binders #f]
#:definites [definites #f]
#:shift-table [shift-table #f])
(send/i sbview sb:syntax-browser<%> add-syntax stx
#:binders binders
@ -215,8 +215,8 @@
(when (exn:fail:syntax? (misstep-exn step))
(for ([e (exn:fail:syntax-exprs (misstep-exn step))])
(send/i sbview sb:syntax-browser<%> add-syntax e
#:binders (or (state-binders state) null)
#:definites (or (state-uses state) null)
#:binders (state-binders state)
#:definites (state-uses state)
#:shift-table shift-table)))
(show-lctx step shift-table))
@ -230,8 +230,8 @@
[(syntax? content)
(send*/i sbview sb:syntax-browser<%>
(add-syntax content
#:binders (or (state-binders state) null)
#:definites (or (state-uses state) null)
#:binders (state-binders state)
#:definites (state-uses state)
#:shift-table shift-table)
(add-text "\n"))]))
(show-lctx step shift-table))
@ -242,7 +242,7 @@
(define highlight-foci? (send/i config config<%> get-highlight-foci?))
(define highlight-frontier? (send/i config config<%> get-highlight-frontier?))
(send/i sbview sb:syntax-browser<%> add-syntax stx
#:definites (or definites null)
#:definites definites
#:binders binders
#:shift-table shift-table
#:hi-colors (list hi-color