commit 803cc3ec82a44c0669d3c57c5865c1e3a35b602c
parent bc306a09bd470a50eae40f26a837bd5e3e3fc7bb
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 1 Jul 2010 13:18:58 -0600
macro-stepper: removed unnecessary partition code
downgraded secondary "partition" to simple binary predicate
original commit: f6f480053eefb840bf723a4c55fa96729d4c4c00
Diffstat:
4 files changed, 23 insertions(+), 141 deletions(-)
diff --git a/collects/macro-debugger/syntax-browser/controller.rkt b/collects/macro-debugger/syntax-browser/controller.rkt
@@ -48,26 +48,20 @@
(define/public-final (reset-primary-partition)
(set! primary-partition (new-bound-partition)))))
-;; secondary-partition-mixin
-(define secondary-partition-mixin
- (mixin (displays-manager<%>) (secondary-partition<%>)
+;; secondary-relation-mixin
+(define secondary-relation-mixin
+ (mixin (displays-manager<%>) (secondary-relation<%>)
(inherit-field displays)
(define-notify identifier=? (new notify-box% (value #f)))
- (define-notify secondary-partition (new notify-box% (value #f)))
(listen-identifier=?
(lambda (name+proc)
- (set-secondary-partition
- (and name+proc
- (new partition% (relation (cdr name+proc)))))))
- (listen-secondary-partition
- (lambda (p)
- (for ([d displays])
+ (for ([d (in-list displays)])
(send/i d display<%> refresh))))
(super-new)))
(define controller%
- (class* (secondary-partition-mixin
+ (class* (secondary-relation-mixin
(selection-manager-mixin
(mark-manager-mixin
(displays-manager-mixin
diff --git a/collects/macro-debugger/syntax-browser/display.rkt b/collects/macro-debugger/syntax-browser/display.rkt
@@ -111,7 +111,7 @@
(let ([selected-syntax
(send/i controller selection-manager<%>
get-selected-syntax)])
- (apply-secondary-partition-styles selected-syntax)
+ (apply-secondary-relation-styles selected-syntax)
(apply-selection-styles selected-syntax))
(send* text
(end-edit-sequence))))
@@ -199,18 +199,18 @@
(for ([style-delta style-deltas])
(restyle-range r style-delta)))))
- ;; apply-secondary-partition-styles : selected-syntax -> void
+ ;; apply-secondary-relation-styles : selected-syntax -> void
;; If the selected syntax is an identifier, then styles all identifiers
- ;; in the same partition in blue.
- (define/private (apply-secondary-partition-styles selected-syntax)
+ ;; in the relation with it.
+ (define/private (apply-secondary-relation-styles selected-syntax)
(when (identifier? selected-syntax)
- (let ([partition
- (send/i controller secondary-partition<%>
- get-secondary-partition)])
- (when partition
+ (let* ([name+relation
+ (send/i controller secondary-relation<%>
+ get-identifier=?)]
+ [relation (and name+relation (cdr name+relation))])
+ (when relation
(for ([id (send/i range range<%> get-identifier-list)])
- (when (send/i partition partition<%>
- same-partition? selected-syntax id)
+ (when (relation selected-syntax id)
(draw-secondary-connection id)))))))
;; apply-selection-styles : syntax -> void
diff --git a/collects/macro-debugger/syntax-browser/interfaces.rkt b/collects/macro-debugger/syntax-browser/interfaces.rkt
@@ -61,18 +61,16 @@
;; reset-primary-partition : -> void
reset-primary-partition))
-;; secondary-partition<%>
-(define-interface secondary-partition<%> ()
- (;; secondary-partition : notify-box of partition<%>
- ;; identifier=? : notify-box of (cons string procedure)
- (methods:notify secondary-partition
- identifier=?)))
+;; secondary-relation<%>
+(define-interface secondary-relation<%> ()
+ (;; identifier=? : notify-box of (cons string (U #f (id id -> bool)))
+ (methods:notify identifier=?)))
;; controller<%>
(define-interface controller<%> (displays-manager<%>
selection-manager<%>
mark-manager<%>
- secondary-partition<%>)
+ secondary-relation<%>)
())
diff --git a/collects/macro-debugger/syntax-browser/partition.rkt b/collects/macro-debugger/syntax-browser/partition.rkt
@@ -4,77 +4,11 @@
"interfaces.rkt"
"../util/stxobj.rkt")
(provide new-bound-partition
- partition%
identifier=-choices)
(define (new-bound-partition)
(new bound-partition%))
-;; representative-symbol : symbol
-;; Must be fresh---otherwise, using it could detect rename wraps
-;; instead of only marks.
-;; For example, in (lambda (representative) representative)
-(define representative-symbol
- (gensym 'representative))
-
-;; unmarked-syntax : identifier
-;; Has no marks---used to initialize bound partition so that
-;; unmarked syntax always gets colored "black"
-(define unmarked-syntax
- (datum->syntax #f representative-symbol))
-
-(define partition%
- (class* object% (partition<%>)
- (init relation)
-
- (define related? (or relation (lambda (a b) #f)))
- (field (rep=>num (make-hasheq)))
- (field (obj=>rep (make-weak-hasheq)))
- (field (reps null))
- (field (next-num 0))
-
- (define/public (get-partition obj)
- (rep->partition (obj->rep obj)))
-
- (define/public (same-partition? A B)
- (= (get-partition A) (get-partition B)))
-
- (define/private (obj->rep obj)
- (hash-ref obj=>rep obj (lambda () (obj->rep* obj))))
-
- (define/public (count)
- next-num)
-
- (define/private (obj->rep* obj)
- (let loop ([reps reps])
- (cond [(null? reps)
- (new-rep obj)]
- [(related? obj (car reps))
- (hash-set! obj=>rep obj (car reps))
- (car reps)]
- [else
- (loop (cdr reps))])))
-
- (define/private (new-rep rep)
- (hash-set! rep=>num rep next-num)
- (set! next-num (add1 next-num))
- (set! reps (cons rep reps))
- rep)
-
- (define/private (rep->partition rep)
- (hash-ref rep=>num rep))
-
- ;; Nearly useless as it stands
- (define/public (dump)
- (hash-for-each
- rep=>num
- (lambda (k v)
- (printf "~s => ~s~n" k v))))
-
- (get-partition unmarked-syntax)
- (super-new)
- ))
-
;; bound-partition%
(define bound-partition%
(class* object% (partition<%>)
@@ -99,57 +33,13 @@
(define/public (count)
next-number)
- (get-partition unmarked-syntax)
+ (get-partition (datum->syntax #f 'nowhere))
(super-new)))
-;; Different identifier relations for highlighting.
-
-(define (lift/rep id=?)
- (lambda (A B)
- (let ([ra (datum->syntax A representative-symbol)]
- [rb (datum->syntax B representative-symbol)])
- (id=? ra rb))))
-
-(define (lift id=?)
- (lambda (A B)
- (and (identifier? A) (identifier? B) (id=? A B))))
-
-;; id:same-marks? : syntax syntax -> boolean
-(define id:same-marks?
- (lift/rep bound-identifier=?))
-
-;; id:X-module=? : identifier identifier -> boolean
-;; If both module-imported, do they come from the same module?
-;; If both top-bound, then same source.
-(define (id:source-module=? a b)
- (let ([ba (identifier-binding a)]
- [bb (identifier-binding b)])
- (cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
- (free-identifier=? a b)]
- [(and (not ba) (not bb))
- #t]
- [(or (not ba) (not bb))
- #f]
- [else
- (eq? (car ba) (car bb))])))
-(define (id:nominal-module=? A B)
- (let ([ba (identifier-binding A)]
- [bb (identifier-binding B)])
- (cond [(or (eq? 'lexical ba) (eq? 'lexical bb))
- (free-identifier=? A B)]
- [(or (not ba) (not bb))
- (and (not ba) (not bb))]
- [else (eq? (caddr ba) (caddr bb))])))
-
-(define (symbolic-identifier=? A B)
- (eq? (syntax-e A) (syntax-e B)))
+;; ==== Identifier relations ====
(define identifier=-choices
(make-parameter
`(("<nothing>" . #f)
("bound-identifier=?" . ,bound-identifier=?)
- ("free-identifier=?" . ,free-identifier=?)
- ("module-or-top-identifier=?" . ,module-or-top-identifier=?)
- ("symbolic-identifier=?" . ,symbolic-identifier=?)
- ("same source module" . ,id:source-module=?)
- ("same nominal module" . ,id:nominal-module=?))))
+ ("free-identifier=?" . ,free-identifier=?))))
