From 2e3a0bcd0dc728f8e6b0f59f5b84ae1645d4a42c Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 20 May 2009 22:43:39 +0000 Subject: [PATCH] macro debugger: fixed hiding bug with non-collection modules improved #%top-interaction elimination Please apply changes for release. svn: r14887 --- .../macro-debugger/model/hiding-policies.ss | 88 ------------------- collects/macro-debugger/util/mpi.ss | 19 +++- collects/macro-debugger/view/stepper.ss | 9 +- collects/tests/macro-debugger/tests/policy.ss | 4 +- 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 index 7c5e36fe5d..51c1027b8a 100644 --- 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 index d9c89cc085..6f627aaf63 100644 --- 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 index 28138be6e5..b833438bff 100644 --- 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 index dec45f3169..d0585a36f2 100644 --- 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)