commit 9c8ec0d60355a9d33fb1494978446c518e45d466
parent 32abb27e21f78709d6b5dba6cab466e5ebf4373c
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 20 May 2009 22:43:39 +0000
macro debugger:
fixed hiding bug with non-collection modules
improved #%top-interaction elimination
Please apply changes for release.
svn: r14887
original commit: 2e3a0bcd0dc728f8e6b0f59f5b84ae1645d4a42c
Diffstat:
4 files changed, 25 insertions(+), 95 deletions(-)
diff --git a/collects/macro-debugger/model/hiding-policies.ss b/collects/macro-debugger/model/hiding-policies.ss
@@ -342,99 +342,11 @@
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?
- hide-libs?
- hide-contracts?
- hide-transformers?
- specialized-policies)
- (lambda (id)
- (define now (phase))
- (define binding
- (cond [(= now 0) (identifier-binding id)]
- [(= now 1) (identifier-transformer-binding id)]
- [else #f]))
- (define-values (def-mod def-name nom-mod nom-name)
- (if (pair? binding)
- (values (car binding)
- (cadr binding)
- (caddr binding)
- (cadddr binding))
- (values #f #f #f #f)))
- (let/ec return
- (let loop ([policies specialized-policies])
- (when (pair? policies)
- ((car policies) id binding return)
- (loop (cdr policies))))
- (cond [(and hide-mzscheme? def-mod (scheme-module? def-mod))
- #f]
- [(and hide-libs? def-mod (lib-module? def-mod))
- #f]
- [(and hide-contracts? def-name
- (regexp-match #rx"^provide/contract-id-"
- (symbol->string def-name)))
- #f]
- [(and hide-transformers? (positive? now))
- #f]
- [else #t]))))
-
-;; ----
-
-(define (scheme-module? mpi)
- (let ([abs (find-absolute-module-path mpi)])
- (and abs
- (or (base-module-path? abs)
- (scheme-lib-module-path? abs)))))
-
-(define (lib-module? mpi)
- (let ([abs (find-absolute-module-path mpi)])
- (and abs (lib-module-path? abs))))
-
-
-(define (find-absolute-module-path mpi)
- (and (module-path-index? mpi)
- (let-values ([(path rel) (module-path-index-split mpi)])
- (cond [(and (pair? path) (memq (car path) '(quote lib planet)))
- path]
- [(symbol? path) path]
- [(string? path) (find-absolute-module-path rel)]
- [else #f]))))
-
-(define (base-module-path? mp)
- (and (pair? mp)
- (eq? 'quote (car mp))
- (regexp-match #rx"^#%" (symbol->string (cadr mp)))))
-
-(define (scheme-lib-module-path? mp)
- (cond [(symbol? mp)
- (scheme-collection-name? (symbol->string mp))]
- [(and (pair? mp) (eq? (car mp) 'lib))
- (cond [(string? (cadr mp)) (null? (cddr mp))
- (scheme-collection-name? (cadr mp))]
- [(symbol? (cadr mp))
- (scheme-collection-name? (symbol->string (cadr mp)))]
- [else #f])]
- [else #f]))
-
-(define (scheme-collection-name? path)
- (or (regexp-match? #rx"^scheme/base(/.)?" path)
- (regexp-match? #rx"^mzscheme(/.)?" path)))
-
-(define (lib-module-path? mp)
- (or (symbol? mp)
- (and (pair? mp) (memq (car mp) '(lib planet)))))
-|#
diff --git a/collects/macro-debugger/util/mpi.ss b/collects/macro-debugger/util/mpi.ss
@@ -41,15 +41,26 @@
;; (list #f) ;; "self" module
;; null
+;; An rmp-sexpr is
+;; (list 'resolved path/symbol)
+
;; 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)))]
+ (cons (mp->mp-sexpr mod) (mpi->mpi-sexpr next)))]
[(resolved-module-path? mpi)
(list (rmp->rmp-sexpr mpi))]
[else null]))
+;; mp->mp-sexpr : mp -> mp-sexpr
+(define (mp->mp-sexpr mp)
+ (if (path? mp)
+ (if (absolute-path? mp)
+ `(file ,(path->string mp))
+ (path->string mp))
+ mp))
+
;; mpi-sexpr->mpi : mpi-sexpr -> mpi
(define (mpi-sexpr->mpi sexpr)
(match sexpr
@@ -124,7 +135,11 @@
[else
`(REL (split-mods path))])]
[(? string? path)
- `(REL ,(split-mods path))]))
+ `(REL ,(split-mods path))]
+ [`(resolved ,(? path? path))
+ `(FILE ,path)]
+ [`(resolved ,(? symbol? symbol))
+ `(QUOTE ,symbol)]))
;; expanded-mpi-sexpr->mpi-sexpr
(define (expanded-mpi-sexpr->mpi-sexpr sexpr)
diff --git a/collects/macro-debugger/view/stepper.ss b/collects/macro-debugger/view/stepper.ss
@@ -23,7 +23,8 @@
"../model/reductions.ss"
"../model/steps.ss"
"cursor.ss"
- "../util/notify.ss")
+ "../util/notify.ss"
+ (only-in mzscheme [#%top-interaction mz-top-interaction]))
(provide macro-stepper-widget%
macro-stepper-widget/process-mixin)
@@ -434,7 +435,8 @@
;; adjust-deriv/top : Derivation -> Derivation
(define/private (adjust-deriv/top deriv)
- (if (or (syntax-source (wderiv-e1 deriv))
+ (if (or (and #| (syntax-source (wderiv-e1 deriv)) |#
+ (syntax-original? (wderiv-e1 deriv)))
(p:module? deriv))
deriv
;; It's not original...
@@ -454,6 +456,7 @@
#f])))
(define/public (top-interaction-kw? x)
- (free-identifier=? x #'#%top-interaction))
+ (or (free-identifier=? x #'#%top-interaction)
+ (free-identifier=? x #'mz-top-interaction)))
))
diff --git a/collects/tests/macro-debugger/tests/policy.ss b/collects/tests/macro-debugger/tests/policy.ss
@@ -38,9 +38,9 @@
(test-base base:if #f)
;; Other Scheme/* forms
- (test-base scheme:match #t)
+ (test-base scheme:match #f)
(test-base scheme:unit #t)
- (test-base scheme:class #t)
+ (test-base scheme:class #f)
;; Unbound names
(test-base no-such-name #t)
