commit c4bf0cb2aa741f0fcc1997b827a8c293b2f23ad7
parent 81e6d8cb6785959ac742cdf229a1bf5b59983260
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Thu, 6 Nov 2008 17:10:44 +0000
macro stepper: changed hiding policy impl
svn: r12332
original commit: f78ce2c9f33c0d035092ba8085f6b6e4f8812683
Diffstat:
3 files changed, 678 insertions(+), 64 deletions(-)
diff --git 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
@@ -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
@@ -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))])))]
+ [_
+ "<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))]))
-
+|#
