diff --git a/collects/macro-debugger/syntax-browser/controller.rkt b/collects/macro-debugger/syntax-browser/controller.rkt index 82a2d06..c5facda 100644 --- 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 index e0a7da0..bc3b1ff 100644 --- 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 index 5f057ba..9d04748 100644 --- 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 index b99cec0..35f662d 100644 --- 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 `(("" . #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=?))))