macro stepper: changed hiding policy impl

svn: r12332

original commit: f78ce2c9f33c0d035092ba8085f6b6e4f8812683

collects/macro-debugger/model/hiding-policies.ss

@@ -3,13 +3,358 @@
 (require (for-syntax scheme/base)
          scheme/match
          syntax/boundmap
-         "reductions-config.ss")
+         "reductions-config.ss"
-(provide make-policy
+         "../util/mpi.ss")
-         standard-policy
+(provide policy->predicate)
+
+;; A Policy is one of
+;;   'disable
+;;   'standard
+;;   (list 'custom boolean boolean boolean boolean (listof Entry))
+
+;; An Entry is one of
+;; (list 'show-if Condition)
+;; (list 'hide-if Condition)
+
+;; A Condition is one of:
+;; (list 'free=? identifier)
+;; (list 'lexical)
+;; (list 'unbound)
+;; (list 'binding IdentifierBinding)
+;; (list 'symbol=? symbol)
+;; (list 'symbol-like regexp)
+;; (list 'from-kernel-module)
+;; (list 'from-def-module ModulePath)
+;; (list 'from-nom-module ModulePath)
+;; (list 'from-collection (listof String))
+;; (list 'from-planet-collection String/#f String/#f (listof String))
+;; (list 'phase>=? nat)
+;; (cons 'and Condition)
+;; (cons 'or Condition)
+
+;; policy->predicate
+(define (policy->predicate policy)
+  (define fun (policy->function policy))
+  (lambda (id)
+    (case (fun id)
+      [(show) #t]
+      [(hide) #f]
+      [else (error 'policy->predicate "incomplete policy (returned ~s): ~s"
+                   (fun id)
+                   policy)])))
+
+;; policy->function : Policy -> (id -> choice)
+(define (policy->function policy)
+  (match policy
+    ['disable
+     (lambda (id) 'show)]
+    ['standard
+     (policy->function '(custom #t #t #t #t ()))]
+    [(list 'custom hide-scheme? hide-libs? hide-contracts? hide-phase1? entries)
+     (entries->function entries
+                        (policy-base->function hide-scheme?
+                                               hide-libs?
+                                               hide-contracts?
+                                               hide-phase1?))]))
+
+;; policy-base->function : boolean boolean boolean boolean -> (id -> choice)
+(define (policy-base->function hide-scheme? hide-libs? hide-contracts? hide-phase1?)
+  (entries->function
+   `[(hide-if
+      (or ,@(filter values
+                    (list (and hide-scheme?
+                               '(or (from-kernel-module)
+                                    (from-collection ("scheme"))))
+                          (and hide-libs?
+                               '(or (from-collection ())
+                                    #;(from-planet-collection #f #f ())))
+                          (and hide-contracts?
+                               '(symbol-like #rx"^provide/contract-id-"))
+                          (and hide-phase1?
+                               '(phase>=? 1))))))]
+   (lambda (id) 'show)))
+
+;; entries->function : (listof Entry) (id -> choice) -> (id -> choice)
+(define (entries->function entries base-fun)
+  (if (pair? entries)
+      (let ([first-fun (entry->function (car entries))]
+            [rest-fun (entries->function (cdr entries) base-fun)])
+        (lambda (id)
+          (or (first-fun id)
+              (rest-fun id))))
+      base-fun))
+
+;; entry->function : Entry -> (id -> choice)
+(define (entry->function entry)
+  (match entry
+    [(list 'show-if condition)
+     (let ([pred (condition->predicate condition)])
+       (lambda (id)
+         (if (pred id) 'show #f)))]
+    [(list 'hide-if condition)
+     (let ([pred (condition->predicate condition)])
+       (lambda (id)
+         (if (pred id) 'hide #f)))]
+    [(list 'splice entries)
+     (entries->function entries)]))
+
+;; condition->predicate : condition -> (id -> boolean)
+(define (condition->predicate condition)
+  (match condition
+    [(list 'free=? the-id)
+     (lambda (id)
+       (free-identifier=? id the-id (phase)))]
+    [(list 'lexical)
+     (lambda (id)
+       (eq? (get-binding id) 'lexical))]
+    [(list 'unbound)
+     (lambda (id)
+       (eq? (get-binding id) #f))]
+    [(list 'binding module-binding)
+     (lambda (id)
+       (let ([binding (get-binding id)])
+         (and (pair? binding)
+              (same-binding? binding module-binding))))]
+    [(list 'symbol=? name)
+     (lambda (id)
+       (eq? (syntax-e id) name))]
+    [(list 'symbol-like rx)
+     (lambda (id)
+       (regexp-match? rx (symbol->string (syntax-e id))))]
+    [(list 'from-kernel-module)
+     (lambda (id)
+       (let ([binding (get-binding id)])
+         (and (pair? binding)
+              (kernel-module? (binding-def-module binding)))))]
+    [(list 'from-def-module module-path)
+     (lambda (id)
+       (let ([binding (get-binding id)])
+         (and (pair? binding)
+              (same-module-path? (binding-def-module binding)
+                                 module-path))))]
+    [(list 'from-nom-module module-path)
+     (lambda (id)
+       (let ([binding (get-binding id)])
+         (and (pair? binding)
+              (same-module-path? (binding-nom-module binding)
+                                 module-path))))]
+    [(list 'from-collection collection)
+     (lambda (id)
+       (let ([binding (get-binding id)])
+         (and (pair? binding)
+              (collection-prefix? collection
+                                  (binding-def-module binding)))))]
+    [(list 'phase>=? num)
+     (lambda (id)
+       (>= (phase) num))]
+    [(cons 'and conditions)
+     (let ([predicates (map condition->predicate conditions)])
+       (lambda (id)
+         (for/and ([predicate predicates])
+           (predicate id))))]
+    [(cons 'or conditions)
+     (let ([predicates (map condition->predicate conditions)])
+       (lambda (id)
+         (for/or ([predicate predicates])
+           (predicate id))))]))
+
+(define (kernel-module? mpi)
+  (cond [(module-path-index? mpi)
+         (let-values ([(a b) (module-path-index-split mpi)])
+           (match a
+             [`(quote ,name)
+              (regexp-match? #rx"^#%" (symbol->string name))]
+             [_ #f]))]
+        [else #f]))
+
+;; same-module-path? : mpi mpi -> boolean
+(define (same-module-path? actual expected)
+  (equal? (module-path-index-resolve actual)
+          (module-path-index-resolve expected)))
+
+;; same-binding? : binding binding -> boolean
+(define (same-binding? actual expected)
+  (and (list? actual)
+       (same-module-path? (car actual) (car expected))
+       (eq? (cadr actual) (cadr expected))))
+
+;; collection-prefix? : (listof string) mpi -> boolean
+(define (collection-prefix? collection mpi)
+  (define library-frame
+    (expanded-mpi-sexpr->library
+     (mpi-sexpr->expanded-mpi-sexpr
+      (mpi->mpi-sexpr mpi))))
+  (match library-frame
+    [`(LIB ,paths)
+     (let loop ([cpaths collection] [paths paths])
+       (cond [(and (pair? cpaths) (pair? paths))
+              (and (equal? (car cpaths) (car paths))
+                   (loop (cdr cpaths) (cdr paths)))]
+             [(pair? cpaths) #f]
+             [(pair? paths) #t]))]
+    [_ #f]))
+
+
+;; get-binding : id -> binding
+(define (get-binding id)
+  (identifier-binding id (phase)))
+
+;; binding-def-module : binding -> module-path
+(define (binding-def-module binding)
+  (car binding))
+
+;; binding-def-name : binding -> module-path
+(define (binding-def-name binding)
+  (cadr binding))
+
+;; binding-nom-module : binding -> module-path
+(define (binding-nom-module binding)
+  (caddr binding))
+
+;; binding-nom-name : binding -> module-path
+(define (binding-nom-name binding)
+  (cadddr binding))
+
+
+;; ----
+
+;; Conversion to and from S-expr form.
+;; Conversion is lossy (identifier policies)
+
+;; policy->policy-sexpr
+(define (policy->policy-sexpr policy)
+  (match policy
+    [`(custom ,b1 ,b2 ,b3 ,b4 ,entries)
+     `(CUSTOM ,b1 ,b2 ,b3 ,b4 ,(map entry->entry-sexpr entries))]
+    [_ policy]))
+
+;; policy-sexpr->policy
+(define (policy-sexpr->policy sexpr)
+  (match sexpr
+    [`(CUSTOM ,b1 ,b2 ,b3 ,b4 ,entries)
+     `(custom ,b1 ,b2 ,b3 ,b4 ,(map entry-sexpr->entry entries))]
+    [_ sexpr]))
+
+;; entry->entry-sexpr
+(define (entry->entry-sexpr entry)
+  (match entry
+    [`(show-if ,condition)
+     `(show-if ,(condition->condition-sexpr condition))]
+    [`(hide-if ,condition)
+     `(hide-if ,(condition->condition-sexpr condition))]))
+
+;; entry-sexpr->entry
+(define (entry-sexpr->entry sexpr)
+  (match sexpr
+    [`(show-if ,condition)
+     `(show-if ,(condition-sexpr->condition condition))]
+    [`(hide-if ,condition)
+     `(hide-if ,(condition-sexpr->condition condition))]))
+
+;; condition->condition-sexpr
+(define (condition->condition-sexpr condition)
+  (match condition
+    [(list 'free=? id)
+     (let ([binding (identifier-binding id)])
+       (cond [(list? binding)
+              (condition->condition-sexpr `(binding ,binding))]
+             [(eq? binding 'lexical)
+              `(and (lexical)
+                    (symbol=? ,(syntax-e id)))]
+             [else
+              `(and (unbound)
+                    (symbol=? ,(syntax-e id)))]))]
+    [`(binding (,mod1 ,name1 ,mod2 ,name2 . ,rest))
+     `(BINDING (,(mpi->mpi-sexpr mod1)
+                ,name1
+                ,(mpi->mpi-sexpr mod2)
+                ,name2
+                . ,rest))]
+    [`(from-def-module ,mod)
+     `(FROM-DEF-MODULE ,(mpi->mpi-sexpr mod))]
+    [`(from-nom-module ,mod)
+     `(FROM-NOM-MODULE ,(mpi->mpi-sexpr mod))]
+    [`(and . ,conditions)
+     `(and ,@(map condition->condition-sexpr conditions))]
+    [`(or . ,conditions)
+     `(or ,@(map condition->condition-sexpr conditions))]
+    [_
+     condition]))
+
+;; condition-sexpr->condition
+(define (condition-sexpr->condition sexpr)
+  (match sexpr
+    [`(BINDING (,mod1 ,name1 ,mod2 ,name2 . ,rest))
+     `(binding (,(mpi-sexpr->mpi mod1)
+                ,name1
+                ,(mpi-sexpr->mpi mod2)
+                ,name2
+                . ,rest))]
+    [`(FROM-DEF-MODULE ,mod)
+     `(from-def-module ,(mpi-sexpr->mpi mod))]
+    [`(FROM-NOM-MODULE ,mod)
+     `(from-nom-module ,(mpi-sexpr->mpi mod))]
+    [`(and . ,sexprs)
+     `(and ,@(map condition-sexpr->condition sexprs))]
+    [`(or . ,sexprs)
+     `(or ,@(map condition-sexpr->condition sexprs))]
+    [_ sexpr]))
+
+
+;; ----
+
+(provide same-condition?)
+
+;; same-condition? : condition condition -> boolean
+(define (same-condition? a b)
+  (and (eq? (car a) (car b))
+       (match a
+         [`(free=? ,aid)
+          (let ([bid (cadr b)])
+            (for/and ([n '(0 #| 1 -1 |#)])
+              (free-identifier=? aid bid n)))]
+         [`(binding ,ab)
+          (let ([bb (cadr b)]) 
+            (and (same-module-path? (car ab) (car bb))
+                 (eq? (cadr ab) (cadr bb))
+                 (equal? (list-tail ab 4) (list-tail bb 4))))]
+         [`(from-def-module ,ampi)
+          (same-module-path? ampi (cadr b))]
+         [`(from-nom-module ,ampi)
+          (same-module-path? ampi (cadr b))]
+         [`(and . ,aconditions)
+          (let ([bconditions (cdr b)])
+            (and (= (length aconditions) (length bconditions))
+                 (andmap same-condition? aconditions (cdr b))))]
+         [`(or . ,aconditions)
+          (let ([bconditions (cdr b)])
+            (and (= (length aconditions) (length bconditions))
+                 (andmap same-condition? aconditions (cdr b))))]
+         [_
+          (equal? a b)])))
+
+
+;; ----
+
+(provide standard-policy
          base-policy
          hide-all-policy
          hide-none-policy)
 
+(define standard-policy
+  #;(make-policy #t #t #t #t null)
+  (policy->predicate 'standard))
+
+(define base-policy
+  #;(make-policy #t #f #f #f null)
+  (policy->predicate
+   '(custom #t #f #f #f ())))
+
+(define (hide-all-policy id) #f)
+(define (hide-none-policy id) #t)
+
+#|
+
 ;; make-policy : bool^4 (listof (identifier bindinglist (bool -> void) -> void))
 ;;            -> identifier -> bool
 (define (make-policy hide-mzscheme?
@@ -47,17 +392,7 @@
              #f]
             [else #t]))))
 
-(define standard-policy
+;; ----
-  (make-policy #t #t #t #t null))
-
-(define base-policy
-  (make-policy #t #f #f #f null))
-
-(define (hide-all-policy id) #f)
-(define (hide-none-policy id) #t)
-
-
-;;
 
 (define (scheme-module? mpi)
   (let ([abs (find-absolute-module-path mpi)])
@@ -102,3 +437,4 @@
 (define (lib-module-path? mp)
   (or (symbol? mp)
       (and (pair? mp) (memq (car mp) '(lib planet)))))
+|#

collects/macro-debugger/util/mpi.ss

@@ -1,4 +1,6 @@
 #lang scheme/base
+(require scheme/match)
+
 (provide mpi->list
          mpi->string)
 
@@ -21,3 +23,236 @@
                       (map (lambda (x) (format " <= ~s" x)) (cdr mps)))]
               [(null? mps) "this module"]))
       (format "~s" mpi)))
+
+;; --
+
+(provide mpi->mpi-sexpr
+         mpi-sexpr->mpi
+         rmp->rmp-sexpr
+         rmp-sexpr->rmp)
+
+;; mp = module-path
+;; mpi = module-path-index
+;; rmp = resolved-module-path
+
+;; An mpi-sexpr is one of
+;;   (cons mp-sexpr mpi-sexpr)
+;;   (list rmp-sexpr)
+;;   (list #f)  ;; "self" module
+;;   null
+
+;; mpi->mpi-sexpr : mpi -> mpi-sexpr
+(define (mpi->mpi-sexpr mpi)
+  (cond [(module-path-index? mpi)
+         (let-values ([(mod next) (module-path-index-split mpi)])
+           (cons mod (mpi->mpi-sexpr next)))]
+        [(resolved-module-path? mpi)
+         (list (rmp->rmp-sexpr mpi))]
+        [else null]))
+
+;; mpi-sexpr->mpi : mpi-sexpr -> mpi
+(define (mpi-sexpr->mpi sexpr)
+  (match sexpr
+    ['() #f]
+    [(list (list 'resolved path))
+     (rmp-sexpr->rmp path)]
+    [(cons first rest)
+     (module-path-index-join first (mpi-sexpr->mpi rest))]))
+
+;; rmp->rmp-sexpr : rmp -> rmp-sexpr
+(define (rmp->rmp-sexpr rmp)
+  (list 'resolved (resolved-module-path-name rmp)))
+
+;; rmp-sexpr->rmp : rmp-sexpr -> rmp
+(define (rmp-sexpr->rmp sexpr)
+  (make-resolved-module-path (cadr sexpr)))
+
+;; ----
+
+(provide mpi-sexpr->expanded-mpi-sexpr
+         expanded-mpi-sexpr->mpi-sexpr
+
+         mpi-frame->expanded-mpi-frame
+         expanded-mpi-frame->mpi-frame
+
+         expanded-mpi-sexpr->library
+         absolute-expanded-mpi-frame?
+         library-expanded-mpi-frame?)
+
+;; An expanded-mpi-sexpr is (listof expanded-mpi-frame)
+
+;; An expanded-mpi-frame is one of:
+;;   (list 'LIB (listof string))
+;;   (list 'PLANET (listof string) PackageSpec)
+;;   (list 'FILE string)
+;;      absolute file path (not relative)
+;;   (list 'QUOTE symbol)
+;;   (list 'SELF)
+;;   (list 'REL (listof string))
+;; The first 5 variants are considered "absolute" frames.
+;; The first 2 variants are consider "library" frames.
+
+;; mpi-sexpr->expanded-mpi-sexpr
+(define (mpi-sexpr->expanded-mpi-sexpr sexpr)
+  (map mpi-frame->expanded-mpi-frame sexpr))
+
+;; mpi-frame->expanded-mpi-frame
+(define (mpi-frame->expanded-mpi-frame sexpr)
+  (match sexpr
+    [#f
+     `(SELF)]
+    [`(quote ,mod)
+     `(QUOTE ,mod)]
+    [`(lib ,path)
+     (cond [(symbol? path)
+            (mpi-frame->expanded-mpi-frame path)]
+           [(regexp-match? #rx"/" path)
+            `(LIB ,(split-mods path))]
+           [else
+            `(LIB ,(list "mzlib" path))])]
+    [`(lib ,path . ,more)
+     `(LIB ,(split-mods path more))]
+    [`(planet ,(? symbol? spec))
+     (mpi-frame->expanded-mpi-frame (parse-planet-spec spec))]
+    [`(planet ,path ,package . ,more)
+     `(PLANET ,(split-mods path more) ,package)]
+    [(? symbol? mod)
+     `(LIB ,(split-mods* (symbol->string mod)))]
+    [`(file ,path)
+     (cond [(absolute-path? path)
+            `(FILE ,path)]
+           [else
+            `(REL (split-mods path))])]
+    [(? string? path)
+     `(REL ,(split-mods path))]))
+
+;; expanded-mpi-sexpr->mpi-sexpr
+(define (expanded-mpi-sexpr->mpi-sexpr sexpr)
+  (map expanded-mpi-frame->mpi-frame sexpr))
+
+;; expanded-mpi-frame->mpi-frame
+(define (expanded-mpi-frame->mpi-frame sexpr)
+  (match sexpr
+    [`(SELF)
+     #f]
+    [`(QUOTE ,mod)
+     `(quote ,mod)]
+    [`(LIB ,paths)
+     `(lib ,(apply string-append (intersperse "/" paths)))]
+    [`(PLANET ,paths ,package)
+     `(planet ,(apply string-append (intersperse "/" paths)) ,package)]
+    [`(FILE ,path)
+     `(file ,path)]
+    [`(REL ,paths)
+     (apply string-append (intersperse "/" paths))]))
+
+(define (parse-planet-spec spec-sym)
+  (define spec (symbol->string spec-sym))
+  (let ([m (regexp-match #rx"([^/]*)/([^:/]*)(?:[:]([^/]*))?(?:/(.*))?" spec)])
+    (unless m (error "bad planet symbol" spec-sym))
+    (let ([owner (cadr m)]
+          [package (string-append (caddr m) ".plt")]
+          [version (and (cadddr m) (parse-version (cadddr m)))]
+          [path (list-ref m 4)])
+      `(planet ,(string-append (or path "main") ".ss")
+               (,owner ,package . ,version)))))
+
+(define (parse-version str)
+  ;; FIXME!!!
+  '())
+
+(define (split-mods* path)
+  (let ([mods (split-mods path)])
+    (if (and (pair? mods) (null? (cdr mods)))
+        (append mods (list "main.ss"))
+        mods)))
+
+(define (split-mods path [more null])
+  (append (apply append (map split-mods more))
+          (regexp-split #rx"/" path)))
+
+(define (flatten-mods more path)
+  (path->string (apply build-path (append more (list path)))))
+
+;; expanded-mpi-sexpr->library : expanded-mpi-sexpr -> expanded-mpi-frame
+(define (expanded-mpi-sexpr->library sexpr0)
+  (define (abs? link)
+    (and (pair? link) (memq (car link) '(LIB PLANET))))
+  (define (loop stack stacks)
+    (cond [(pair? (cdr stack))
+           (cons (car stack) (loop (cdr stack) stacks))]
+          [(pair? stacks)
+           (unless (eq? 'REL (car (car stacks)))
+             (error 'expanded-mpi-sexpr->library
+                    "internal error: absolute frame"))
+           (loop (cadr (car stacks)) (cdr stacks))]
+          [else stack]))
+  (define sexpr1 (reverse (cut-to-absolute sexpr0)))
+  (and (library-expanded-mpi-frame? (car sexpr1))
+       `(,(car (car sexpr1))
+         ,(loop (cadr (car sexpr1)) (cdr sexpr1))
+         . ,(cddr (car sexpr1)))))
+
+;; cut-to-absolute : expanded-mpi-sexpr -> expanded-mpi-sexpr
+(define (cut-to-absolute sexpr)
+  (cond [(and (pair? sexpr)
+              (absolute-expanded-mpi-frame? (car sexpr)))
+         (list (car sexpr))]
+        [(pair? sexpr)
+         (cons (car sexpr) (cut-to-absolute (cdr sexpr)))]))
+
+;; absolute-expanded-mpi-frame? : expanded-mpi-frame -> boolean
+(define (absolute-expanded-mpi-frame? sexpr)
+  (not (memq (car sexpr) '(REL))))
+
+;; library-expanded-mpi-frame? : expanded-mpi-frame -> boolean
+(define (library-expanded-mpi-frame? sexpr)
+  (memq (car sexpr) '(LIB PLANET)))
+
+;; intersperse : X (listof X) -> (listof X)
+(define (intersperse sep items)
+  (cond [(and (pair? items) (pair? (cdr items)))
+         (cons (car items) (cons sep (intersperse sep (cdr items))))]
+        [else items]))
+
+
+
+#|
+(provide mpi->path-list
+         path-list->library-module)
+
+(define (mpi->path-list mpi)
+  (reverse-to-abs (mpi->mpi-sexpr mpi) null))
+
+(define (reverse-to-abs paths acc)
+  (match paths
+    ['() 
+     acc]
+    [#f
+     (cons (list 'SELF) acc)]
+    [(cons `(quote ,mod) rest)
+     (cons `(QUOTE ,mod) acc)]
+    [(cons `(lib ,path) rest)
+     (cond [(symbol? path)
+            (reverse-to-abs (cons path rest) acc)]
+           [(regexp-match? #rx"/" path)
+            (cons `(LIB ,(split-mods path)) acc)]
+           [else
+            (cons `(LIB ,(list "mzlib" path)) acc)])]
+    [(cons `(lib ,path . ,more) rest)
+     (cons `(LIB ,(split-mods path more)) acc)]
+    [(cons `(planet ,(? symbol? spec)) rest)
+     (reverse-to-abs (cons (parse-planet-spec spec) rest) acc)]
+    [(cons `(planet ,path ,package . ,more) rest)
+     (cons `(PLANET ,(split-mods path more) ,package) acc)]
+    [(cons (? symbol? mod) rest)
+     (cons `(LIB ,(split-mods* (symbol->string mod))) acc)]
+    [(cons `(file ,path) rest)
+     (cond [(absolute-path? path)
+            (cons `(FILE ,(split-mods path)) acc)]
+           [else (reverse-to-abs rest (cons (split-mods path) acc))])]
+    [(cons (? string? path) rest)
+     (reverse-to-abs rest (cons (split-mods path) acc))]))
+
+(provide parse-planet-spec)
+|#

collects/macro-debugger/view/hiding-panel.ss

@@ -13,6 +13,7 @@
 (define mode:standard "Standard")
 (define mode:custom "Custom ...")
 
+
 ;; macro-hiding-prefs-widget%
 (define macro-hiding-prefs-widget%
   (class object%
@@ -32,11 +33,12 @@
             [hide-contracts? (send box:hide-contracts get-value)]
             [hide-transformers? (send box:hide-phase1 get-value)]
             [specialized-policies (get-specialized-policies)])
-        (make-policy hide-mzscheme?
+        (policy->predicate
-                     hide-libs?
+         `(custom ,hide-mzscheme?
-                     hide-contracts?
+                  ,hide-libs?
-                     hide-transformers?
+                  ,hide-contracts?
-                     specialized-policies)))
+                  ,hide-transformers?
+                  ,specialized-policies))))
 
     (define super-panel
       (new vertical-panel%
@@ -162,12 +164,11 @@
     (define add-show-id-button
       (new button% (parent look-button-pane) (label "Show macro") (enabled #f)
            (callback (lambda _ (add-show-identifier) (refresh)))))
-    #;(new grow-box-spacer-pane% (parent right-pane))
+    ;;(new grow-box-spacer-pane% (parent right-pane))
 
     ;; Methods
 
     (define stx #f)
-    (define stx-name #f)
 
     ;; refresh : -> void
     (define/public (refresh)
@@ -181,60 +182,42 @@
     ;; set-syntax : syntax/#f -> void
     (define/public (set-syntax lstx)
       (set! stx (and (identifier? lstx) lstx))
-      (when (identifier? stx)
-        (let ([binding (identifier-binding stx)])
-          (if (pair? binding)
-              (set! stx-name (cadr binding))
-              (set! stx-name (syntax-e stx)))))
       (send add-show-id-button enable (identifier? lstx))
       (send add-hide-id-button enable (identifier? lstx)))
 
+    ;; A PolicyLine is an Entry
+    ;; Entry is defined in ../model/hiding-policies
+
+    ;; identifier-policies : (listof Entry)
     (define identifier-policies null)
 
+    ;; get-specialized-policies : -> (listof Entry)
     (define/private (get-specialized-policies)
-      (map (lambda (policy)
+      identifier-policies)
-             (define key (mcar policy))
-             (define show? (mcdr policy))
-             (cond [(pair? key)
-                    (lambda (id binding return)
-                      (when (and (pair? binding)
-                                 (equal? key (get-id-key/binding id binding)))
-                        (return show?)))]
-                   [else
-                    (lambda (id binding return)
-                      (when (free-identifier=? id key)
-                        (return show?)))]))
-           identifier-policies))
 
     (define/public (add-hide-identifier)
-      (add-identifier-policy #f)
+      (when (identifier? stx)
-      (ensure-custom-mode))
+        (add-policy-line 'hide-if `(free=? ,stx))))
 
     (define/public (add-show-identifier)
-      (add-identifier-policy #t)
+      (when (identifier? stx)
+        (add-policy-line 'show-if `(free=? ,stx))))
+
+    ;; add-policy-line : 'show-if/'hide-if Condition -> void
+    (define/private (add-policy-line action condition)
+      (set! identifier-policies
+            (cons `(,action ,condition)
+                  (remove-policy/condition condition identifier-policies)))
+      (update-list-view)
       (ensure-custom-mode))
 
-    (define/private (add-identifier-policy show?)
+    ;; update-list-view : -> void
-      (when (identifier? stx)
+    (define/private (update-list-view)
-        (let ([key (get-id-key stx)])
+      (send look-ctl set null)
-          (let loop ([i 0] [policies identifier-policies])
+      (for ([policy identifier-policies])
-            (cond [(null? policies)
+        (send look-ctl append (policy->string policy) policy)))
-                   (set! identifier-policies
-                         (cons (mcons key show?) identifier-policies))
-                   (send look-ctl append "")
-                   (update-list-view i key show?)]
-                  [(key=? key (mcar (car policies)))
-                   (set-mcdr! (car policies) show?)
-                   (update-list-view i key show?)]
-                  [else (loop (add1 i) (cdr policies))])))))
-
-    (define/private (update-list-view index key show?)
-      (send look-ctl set-data index key)
-      (send look-ctl set-string
-            index
-            (string-append (if show? "show " "hide ")
-                           (key->text key))))
 
+    ;; delete-selected : -> void
     (define/private (delete-selected)
       (define to-delete (sort (send look-ctl get-selections) <))
       (set! identifier-policies
@@ -245,11 +228,70 @@
                     [else
                      (cons (car policies)
                            (loop (add1 i) (cdr policies) to-delete))])))
-      (for-each (lambda (n) (send look-ctl delete n)) (reverse to-delete)))
+      (update-list-view))
 
     (super-new)
     (update-visibility)))
 
+
+(define (remove-policy/condition condition policies)
+  (filter (lambda (p) (not (same-condition? (cadr p) condition)))
+          policies))
+
+
+;; ----
+
+(define (policy->string policy)
+  (string-append 
+   (case (car policy)
+     ((show-if) "show ")
+     ((hide-if) "hide "))
+   (condition->string (cadr policy))))
+
+(define (condition->string condition)
+  (match condition
+    [`(free=? ,id)
+     (let ([b (identifier-binding id)])
+       (or #;(identifier->string id)
+           (cond [(list? b)
+                  (let ([mod (caddr b)]
+                        [name (cadddr b)])
+                    (format "'~s' from ~a" name (mpi->string mod)))]
+                 [else
+                  (symbol->string (syntax-e id))])))]
+    [_
+     "<condition>"]))
+
+#|
+(require scribble/xref
+         scribble/manual-struct
+         setup/xref)
+
+(define xref-p (delay (load-collections-xref)))
+
+(define (identifier->string id)
+  (define binding-info (identifier-binding id))
+  (define xref (force xref-p))
+  (define definition-tag
+    (and xref 
+         (xref-binding->definition-tag xref binding-info #f)))
+  (and definition-tag
+       (let-values ([(path tag) (xref-tag->path+anchor xref definition-tag)])
+         (define index-entry
+           (and path (xref-tag->index-entry xref definition-tag)))
+         (define desc
+           (and index-entry (entry-desc index-entry)))
+         (and desc
+              (let ([name (exported-index-desc-name desc)]
+                    [libs (exported-index-desc-from-libs desc)])
+                (format "'~a' from ~a"
+                        name
+                        (mpi->string (car libs))))))))
+|#
+
+
+
+#|
 (define (get-id-key id)
   id
   #; ;; FIXME
@@ -277,4 +319,4 @@
                    name
                    (mpi->string mod)))]
         [else (symbol->string (syntax-e key))]))
-
+|#