macro debugger:

fixed hiding bug with non-collection modules
  improved #%top-interaction elimination
Please apply changes for release.

svn: r14887

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)))))
-|#

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)

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)))
 
     ))

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)