macro-stepper: removed unnecessary partition code

downgraded secondary "partition" to simple binary predicate

original commit: f6f480053eefb840bf723a4c55fa96729d4c4c00

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

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

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<%>)
   ())
 
 

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=?))))