use hairy macro rewriting to make more of racunit work

original commit: b00b72a73a78f5b24a18fd79d907d987efe61530

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)

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)

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