commit 8ba66aafd07e8c3e0bd2ee3a7c1c6d3d250d29a8
parent bbf9314bd8eae1ffb2c616c7ae4b5b41fda5dd1e
Author: Ryan Culpepper <ryanc@racket-lang.org>
Date: Wed, 14 Sep 2011 02:36:23 -0600
updated macro-debugger tests
original commit: 2111f136aa740c930f6ea5ea6bd9e5f85bb84363
Diffstat:
13 files changed, 89 insertions(+), 276 deletions(-)
diff --git a/collects/tests/macro-debugger/all-tests.rkt b/collects/tests/macro-debugger/all-tests.rkt
@@ -1,5 +1,7 @@
-#lang scheme/base
-(require rackunit
+#lang racket/base
+(require racket/cmdline
+ rackunit
+ rackunit/text-ui
macro-debugger/model/debug
"gentest-framework.rkt"
"gentests.rkt"
@@ -11,17 +13,9 @@
"tests/hiding.rkt"
"tests/regression.rkt"
"tests/policy.rkt"
- ;;"tests/collects.rkt"
- )
+ "tests/collects.rkt")
(provide all-tests)
-#|
-(require rackunit/gui)
-(define (go) (test/gui all-tests))
-(define (collects) (test/gui big-libs-tests))
-(provide go)
-|#
-
(define protos
(list proto:kernel-forms
proto:kernel-contexts
@@ -48,3 +42,28 @@
specialized-hiding-tests
regression-tests
policy-tests))
+
+(define-syntax-rule (with-namespace expr)
+ (parameterize ((current-namespace (make-base-namespace)))
+ expr))
+
+;; ----
+
+(define test-mode #f)
+(define collects-tests? #f)
+
+(command-line
+ #:once-each
+ [("--text") "Run tests in RackUnit text UI" (set! test-mode 'text)]
+ [("--gui") "Run tests in RackUnit GUI" (set! test-mode 'gui)]
+ [("--collects") "Include collects tests" (set! collects-tests? #t)]
+ #:args ()
+ (let* ([tests (cons all-tests (if collects-tests? (list collects-tests) null))])
+ (case test-mode
+ ((text)
+ (with-namespace
+ (for-each run-tests tests)))
+ ((gui)
+ (let ([test/gui (dynamic-require 'rackunit/gui 'test/gui)])
+ (with-namespace
+ (apply test/gui #:wait? #t tests)))))))
diff --git a/collects/tests/macro-debugger/gentest-framework.rkt b/collects/tests/macro-debugger/gentest-framework.rkt
@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
(provide (all-defined-out))
(define-struct collection (label contents) #:transparent)
diff --git a/collects/tests/macro-debugger/gentests.rkt b/collects/tests/macro-debugger/gentests.rkt
@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
(require rackunit)
(require macro-debugger/model/debug
macro-debugger/model/stx-util
diff --git a/collects/tests/macro-debugger/gui-tests.rkt b/collects/tests/macro-debugger/gui-tests.rkt
@@ -1,8 +1,8 @@
-#lang scheme/base
-(require scheme/class
- scheme/list
- scheme/gui/base
- framework/framework
+#lang racket/base
+(require racket/class
+ racket/list
+ racket/gui/base
+ framework
mzlib/etc)
(require macro-debugger/model/trace
diff --git a/collects/tests/macro-debugger/test-setup.rkt b/collects/tests/macro-debugger/test-setup.rkt
@@ -1,5 +1,4 @@
-
-#lang scheme/base
+#lang racket/base
(require macro-debugger/model/debug)
;; Testing facilities for macro debugger
diff --git a/collects/tests/macro-debugger/tests/collects.rkt b/collects/tests/macro-debugger/tests/collects.rkt
@@ -1,57 +1,26 @@
-#lang scheme/base
-(require rackunit)
-(require macro-debugger/model/debug
- scheme/path
- scheme/gui)
-(provide big-libs-tests
- loadlib
- loadfile
+#lang racket/base
+(require racket/list
+ racket/path
+ macro-debugger/model/debug
+ rackunit)
+(provide collects-tests
+ modules-for-test
trace-modules)
;; loadlib : module-path symbol -> Deriv
(define (loadlib mod)
- (let ([resolved ((current-module-name-resolver) mod #f #f #f)])
- (loadfile (resolved-module-path-name resolved))))
-
-;; loadfile : path symbol -> Deriv
-(define (loadfile path)
- (define-values (base file dir?) (split-path path))
- (define expect-module
- (string->symbol (path->string (path-replace-suffix file #""))))
- (define-values (eh mnr)
- (make-handlers (current-eval)
- (current-module-name-resolver)))
- #;(printf "Loading ~s\n" (path->string path))
- #;(printf "Expecting module named '~s'\n" expect-module)
- (parameterize ((current-load-relative-directory base)
- (current-directory base)
- (current-eval eh)
- (current-module-name-resolver mnr))
- (let-values ([(e-expr deriv)
- ((current-load) path expect-module)])
- (when (exn? e-expr)
- (raise e-expr))
- deriv)))
-
-(define (make-handlers original-eval-handler original-module-name-resolver)
- (values
- (lambda (expr)
- (unless (syntax? expr)
- (raise-type-error 'eval-handler "syntax" expr))
- (trace/result expr))
- (lambda args
- (parameterize ((current-eval original-eval-handler)
- (current-module-name-resolver original-module-name-resolver))
- (apply original-module-name-resolver args)))))
+ (trace-module mod))
(define (test-libs name mods)
(test-suite name
- (apply make-test-suite "Trace & Parse"
- (for/list ([m mods]) (test-lib/deriv m)))
- (apply make-test-suite "Reductions"
- (for/list ([m mods]) (test-lib/hide m hide-none-policy)))
- (apply make-test-suite "Standard hiding"
- (for/list ([m mods]) (test-lib/hide m standard-policy)))))
+ (test-suite "Trace & Parse"
+ (for ([m mods]) (test-lib/deriv m)))
+ #|
+ (test-suite "Reductions"
+ (for ([m mods]) (test-lib/hide m hide-none-policy)))
+ (test-suite "Standard hiding"
+ (for ([m mods]) (test-lib/hide m standard-policy)))
+ |#))
(define (test-lib/deriv m)
(test-case (format "~s" m)
@@ -70,9 +39,10 @@
(check-pred syntax? stx)
(check-eq? exn #f)
(check-true (list? steps) "Expected list for steps")
- (check-reduction-sequence steps))
+ #|(check-reduction-sequence steps)|#)
(define (check-reduction-sequence steps)
+ ;; FIXME: add remarkstep
(cond [(null? steps) (void)]
[(and (pair? steps) (step? (car steps)))
(check-reduction-sequence (cdr steps))]
@@ -80,6 +50,8 @@
(check-eq? (cdr steps) '() "Stuff after misstep")]
[else (fail "Bad reduction sequence")]))
+;; ----
+
(define (make-tracing-module-name-resolver omnr table)
(case-lambda
[(mod rel stx load?)
@@ -118,9 +90,9 @@
(make-tracing-module-name-resolver
(current-module-name-resolver)
table))
- (current-namespace (make-gui-namespace)))
+ (current-namespace (make-base-namespace)))
(for ([mod mods])
- (dynamic-require mod #f))
+ (dynamic-require mod (void)))
(let* ([loaded
(hash-map table (lambda (k v) k))]
[syms
@@ -134,192 +106,14 @@
(apply string-append
(for/list ([d (cddr l)]) (string-append d "/")))
(path->string (path-replace-suffix (cadr l) #"")))))])
- (sort (append syms conv-libs)
+ (sort (remove-duplicates (append syms conv-libs))
string<?
- #:key symbol->string
- #:cache-keys? #t))))
+ #:key symbol->string))))
+
+;; ----
-(define modules-from-framework (trace-modules '(framework)))
-(define modules-from-typed-scheme
- #;(trace-modules '(typed-scheme))
- '(#|
- mzlib/contract
- mzlib/etc
- mzlib/file
- mzlib/kw
- mzlib/list
- mzlib/match
- mzlib/class
- mzlib/cm-accomplice
- mzlib/contract
- mzlib/etc
- mzlib/kw
- mzlib/list
- mzlib/pconvert
- mzlib/pconvert-prop
- mzlib/plt-match
- mzlib/pretty
- mzlib/private/increader
- mzlib/private/unit-compiletime
- mzlib/private/unit-keywords
- mzlib/private/unit-runtime
- mzlib/private/unit-syntax
- mzlib/shared
- mzlib/string
- mzlib/struct
- mzlib/trace
- mzlib/unit
- mzlib/unit-exptime
- mzscheme
- mzlib/plt-match
- scheme/base
- scheme/class
- scheme/contract
- scheme/include
- scheme/list
- scheme/match
- scheme/match/compiler
- scheme/match/define-forms
- scheme/match/gen-match
- scheme/match/legacy-match
- scheme/match/match
- scheme/match/match-expander
- scheme/match/parse
- scheme/match/parse-helper
- scheme/match/parse-legacy
- scheme/match/parse-quasi
- scheme/match/patterns
- scheme/match/reorder
- scheme/match/split-rows
- scheme/mzscheme
- scheme/nest
- scheme/private/class-internal
- scheme/contract/private/base
- scheme/contract/private/arrow
- scheme/contract/private/basic-opters
- scheme/contract/private/ds
- scheme/contract/private/ds-helpers
- scheme/contract/private/exists
- scheme/contract/private/guts
- scheme/contract/private/helpers
- scheme/contract/private/misc
- scheme/contract/private/opt
- scheme/contract/private/opt-guts
- scheme/private/define-struct
- scheme/private/define-struct
- scheme/private/for
- scheme/private/kw
- scheme/private/letstx-scheme
- scheme/private/list
- scheme/private/misc
- scheme/private/modbeg
- scheme/private/more-scheme
- scheme/private/namespace
- scheme/private/old-procs
- scheme/private/pre-base
- scheme/private/qqstx
- scheme/private/reqprov
- scheme/private/struct-info
- scheme/private/stx
- scheme/private/stxcase
- scheme/private/stxcase-scheme
- scheme/private/stxloc
- scheme/private/stxparamkey
- scheme/private/with-stx
- scheme/promise
- scheme/provide-transform
- scheme/require-syntax
- scheme/require-transform
- scheme/struct-info
- scheme/struct-info
- scheme/stxparam
- scheme/unit
- scheme/unit-exptime
- scheme/unit/lang
- srfi/1
- srfi/1/alist
- srfi/1/cons
- srfi/1/delete
- srfi/1/filter
- srfi/1/fold
- srfi/1/list
- srfi/1/lset
- srfi/1/misc
- srfi/1/predicate
- srfi/1/search
- srfi/1/selector
- srfi/1/util
- srfi/optional
- srfi/provider
- mzlib/struct
- syntax/boundmap
- syntax/boundmap
- syntax/context
- syntax/free-vars
- syntax/kerncase
- syntax/kerncase
- syntax/name
- syntax/path-spec
- syntax/private/boundmap
- syntax/struct
- syntax/struct
- syntax/stx
- syntax/stx
- mzlib/trace
- |#
- typed-scheme
- typed-scheme/minimal
- typed-scheme/private/base-env
- typed-scheme/private/base-types
- typed-scheme/private/check-subforms-unit
- typed-scheme/private/def-binding
- typed-scheme/private/effect-rep
- typed-scheme/private/extra-procs
- typed-scheme/private/free-variance
- typed-scheme/private/infer
- typed-scheme/private/infer-ops
- typed-scheme/private/init-envs
- typed-scheme/private/internal-forms
- typed-scheme/private/interning
- typed-scheme/private/lexical-env
- typed-scheme/private/mutated-vars
- typed-scheme/private/parse-type
- typed-scheme/private/planet-requires
- typed-scheme/private/prims
- typed-scheme/private/provide-handling
- typed-scheme/private/remove-intersect
- typed-scheme/private/rep-utils
- typed-scheme/private/require-contract
- typed-scheme/private/resolve-type
- typed-scheme/private/signatures
- typed-scheme/private/subtype
- typed-scheme/private/syntax-traversal
- typed-scheme/private/tables
- typed-scheme/private/tc-app-unit
- typed-scheme/private/tc-expr-unit
- typed-scheme/private/tc-if-unit
- typed-scheme/private/tc-lambda-unit
- typed-scheme/private/tc-let-unit
- typed-scheme/private/tc-structs
- typed-scheme/private/tc-toplevel
- typed-scheme/private/tc-utils
- typed-scheme/private/type-alias-env
- typed-scheme/private/type-annotation
- typed-scheme/private/type-comparison
- typed-scheme/private/type-contract
- typed-scheme/private/type-effect-convenience
- typed-scheme/private/type-effect-printer
- typed-scheme/private/type-env
- typed-scheme/private/type-environments
- typed-scheme/private/type-name-env
- typed-scheme/private/type-rep
- typed-scheme/private/type-utils
- typed-scheme/private/typechecker
- typed-scheme/private/unify
- typed-scheme/private/union
- typed-scheme/private/unit-utils
- typed-scheme/private/utils
- typed-scheme/typed-scheme))
+(define modules-for-test
+ (trace-modules '(racket/main typed/racket framework)))
-(define big-libs-tests
- (test-libs "Collections" modules-from-typed-scheme))
+(define collects-tests
+ (test-libs "Trace collections" modules-for-test))
diff --git a/collects/tests/macro-debugger/tests/hiding.rkt b/collects/tests/macro-debugger/tests/hiding.rkt
@@ -1,6 +1,6 @@
-#lang scheme/base
-(require rackunit)
-(require macro-debugger/model/debug
+#lang racket/base
+(require rackunit
+ macro-debugger/model/debug
"../test-setup.rkt")
(provide specialized-hiding-tests)
@@ -160,8 +160,11 @@
(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))
+ #|
+ FIXME
(test-T-hiding (lambda (x) (id (define-values (y) (Tid x))) y)
- (lambda (x) (id (define-values (y) x)) y)))
+ (lambda (x) (id (define-values (y) x)) y))
+ |#)
(test-suite "Binding expressions"
(test-T-hiding/id (lambda (x) x))
(test-T-hiding/id (lambda (x) (id x))))
diff --git a/collects/tests/macro-debugger/tests/policy.rkt b/collects/tests/macro-debugger/tests/policy.rkt
@@ -1,13 +1,13 @@
-#lang scheme/base
-(require rackunit)
-(require macro-debugger/model/debug
+#lang racket/base
+(require rackunit
+ macro-debugger/model/debug
"../test-setup.rkt")
(provide policy-tests)
(define ns (make-base-namespace))
(eval '(require (prefix-in k: '#%kernel)) ns)
-(eval '(require (prefix-in base: scheme/base)) ns)
-(eval '(require (prefix-in scheme: scheme)) ns)
+(eval '(require (prefix-in base: racket/base)) ns)
+(eval '(require (prefix-in scheme: racket)) ns)
(define (make-test-id sym)
(parameterize ((current-namespace ns))
@@ -30,13 +30,13 @@
(test-base k:lambda #f)
(test-base k:if #f)
- ;; Scheme/base forms
+ ;; racket/base forms
(test-base base:define #f)
(test-base base:lambda #f)
(test-base base:#%app #f)
(test-base base:if #f)
- ;; Other Scheme/* forms
+ ;; Other racket/* forms
(test-base scheme:match #f)
(test-base scheme:unit #t)
(test-base scheme:class #f)
@@ -50,13 +50,13 @@
(test-standard k:lambda #f)
(test-standard k:if #f)
- ;; Scheme/base forms
+ ;; racket/base forms
(test-standard base:define #f)
(test-standard base:lambda #f)
(test-standard base:#%app #f)
(test-standard base:if #f)
- ;; Other Scheme/* forms
+ ;; Other racket/* forms
(test-standard scheme:match #f)
(test-standard scheme:unit #f)
(test-standard scheme:class #f)
diff --git a/collects/tests/macro-debugger/tests/regression.rkt b/collects/tests/macro-debugger/tests/regression.rkt
@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
(require rackunit)
(require macro-debugger/model/debug
macro-debugger/model/steps
@@ -129,8 +129,6 @@
(define (g y) c)
(define h c)
(add1 (g 2))))))])
- (printf "not a step:\n~s\n"
- (for/or ([s rs]) (and (not (step? s)) s)))
(check-pred list? rs)
(for ([x (in-list rs)])
(check-true (not (misstep? x)))))))
diff --git a/collects/tests/macro-debugger/tests/syntax-basic.rkt b/collects/tests/macro-debugger/tests/syntax-basic.rkt
@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
(require "../gentest-framework.rkt")
(provide proto:kernel-forms
proto:kernel-contexts)
diff --git a/collects/tests/macro-debugger/tests/syntax-errors.rkt b/collects/tests/macro-debugger/tests/syntax-errors.rkt
@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
(require "../gentest-framework.rkt")
(provide proto:errors)
diff --git a/collects/tests/macro-debugger/tests/syntax-macros.rkt b/collects/tests/macro-debugger/tests/syntax-macros.rkt
@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
(require "../gentest-framework.rkt")
(provide proto:macros)
diff --git a/collects/tests/macro-debugger/tests/syntax-modules.rkt b/collects/tests/macro-debugger/tests/syntax-modules.rkt
@@ -1,4 +1,4 @@
-#lang scheme/base
+#lang racket/base
(require "../gentest-framework.rkt")
(provide proto:modules)
