commit 57f69f722c4186e7187de37362c6e26be32981ca
parent c199055ac7f9637ff66855c0f87bd641d2a70078
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Fri, 13 Mar 2009 05:54:17 +0000
macro stepper:
better module hiding
display prefab structs
updated tests
svn: r14085
original commit: e11a24fda8c9c00a62be3fc92df83d36b6ac1b90
Diffstat:
7 files changed, 184 insertions(+), 143 deletions(-)
diff --git a/collects/macro-debugger/model/reductions.ss b/collects/macro-debugger/model/reductions.ss
@@ -3,7 +3,6 @@
(require scheme/match
"stx-util.ss"
"deriv-util.ss"
- "context.ss"
"deriv.ss"
"reductions-engine.ss")
@@ -61,7 +60,7 @@
[#:when (not (bound-identifier=? e1 e2))
[#:walk e2 'resolve-variable]])]
[(Wrap p:module (e1 e2 rs ?1 ?2 tag rename check tag2 ?3 body shift))
- (R ;; [#:hide-check rs] ;; FIXME: test and enable!!!
+ (R [#:hide-check rs]
[! ?1]
[#:pattern (?module ?name ?language . ?body-parts)]
[! ?2]
diff --git a/collects/macro-debugger/syntax-browser/pretty-helper.ss b/collects/macro-debugger/syntax-browser/pretty-helper.ss
@@ -89,6 +89,13 @@
lp-datum)]
[(pair? obj)
(pairloop obj)]
+ [(struct? obj)
+ ;; Only traverse prefab structs
+ (let ([pkey (prefab-struct-key obj)])
+ (if pkey
+ (let-values ([(refold fields) (unfold-pstruct obj)])
+ (refold (map loop fields)))
+ obj))]
[(symbol? obj)
(unintern obj)]
[(null? obj)
@@ -117,6 +124,14 @@
flat=>stx
stx=>flat))))
+;; unfold-pstruct : prefab-struct -> (values (list -> prefab-struct) list)
+(define (unfold-pstruct obj)
+ (define key (prefab-struct-key obj))
+ (define fields (cdr (vector->list (struct->vector obj))))
+ (values (lambda (new-fields)
+ (apply make-prefab-struct key new-fields))
+ fields))
+
;; check+convert-special-expression : syntax -> #f/syntaxish
(define (check+convert-special-expression stx)
(define stx-list (stx->list stx))
diff --git a/collects/macro-debugger/syntax-browser/pretty-printer.ss b/collects/macro-debugger/syntax-browser/pretty-printer.ss
@@ -56,7 +56,7 @@
;; Printing parameters (mzscheme manual 7.9.1.4)
[print-unreadable #t]
[print-graph #f]
- [print-struct #f]
+ [print-struct #t]
[print-box #t]
[print-vector-length #t]
[print-hash-table #f]
diff --git a/collects/tests/macro-debugger/gentests.ss b/collects/tests/macro-debugger/gentests.ss
@@ -57,7 +57,7 @@
[expect-ok? (cdr key+expect-ok?)])
(check-hide d hide-none-policy expect-ok?)
(check-hide d hide-all-policy expect-ok?)
- (check-hide d simple-policy expect-ok?))))]
+ (check-hide d T-policy expect-ok?))))]
[else #f]))
(define (check-hide d policy expect-ok?)
@@ -86,14 +86,14 @@
(error 'checker-for-hidden-steps "no steps given for ~s" label))
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
- [rs (parameterize ((macro-policy simple-policy))
+ [rs (parameterize ((macro-policy T-policy))
(reductions d))])
(check-steps (cdr (assq '#:steps attrs)) rs)))]
[(assq '#:hidden-steps attrs)
=> (lambda (key+expected)
(test-case label
(let* ([d (trace/ns form (assq '#:kernel attrs))]
- [rs (parameterize ((macro-policy simple-policy))
+ [rs (parameterize ((macro-policy T-policy))
(reductions d))])
(check-steps (cdr (assq '#:hidden-steps attrs)) rs))))]
[else #f]))
diff --git a/collects/tests/macro-debugger/test-setup.ss b/collects/tests/macro-debugger/test-setup.ss
@@ -8,12 +8,15 @@
trace/k
hide-all-policy
hide-none-policy
- simple-policy
+
+ T-policy
+ Tm-policy
stx/hide-none
stx/hide-all
stx/hide-standard
- stx/hide-simple)
+ stx/hide-T
+ stx/hide-Tm)
(define (trace/t expr)
(trace/ns expr #f))
@@ -133,22 +136,25 @@
(stx/hide-policy d hide-none-policy))
(define (stx/hide-all d)
(stx/hide-policy d hide-all-policy))
-(define (stx/hide-simple d)
- (stx/hide-policy d simple-policy))
(define (stx/hide-standard d)
(stx/hide-policy d standard-policy))
-#|
-(define (hide/standard d) (hide/policy d standard-policy))
-(define (hide/all d) (hide/policy d hide-all-policy))
-(define (hide/null d) (hide/policy d hide-none-policy))
-(define (hide/except d syms)
- (hide/policy d (lambda (id) (memq (syntax-e id) syms))))
-(define (hide/simple d) (hide/policy d simple-policy))
-|#
-
-;; Simple hiding policy
-;; ALL MACROS & primitive tags are hidden
-;; EXCEPT Tlist and Tlet (and #%module-begin)
-(define (simple-policy id)
+
+(define (stx/hide-T d)
+ (stx/hide-policy d T-policy))
+(define (stx/hide-Tm d)
+ (stx/hide-policy d Tm-policy))
+
+;; T hiding policy
+;; ALL macros & primitives are hidden
+;; EXCEPT those starting with T (Tlist and Tlet)
+(define (T-policy id)
(or (memq (syntax-e id) '())
(regexp-match #rx"^T" (symbol->string (syntax-e id)))))
+
+;; Tm hiding policy
+;; ALL MACROS & primitive tags are hidden
+;; EXCEPT those starting with T (Tlist and Tlet)
+;; EXCEPT module (=> #%module-begin gets tagged)
+(define (Tm-policy id)
+ (or (memq (syntax-e id) '(module))
+ (regexp-match #rx"^T" (symbol->string (syntax-e id)))))
diff --git a/collects/tests/macro-debugger/tests/hiding.ss b/collects/tests/macro-debugger/tests/hiding.ss
@@ -1,7 +1,6 @@
#lang scheme/base
(require (planet "test.ss" ("schematics" "schemeunit.plt" 2 8))
- (planet "graphical-ui.ss" ("schematics" "schemeunit.plt" 2 8))
macro-debugger/model/debug
"../test-setup.ss")
(provide specialized-hiding-tests)
@@ -27,16 +26,19 @@
[(tthi form)
(test-trivial-hiding form form)]))
-(define-syntax test-simple-hiding
- (syntax-rules ()
- [(tsh form hidden-e2)
- (test-hiding/policy form hidden-e2 simple-policy)]))
-(define-syntax test-simple-hiding/id
- (syntax-rules ()
- [(tshi form) (test-simple-hiding form form)]))
+(define-syntax-rule (test-T-hiding form hidden-e2)
+ (test-hiding/policy form hidden-e2 T-policy))
+(define-syntax-rule (test-T-hiding/id form)
+ (test-T-hiding form form))
+
+(define-syntax-rule (test-Tm-hiding form hidden-e2)
+ (test-hiding/policy form hidden-e2 Tm-policy))
+(define-syntax-rule (test-Tm-hiding/id form)
+ (test-Tm-hiding form form))
(define specialized-hiding-tests
(test-suite "Specialized macro hiding tests"
+
(test-suite "Result tests for trivial hiding"
(test-suite "Atomic expressions"
(test-trivial-hiding/id *)
@@ -74,7 +76,7 @@
(lambda (x y) x y))
(test-trivial-hiding (lambda (x) (define-values (y) (id x)) y)
(lambda (x) (letrec-values ([(y) x]) y))))
- #;
+ #|
;; Old hiding mechanism never did letrec transformation (unless forced)
(test-suite "Block normalization"
(test-trivial-hiding/id (lambda (x y) x y))
@@ -88,94 +90,119 @@
(test-trivial-hiding (lambda (x) (id (begin (define-values (y) x) x)))
(lambda (x) (begin (define-values (y) x) x)))
(test-trivial-hiding (lambda (x) (define-values (y) (id x)) y)
- (lambda (x) (define-values (y) x) y))))
- (test-suite "Result tests for simple hiding"
+ (lambda (x) (define-values (y) x) y)))
+ |#
+ )
+
+ (test-suite "Result tests for T hiding"
(test-suite "Atomic expressions"
- (test-simple-hiding/id *)
- (test-simple-hiding/id 1)
- (test-simple-hiding/id unbound-var))
+ (test-T-hiding/id *)
+ (test-T-hiding/id 1)
+ (test-T-hiding/id unbound-var))
(test-suite "Basic expressions"
- (test-simple-hiding/id (if 1 2 3))
- (test-simple-hiding/id (with-continuation-mark 1 2 3))
- (test-simple-hiding/id (define-values (x) 1))
- (test-simple-hiding/id (define-syntaxes (x) 1)))
+ (test-T-hiding/id (if 1 2 3))
+ (test-T-hiding/id (with-continuation-mark 1 2 3))
+ (test-T-hiding/id (define-values (x) 1))
+ (test-T-hiding/id (define-syntaxes (x) 1)))
(test-suite "Opaque macros"
- (test-simple-hiding/id (id '1))
- (test-simple-hiding/id (id 1))
- (test-simple-hiding/id (id (id '1)))
+ (test-T-hiding/id (id '1))
+ (test-T-hiding/id (id 1))
+ (test-T-hiding/id (id (id '1)))
;; app is hidden:
- (test-simple-hiding/id (+ '1 '2)))
+ (test-T-hiding/id (+ '1 '2)))
(test-suite "Transparent macros"
- (test-simple-hiding (Tlist x)
- (list x))
- (test-simple-hiding (Tid x) x)
- (test-simple-hiding (Tlist (id x))
- (list (id x)))
- (test-simple-hiding (Tid (id x))
- (id x))
- (test-simple-hiding (id (Tlist x))
- (id (list x)))
- (test-simple-hiding (id (Tid x))
- (id x)))
+ (test-T-hiding (Tlist x)
+ (list x))
+ (test-T-hiding (Tid x) x)
+ (test-T-hiding (Tlist (id x))
+ (list (id x)))
+ (test-T-hiding (Tid (id x))
+ (id x))
+ (test-T-hiding (id (Tlist x))
+ (id (list x)))
+ (test-T-hiding (id (Tid x))
+ (id x)))
(test-suite "Blocks"
- (test-simple-hiding/id (lambda (x y) x y))
- (test-simple-hiding (lambda (x y z) (begin x y) z)
- (lambda (x y z) x y z))
- (test-simple-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin!
- (test-simple-hiding (lambda (x) (define-values (y) x) y)
- (lambda (x) (letrec-values ([(y) x]) y)))
- (test-simple-hiding (lambda (x) (begin (define-values (y) x)) y)
- (lambda (x) (letrec-values ([(y) x]) y)))
- (test-simple-hiding (lambda (x) (begin (define-values (y) x) y) x)
- (lambda (x) (letrec-values ([(y) x]) y x)))
- (test-simple-hiding (lambda (x) (id x))
- (lambda (x) (id x)))
- (test-simple-hiding (lambda (x) (Tid x))
- (lambda (x) x))
- (test-simple-hiding/id (lambda (x) (id (define-values (y) x)) x))
- (test-simple-hiding (lambda (x) (id (define-values (y) x)) (Tid x))
- (lambda (x) (id (define-values (y) x)) x))
- (test-simple-hiding/id (lambda (x) (id (begin (define-values (y) x) x))))
- (test-simple-hiding (lambda (x) (begin (id (define-values (y) x)) y))
- (lambda (x) (id (define-values (y) x)) y))
- (test-simple-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y))
- (lambda (x) (id (begin (define-values (y) x))) y))
- (test-simple-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y))
- (lambda (x) (id (begin (define-values (y) x))) x y))
- (test-simple-hiding (lambda (x) (define-values (y) (id x)) y)
- (lambda (x) (letrec-values ([(y) (id x)]) y)))
- (test-simple-hiding (lambda (x y) x (id y))
- (lambda (x y) x (id y)))
- (test-simple-hiding (lambda (x y) x (Tid y))
- (lambda (x y) x y))
- (test-simple-hiding (lambda (x) (id (define-values (y) x)) x (Tid y))
- (lambda (x) (id (define-values (y) x)) x y))
- (test-simple-hiding/id (lambda (x) (id (define-values (y) (id x))) y))
- (test-simple-hiding (lambda (x) (id (define-values (y) (Tid x))) y)
- (lambda (x) (id (define-values (y) x)) y)))
+ (test-T-hiding/id (lambda (x y) x y))
+ (test-T-hiding (lambda (x y z) (begin x y) z)
+ (lambda (x y z) x y z))
+ (test-T-hiding/id (lambda (x y z) x (begin y z))) ;; expression begin!
+ (test-T-hiding (lambda (x) (define-values (y) x) y)
+ (lambda (x) (letrec-values ([(y) x]) y)))
+ (test-T-hiding (lambda (x) (begin (define-values (y) x)) y)
+ (lambda (x) (letrec-values ([(y) x]) y)))
+ (test-T-hiding (lambda (x) (begin (define-values (y) x) y) x)
+ (lambda (x) (letrec-values ([(y) x]) y x)))
+ (test-T-hiding (lambda (x) (id x))
+ (lambda (x) (id x)))
+ (test-T-hiding (lambda (x) (Tid x))
+ (lambda (x) x))
+ (test-T-hiding/id (lambda (x) (id (define-values (y) x)) x))
+ (test-T-hiding (lambda (x) (id (define-values (y) x)) (Tid x))
+ (lambda (x) (id (define-values (y) x)) x))
+ (test-T-hiding/id (lambda (x) (id (begin (define-values (y) x) x))))
+ (test-T-hiding (lambda (x) (begin (id (define-values (y) x)) y))
+ (lambda (x) (id (define-values (y) x)) y))
+ (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) (Tid y))
+ (lambda (x) (id (begin (define-values (y) x))) y))
+ (test-T-hiding (lambda (x) (id (begin (Tid (define-values (y) x)))) x (Tid y))
+ (lambda (x) (id (begin (define-values (y) x))) x y))
+ (test-T-hiding (lambda (x) (define-values (y) (id x)) y)
+ (lambda (x) (letrec-values ([(y) (id x)]) y)))
+ (test-T-hiding (lambda (x y) x (id y))
+ (lambda (x y) x (id y)))
+ (test-T-hiding (lambda (x y) x (Tid y))
+ (lambda (x y) x y))
+ (test-T-hiding (lambda (x) (id (define-values (y) x)) x (Tid y))
+ (lambda (x) (id (define-values (y) x)) x y))
+ (test-T-hiding/id (lambda (x) (id (define-values (y) (id x))) y))
+ (test-T-hiding (lambda (x) (id (define-values (y) (Tid x))) y)
+ (lambda (x) (id (define-values (y) x)) y)))
(test-suite "Binding expressions"
- (test-simple-hiding/id (lambda (x) x))
- (test-simple-hiding/id (lambda (x) (id x))))
+ (test-T-hiding/id (lambda (x) x))
+ (test-T-hiding/id (lambda (x) (id x))))
(test-suite "Module declarations"
- (test-simple-hiding (module m mzscheme
- (require 'helper)
- (define x 1))
- (module m mzscheme
- (#%module-begin
- (require 'helper)
- (define x 1))))
- (test-simple-hiding (module m mzscheme
- (require 'helper)
- (define x (Tlist 1)))
- (module m mzscheme
- (#%module-begin
- (require 'helper)
- (define x (list 1)))))
- (test-simple-hiding (module m mzscheme
- (#%plain-module-begin
- (require 'helper)
- (define x (Tlist 1))))
- (module m mzscheme
- (#%plain-module-begin
- (require 'helper)
- (define x (list 1)))))))))
+ (test-T-hiding (module m mzscheme
+ (require 'helper)
+ (define x 1))
+ (module m mzscheme
+ (require 'helper)
+ (define x 1)))
+ (test-Tm-hiding (module m mzscheme
+ (require 'helper)
+ (define x 1))
+ (module m mzscheme
+ (#%module-begin
+ (require 'helper)
+ (define x 1))))
+
+ (test-T-hiding (module m mzscheme
+ (require 'helper)
+ (define x (Tlist 1)))
+ (module m mzscheme
+ (require 'helper)
+ (define x (list 1))))
+ (test-Tm-hiding (module m mzscheme
+ (require 'helper)
+ (define x (Tlist 1)))
+ (module m mzscheme
+ (#%module-begin
+ (require 'helper)
+ (define x (list 1)))))
+
+ (test-T-hiding (module m mzscheme
+ (#%plain-module-begin
+ (require 'helper)
+ (define x (Tlist 1))))
+ (module m mzscheme
+ (#%plain-module-begin
+ (require 'helper)
+ (define x (list 1)))))
+ (test-Tm-hiding (module m mzscheme
+ (#%plain-module-begin
+ (require 'helper)
+ (define x (Tlist 1))))
+ (module m mzscheme
+ (#%plain-module-begin
+ (require 'helper)
+ (define x (list 1)))))))))
diff --git a/collects/tests/macro-debugger/tests/syntax-modules.ss b/collects/tests/macro-debugger/tests/syntax-modules.ss
@@ -18,7 +18,7 @@
[#:steps
(tag-module-begin
(module m '#%kernel (#%module-begin (define-values (x) 'a))))]
- #:same-hidden-steps)
+ #:no-hidden-steps)
(test "module, MB, def, use"
(module m '#%kernel (#%module-begin (define-values (x) 'a) x))
#:no-steps
@@ -28,7 +28,7 @@
[#:steps
(tag-module-begin
(module m '#%kernel (#%module-begin (define-values (x) 'a) x)))]
- #:same-hidden-steps)
+ #:no-hidden-steps)
(test "module, MB, quote"
(module m '#%kernel (#%module-begin 'a))
#:no-steps
@@ -37,12 +37,12 @@
(module m '#%kernel 'a)
[#:steps
(tag-module-begin (module m '#%kernel (#%module-begin 'a)))]
- #:same-hidden-steps)
+ #:no-hidden-steps)
(test "module, 2 quotes"
(module m '#%kernel 'a 'b)
[#:steps
(tag-module-begin (module m '#%kernel (#%module-begin 'a 'b)))]
- #:same-hidden-steps)
+ #:no-hidden-steps)
(test "module, MB, begin"
(module m '#%kernel (#%module-begin (begin 'a 'b)))
[#:steps
@@ -53,7 +53,7 @@
[#:steps
(tag-module-begin (module m '#%kernel (#%module-begin (begin 'a 'b))))
(splice-module (module m '#%kernel (#%module-begin 'a 'b)))]
- #:same-hidden-steps)
+ #:no-hidden-steps)
(test "module, MB, def in begin"
(module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x)))
[#:steps
@@ -67,7 +67,7 @@
(module m '#%kernel (#%module-begin (begin (define-values (x) 'a) x))))
(splice-module
(module m '#%kernel (#%module-begin (define-values (x) 'a) x)))]
- #:same-hidden-steps)
+ #:no-hidden-steps)
(test "module, MB, defstx, use"
(module m '#%kernel
@@ -106,7 +106,11 @@
(#%module-begin
(#%require 'helper)
'a)))]
- #:same-hidden-steps)
+ [#:hidden-steps
+ (macro
+ (module m '#%kernel
+ (#%require 'helper)
+ 'a))])
(test "module k+helper, defs and opaque macros"
(module m '#%kernel
@@ -196,14 +200,12 @@
(tag-module-begin
(module m mzscheme (#%module-begin (define-values (x) 'a) x)))
(macro
- (module m mzscheme
- (#%plain-module-begin
- (#%require (for-syntax scheme/mzscheme))
- (define-values (x) 'a)
- x)))]
- [#:hidden-steps
- (tag-module-begin
- (module m mzscheme (#%module-begin (define-values (x) 'a) x)))])
+ (module m mzscheme
+ (#%plain-module-begin
+ (#%require (for-syntax scheme/mzscheme))
+ (define-values (x) 'a)
+ x)))]
+ #:no-hidden-steps)
(test "module mz, def"
(module m mzscheme (define-values (x) 'a))
[#:steps
@@ -214,9 +216,7 @@
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
(define-values (x) 'a))))]
- [#:hidden-steps
- (tag-module-begin
- (module m mzscheme (#%module-begin (define-values (x) 'a))))])
+ #:no-hidden-steps)
(test "module mz, quote"
(module m mzscheme 'a)
[#:steps
@@ -227,10 +227,8 @@
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
'a)))]
- [#:hidden-steps
- (tag-module-begin
- (module m mzscheme (#%module-begin 'a)))])
-
+ #:no-hidden-steps)
+
(test "module mz, begin with 2 quotes"
(module m mzscheme (begin 'a 'b))
[#:steps
@@ -246,9 +244,7 @@
(#%plain-module-begin
(#%require (for-syntax scheme/mzscheme))
'a 'b)))]
- [#:hidden-steps
- (tag-module-begin
- (module m mzscheme (#%module-begin (begin 'a 'b))))])
+ #:no-hidden-steps)
(test "module mz, macro use, quote"
(module m mzscheme (or 'a 'b) 'c)
@@ -289,9 +285,7 @@
(let-values ([(or-part) 'a])
(if or-part or-part 'b))
'c)))]
- [#:hidden-steps
- (tag-module-begin
- (module m mzscheme (#%module-begin (or 'a 'b) 'c)))])
+ #:no-hidden-steps)
(test "module mz, macro use"
(module m mzscheme (or 'a 'b))
