diff --git a/collects/typed/private/rewriter.rkt b/collects/typed/private/rewriter.rkt new file mode 100644 index 00000000..45c29a5c --- /dev/null +++ b/collects/typed/private/rewriter.rkt @@ -0,0 +1,60 @@ +#lang racket/base +(require (for-syntax syntax/parse racket/base syntax/id-table racket/dict + unstable/debug)) + +(define-for-syntax (rewrite stx tbl from) + (define (rw stx) + (syntax-recertify + (syntax-parse stx #:literal-sets (kernel-literals) + [i:identifier + (dict-ref tbl #'i #'i)] + ;; no expressions here + [((~or (~literal #%top) (~literal quote) (~literal quote-syntax)) . _) stx] + [(#%plain-lambda formals expr ...) + (quasisyntax/loc stx (#%plain-lambda formals #,@(map rw (syntax->list #'(expr ...)))))] + [(case-lambda [formals expr ...] ...) + (with-syntax ([((expr* ...) ...) (for*/list ([exprs (in-list (syntax->list #'((expr ...) ...)))] + [e (in-list (syntax->list exprs))]) + (rw e))]) + (quasisyntax/loc stx (case-lambda [formals expr* ...] ...)))] + [(let-values ([(id ...) rhs] ...) expr ...) + (with-syntax ([(rhs* ...) (map rw (syntax->list #'(rhs ...)))] + [(expr* ...) (map rw (syntax->list #'(expr ...)))]) + (quasisyntax/loc stx (let-values ([(id ...) rhs*] ...) expr* ...)))] + [(letrec-values ([(id ...) rhs] ...) expr ...) + (with-syntax ([(rhs* ...) (map rw (syntax->list #'(rhs ...)))] + [(expr* ...) (map rw (syntax->list #'(expr ...)))]) + (quasisyntax/loc stx (letrec-values ([(id ...) rhs*] ...) expr* ...)))] + [(letrec-syntaxes+values ([(sid ...) srhs] ...) ([(id ...) rhs] ...) expr ...) + (with-syntax ([(srhs* ...) (map rw (syntax->list #'(srhs ...)))] + [(rhs* ...) (map rw (syntax->list #'(rhs ...)))] + [(expr* ...) (map rw (syntax->list #'(expr ...)))]) + (quasisyntax/loc stx (letrec-syntaxes+values ([(sid ...) srhs*] ...) ([(id ...) rhs*] ...) expr* ...)))] + [((~and kw + (~or if begin begin0 set! #%plain-app #%expression + #%variable-reference with-continuation-mark)) + expr ...) + (quasisyntax/loc stx (#,#'kw #,@(map rw (syntax->list #'(expr ...)))))]) + stx + (current-code-inspector) + #f)) + (rw stx)) + +(define-syntax (define-rewriter stx) + (syntax-case stx () + [(_ orig-name new-name [from to] ...) + #'(begin + (define-for-syntax from-list (list #'from ...)) + (define-for-syntax tbl (make-immutable-free-id-table (map cons from-list (list #'to ...)))) + (define-syntax (new-name stx) + (syntax-case stx () + [(_ . args) + (let ([result (local-expand (syntax/loc stx (orig-name . args)) (syntax-local-context) null)]) + (rewrite result tbl from-list))])))])) + +(provide define-rewriter) +#;(define-syntax-rule (m x) (+ x 7)) + +#;(define-rewriter m n [+ -]) + +#;(n 77) diff --git a/collects/typed/racunit/main.rkt b/collects/typed/racunit/main.rkt index 93b1752b..6232b889 100644 --- a/collects/typed/racunit/main.rkt +++ b/collects/typed/racunit/main.rkt @@ -1,5 +1,7 @@ #lang typed/scheme -(require typed/private/utils) +(require typed/private/utils + typed/private/rewriter + "type-env-ext.rkt") (define-type check-ish-ty (case-lambda @@ -67,7 +69,7 @@ racunit [make-check-name (String -> CheckInfo)] [make-check-params ((Listof Any) -> CheckInfo)] - [make-check-location ((List Any (U Number #f) (U Number #f) (U Number #f) (U Number #f)) -> CheckInfo)] + [make-check-location ((List Any (Option Number) (Option Number) (Option Number) (Option Number)) -> CheckInfo)] [make-check-expression (Any -> CheckInfo)] [make-check-message (String -> CheckInfo)] [make-check-actual (Any -> CheckInfo)] @@ -89,7 +91,18 @@ (Parameter ((Thunk Any) -> Any))]) ; 3.3 -(require (only-in racunit test-begin test-case)) +(require (prefix-in t: (except-in racunit struct:check-info struct:exn:test struct:exn:test:check struct:test-result struct:test-failure + struct:test-error struct:test-success))) +(define-rewriter t:test-begin test-begin + [t:current-test-case-around current-test-case-around] + [t:check-around check-around] + [t:current-check-handler current-check-handler] + [t:current-check-around current-check-around]) +(define-rewriter t:test-case test-case + [t:current-test-case-around current-test-case-around] + [t:check-around check-around] + [t:current-check-handler current-check-handler] + [t:current-check-around current-check-around]) (provide test-begin test-case) (require/opaque-type TestCase test-case? racunit) diff --git a/collects/typed/racunit/type-env-ext.rkt b/collects/typed/racunit/type-env-ext.rkt new file mode 100644 index 00000000..02777a75 --- /dev/null +++ b/collects/typed/racunit/type-env-ext.rkt @@ -0,0 +1,23 @@ +#lang scheme/base + +(require typed-scheme/utils/utils + (prefix-in ru: (combine-in racunit racunit/private/test-case racunit/private/check)) + (for-syntax + scheme/base syntax/parse + (utils tc-utils) + (env init-envs) + (except-in (rep filter-rep object-rep type-rep) make-arr) + (types convenience union) + (only-in (types convenience) [make-arr* make-arr]))) + +(define-for-syntax unit-env + (make-env + [ru:check-around + (-poly (a) (-> (-> a) a))] + ;; current-test-case-around + [(syntax-parse (local-expand #'(ru:test-begin 0) 'expression null) + #:context #'ru:test-begin + [(_ _ . _) #'ctca]) + (-poly (a) (-> (-> a) a))])) + +(begin-for-syntax (initialize-type-env unit-env)) \ No newline at end of file