Adding typed/racunit and fixing racunit exports vis a vis documentation

collects/racunit/private/check.rkt

@@ -30,6 +30,7 @@
          check-=
          check-not-false
          check-not-eq?
+         check-not-eqv?
          check-not-equal?
          fail)
 
@@ -263,6 +264,9 @@
 (define-simple-check (check-not-eq? expr1 expr2)
   (not (eq? expr1 expr2)))
 
+(define-simple-check (check-not-eqv? expr1 expr2)
+  (not (eqv? expr1 expr2)))
+
 (define-simple-check (check-not-equal? expr1 expr2)
   (not (equal? expr1 expr2)))
 

collects/racunit/private/test.rkt

@@ -9,7 +9,8 @@
          "test-suite.rkt"
          "util.rkt")
 
-(provide (struct-out exn:test:check)
+(provide (struct-out exn:test)
+         (struct-out exn:test:check)
          (struct-out check-info)
          (struct-out test-result)
          (struct-out test-failure)
@@ -45,6 +46,10 @@
          (rename-out [make-racunit-test-case make-test-case]
                      [racunit-test-case? test-case?]
                      [racunit-test-suite? test-suite?])
+         current-test-name
+         current-test-case-around
+         test-suite-test-case-around
+         test-suite-check-around
          
          define-test-suite
          define/provide-test-suite
@@ -80,6 +85,9 @@
          define-check
          define-simple-check
          define-binary-check
+         
+         current-check-handler
+         current-check-around
 
          check
          check-exn
@@ -93,6 +101,7 @@
          check-=
          check-not-false
          check-not-eq?
+         check-not-eqv?
          check-not-equal?
          check-regexp-match
          fail)

collects/racunit/scribblings/check.scrbl

@@ -36,6 +36,7 @@ For example, the following check succeeds:
 @defproc*[([(check-eq? (v1 any) (v2 any) (message string? "")) #t]
            [(check-not-eq? (v1 any) (v2 any) (message string? "")) #t]
            [(check-eqv? (v1 any) (v2 any) (message string? "")) #t]
+           [(check-not-eqv? (v1 any) (v2 any) (message string? "")) #t]
            [(check-equal? (v1 any) (v2 any) (message string? "")) #t]
            [(check-not-equal? (v1 any) (v2 any) (message string? "")) #t])]{
 
@@ -50,6 +51,7 @@ For example, the following checks all fail:
   (check-eq? (list 1) (list 1) "allocated data not eq?")
   (check-not-eq? 1 1 "integers are eq?")
   (check-eqv? 1 1.0 "not eqv?")
+  (check-not-eqv? 1 1 "integers are eqv?")
   (check-equal? 1 1.0 "not equal?")
   (check-not-equal? (list 1) (list 1) "equal?")
 ]

collects/typed/racunit.rkt

@@ -0,0 +1,3 @@
+#lang racket
+(require typed/racunit/main)
+(provide (all-from-out typed/racunit/main))

collects/typed/racunit/gui.rkt

@@ -0,0 +1,10 @@
+#lang typed/scheme
+(require typed/racunit
+         typed/private/utils)
+
+(require/typed/provide
+ racunit/gui
+ [test/gui
+  (Test * -> Any)]
+ [make-gui-runner
+  (-> (Test * -> Any))])

collects/typed/racunit/main.rkt

@@ -0,0 +1,160 @@
+#lang typed/scheme
+(require typed/private/utils)
+
+(define-type check-ish-ty
+  (All (A B)
+       (case-lambda
+         (A B -> #t)
+         (A B String -> #t))))
+(define-type (Predicate A) (A -> Boolean))
+(define-type (Thunk A) (-> A))
+
+; 3.2
+(require/typed/provide
+ racunit
+ [check (All (A B C)
+             (case-lambda
+               ((A B -> C) A B -> C)
+               ((A B -> C) A B String -> C)))]
+ [check-eq? check-ish-ty]
+ [check-not-eq? check-ish-ty]
+ [check-eqv? check-ish-ty]
+ [check-not-eqv? check-ish-ty]
+ [check-equal? check-ish-ty]
+ [check-not-equal? check-ish-ty]
+ [check-pred
+  (All (A B)
+       (case-lambda
+         ((A -> B) A -> #t)
+         ((A -> B) A String -> #t)))]
+ [check-=
+  (case-lambda
+    (Number Number Number -> #t)
+    (Number Number Number String -> #t))]
+ [check-true
+  (case-lambda
+    (Boolean -> #t)
+    (Boolean String -> #t))]
+ [check-false
+  (case-lambda
+    (Boolean -> #t)
+    (Boolean String -> #t))]
+ [check-not-false
+  (case-lambda
+    (Any -> #t)
+    (Any String -> #t))]
+ [check-exn
+  (All (A B)
+       (case-lambda 
+         ((Predicate A) (Thunk B) -> #t)
+         ((Predicate A) (Thunk B) String -> #t)))]
+ [check-not-exn
+  (All (A)
+       (case-lambda
+         ((Thunk A) -> #t)
+         ((Thunk A) String -> #t)))]
+ [fail
+  (case-lambda
+    (-> #t)
+    (String -> #t))]
+ [check-regexp-match
+  (Regexp String -> #t)])
+
+; 3.2.1
+(require-typed-struct check-info
+                      ([name : Symbol] [value : Any])
+                      racunit)
+(define-type CheckInfo check-info)
+(provide (struct-out check-info) CheckInfo)
+(require/typed/provide
+ 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-expression (Any -> CheckInfo)]
+ [make-check-message (String -> CheckInfo)]
+ [make-check-actual (Any -> CheckInfo)]
+ [make-check-expected (Any -> CheckInfo)]
+ [with-check-info* (All (A) ((Listof CheckInfo) (Thunk A) -> A))])
+(require (only-in racunit with-check-info))
+(provide with-check-info)
+
+; 3.2.2
+(require (only-in racunit define-simple-check define-binary-check define-check fail-check))
+(provide define-simple-check define-binary-check define-check fail-check)
+
+; 3.2.3
+(require/typed/provide
+ racunit
+ [current-check-handler
+  (Parameter (Any -> Any))]
+ [current-check-around
+  (Parameter ((Thunk Any) -> Any))])
+
+; 3.3
+(require (only-in racunit test-begin test-case))
+(provide test-begin test-case)
+
+(require/opaque-type TestCase test-case? racunit)
+(provide TestCase test-case?)
+
+(require (only-in racunit test-suite))
+(provide test-suite)
+(require/opaque-type TestSuite test-suite? racunit)
+(provide TestSuite test-suite?)
+
+(define-type Test (U TestCase TestSuite))
+(provide Test)
+
+(require/typed/provide
+ racunit
+ [make-test-suite
+  (case-lambda
+    (String (Listof Test) -> TestSuite)
+    ; XXX #:before #:after
+    )])
+
+(require (only-in racunit define-test-suite define/provide-test-suite))
+(provide define-test-suite define/provide-test-suite)
+
+(require/typed/provide
+ racunit
+ [current-test-name (Parameter (Option String))]
+ [current-test-case-around (Parameter ((Thunk Any) -> Any))]
+ [test-suite-test-case-around ((Thunk Any) -> Any)]
+ [test-suite-check-around ((Thunk Any) -> Any)])
+
+; 3.4
+(require (only-in racunit before after around delay-test))
+(provide before after around delay-test)
+
+; 3.5
+; XXX require/expose seems WRONG for typed/scheme
+
+; 3.7
+(require-typed-struct (exn:test exn) () racunit)
+(require-typed-struct (exn:test:check exn:test) ([stack : (Listof CheckInfo)]) racunit)
+(require-typed-struct test-result ([test-case-name : (Option String)]) racunit)
+(require-typed-struct (test-failure test-result) ([result : Any]) racunit)
+(require-typed-struct (test-error test-result) ([result : Any]) racunit)
+(require-typed-struct (test-success test-result) ([result : Any]) racunit)
+(provide (struct-out exn:test) (struct-out exn:test:check)
+         (struct-out test-result)
+         (struct-out test-failure) (struct-out test-error) (struct-out test-success))
+
+(define-type (Tree A)
+  (Rec The-Tree
+       (Listof (U A The-Tree))))
+
+(require/typed/provide
+ racunit
+ [run-test-case 
+  ((Option String) (Thunk Any) -> test-result)]
+ [run-test
+  (Test -> (Tree test-result))]
+ ; XXX Requires keywords and weird stuff
+ #;[fold-test-results
+    XXX]
+ ; XXX Requires knowing more about test cases and structs
+ #;[foldts
+    XXX])

collects/typed/racunit/text-ui.rkt

@@ -0,0 +1,14 @@
+#lang typed/scheme
+(require typed/racunit
+         typed/private/utils)
+
+(define-type Verbosity
+  (U 'quiet 'normal 'verbose))
+
+(require/typed/provide
+ racunit/text-ui
+ [run-tests
+  (case-lambda
+    (Test -> Natural)
+    (Test Verbosity -> Natural))])
+(provide Verbosity)