diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss index f5a2f2acf0..0933b07056 100644 --- a/collects/macro-debugger/model/hiding-policies.ss +++ b/collects/macro-debugger/model/hiding-policies.ss @@ -3,13 +3,358 @@ (require (for-syntax scheme/base) scheme/match syntax/boundmap - "reductions-config.ss") -(provide make-policy - standard-policy + "reductions-config.ss" + "../util/mpi.ss") +(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))))) +|# \ No newline at end of file diff --git a/collects/macro-debugger/util/mpi.ss b/collects/macro-debugger/util/mpi.ss index 240bc53bff..d9c89cc085 100644 --- a/collects/macro-debugger/util/mpi.ss +++ b/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) +|# diff --git a/collects/macro-debugger/view/hiding-panel.ss b/collects/macro-debugger/view/hiding-panel.ss index 002b7c192e..def418938e 100644 --- a/collects/macro-debugger/view/hiding-panel.ss +++ b/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? - hide-libs? - hide-contracts? - hide-transformers? - specialized-policies))) + (policy->predicate + `(custom ,hide-mzscheme? + ,hide-libs? + ,hide-contracts? + ,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) - (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)) + identifier-policies) (define/public (add-hide-identifier) - (add-identifier-policy #f) - (ensure-custom-mode)) + (when (identifier? stx) + (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?) - (when (identifier? stx) - (let ([key (get-id-key stx)]) - (let loop ([i 0] [policies identifier-policies]) - (cond [(null? policies) - (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)))) + ;; update-list-view : -> void + (define/private (update-list-view) + (send look-ctl set null) + (for ([policy identifier-policies]) + (send look-ctl append (policy->string policy) policy))) + ;; 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))])))] + [_ + ""])) + +#| +(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))])) - +|#