From 1ef38458733b0a964ad699ad99ee2ba172cfec2a Mon Sep 17 00:00:00 2001 From: Ryan Culpepper Date: Wed, 13 Feb 2013 15:33:36 -0500 Subject: [PATCH] added unstable/macro-testing --- collects/unstable/macro-testing.rkt | 80 +++++++++++++++++++ .../unstable/scribblings/macro-testing.scrbl | 74 +++++++++++++++++ collects/unstable/scribblings/unstable.scrbl | 1 + 3 files changed, 155 insertions(+) create mode 100644 collects/unstable/macro-testing.rkt create mode 100644 collects/unstable/scribblings/macro-testing.scrbl diff --git a/collects/unstable/macro-testing.rkt b/collects/unstable/macro-testing.rkt new file mode 100644 index 0000000000..8215b3581e --- /dev/null +++ b/collects/unstable/macro-testing.rkt @@ -0,0 +1,80 @@ +#lang racket/base +(require (for-syntax racket/base + racket/syntax + syntax/keyword)) +(provide phase1-eval + convert-syntax-error + convert-compile-time-error) + +(begin-for-syntax + (define (exn->raise-syntax e) + (cond #| + ;; Preserving exn:fail:syntax causes the "unsealed local-definition context found + ;; in fully expanded form" error in some tests. + [(exn:fail:syntax? e) + #`(raise (make-exn:fail:syntax + #,(exn-message e) + (current-continuation-marks) + #,(with-syntax ([(expr ...) (exn:fail:syntax-exprs e)]) + #'(list (quote-syntax expr) ...))))] + |# + [(exn? e) + (with-syntax ([make-exn + (cond [(exn:fail? e) #'make-exn:fail] + [else #'make-exn])]) + #`(raise (make-exn #,(exn-message e) + (current-continuation-marks))))] + [else + #`(raise (make-exn #,(format "non-exception value raised: ~e" e) + (current-continuation-marks)))]))) + +(define-syntax (phase1-eval stx) + (if (eq? (syntax-local-context) 'expression) + (syntax-case stx () + [(phase1-eval ct-expr . options) + (let () + (define opts (parse-keyword-options/eol + #'options + `((#:quote ,check-identifier) + (#:catch? ,check-stx-boolean)) + #:no-duplicates? #t + #:context stx)) + (define quote-form (options-select-value opts '#:quote #:default #'quote)) + (define catch? (options-select-value opts '#:catch? #:default #t)) + (with-handlers ([(lambda (e) catch?) exn->raise-syntax]) + (with-syntax ([quote quote-form] + [result (syntax-local-eval #'ct-expr)]) + #'(quote result))) + #| + ;; Alternative version + (with-syntax ([quote-form quote-form] + [catch? catch?]) + #'(let-syntax ([aux-macro + (lambda _ + (with-handlers ([(lambda (e) catch?) exn->raise-syntax]) + (with-syntax ([result ct-expr]) + ;; want syntax-local-introduce ? + #'(quote-form result))))]) + (aux-macro))) + |#)]) + #`(#%expression #,stx))) + +(begin-for-syntax + (define (do-convert-ct-error stx exn-pred?) + (if (eq? (syntax-local-context) 'expression) + (syntax-case stx () + [(_ expr) + (with-handlers ([exn-pred? exn->raise-syntax] + [void + (lambda (e) + (eprintf "didn't catch ~e\n" e) + (raise e))]) + (local-expand #'expr 'expression null))]) + #`(#%expression #,stx)))) + +(define-syntax (convert-syntax-error stx) + (parameterize ((error-print-source-location #f)) + (do-convert-ct-error stx exn:fail:syntax?))) + +(define-syntax (convert-compile-time-error stx) + (do-convert-ct-error stx (lambda (e) #t))) diff --git a/collects/unstable/scribblings/macro-testing.scrbl b/collects/unstable/scribblings/macro-testing.scrbl new file mode 100644 index 0000000000..707874ee35 --- /dev/null +++ b/collects/unstable/scribblings/macro-testing.scrbl @@ -0,0 +1,74 @@ +#lang scribble/manual +@(require scribble/eval "utils.rkt" + (for-label racket/base + racket/contract + racket/struct-info + rackunit + unstable/macro-testing)) + +@(define the-eval (make-base-eval)) +@(the-eval '(require rackunit unstable/macro-testing (for-syntax racket/base racket/struct-info))) + +@title[#:tag "macro-testing"]{Macro Testing} +@unstable-header[] + +@defmodule[unstable/macro-testing] + +@defform/subs[(phase1-eval ct-expr maybe-quote maybe-catch?) + ([maybe-quote (code:line) + (code:line #:quote quote-id)] + [maybe-catch? (code:line) + (code:line #:catch? catch?)])]{ + +Evaluates @racket[ct-expr] at compile time and quotes the result using +@racket[quote-id], which defaults to @racket[quote]. Another suitable +argument for @racket[quote-id] is @racket[quote-syntax]. + +If @racket[catch?] is @racket[#t], then if the evaluation of +@racket[ct-expr] raises a compile-time exception, it is caught and +converted to a run-time exception. + +@examples[#:eval the-eval +(struct point (x y)) +(phase1-eval (extract-struct-info (syntax-local-value #'point))) +(phase1-eval (extract-struct-info (syntax-local-value #'point)) + #:quote quote-syntax) +] +} + +@defform[(convert-compile-time-error expr)]{ + +Equivalent to @racket[(#%expression expr)] except if expansion of +@racket[expr] causes a compile-time exception to be raised; in that +case, the compile-time exception is converted to a run-time exception +raised when the expression is evaluated. + +Use @racket[convert-compile-time-error] to write tests for +compile-time error checking like syntax errors: + +@examples[#:eval the-eval +(check-exn #rx"missing an \"else\" expression" + (lambda () (convert-compile-time-error (if 1 2)))) +(check-exn #rx"missing formals and body" + (lambda () (convert-compile-time-error (lambda)))) +] + +Without the use of @racket[convert-compile-time-error], the checks +above would not be executed because the test program would not compile. +} + +@defform[(convert-syntax-error expr)]{ + +Like @racket[convert-compile-time-error], but only catches compile-time +@racket[exn:fail:syntax?] exceptions and sets +@racket[error-print-source-location] to @racket[#f] around the +expansion of @racket[expr] to make the message easier to match +exactly. + +@examples[#:eval the-eval +(check-exn #rx"^lambda: bad syntax$" + (lambda () (convert-syntax-error (lambda)))) +] +} + +@(close-eval the-eval) diff --git a/collects/unstable/scribblings/unstable.scrbl b/collects/unstable/scribblings/unstable.scrbl index 00175a2094..afabdd71d2 100644 --- a/collects/unstable/scribblings/unstable.scrbl +++ b/collects/unstable/scribblings/unstable.scrbl @@ -91,6 +91,7 @@ Keep documentation and tests up to date. @include-section["lazy-require.scrbl"] @include-section["list.scrbl"] @include-section["logging.scrbl"] +@include-section["macro-testing.scrbl"] @include-section["markparam.scrbl"] @include-section["match.scrbl"] @include-section["open-place.scrbl"]