diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt index daf862f48e..ae18bc3755 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/core.rkt @@ -11,7 +11,7 @@ (types utils abbrev generalize printer) (typecheck provide-handling tc-toplevel tc-app-helper) (rep type-rep) - (for-template (only-in (base-env prims) :type :print-type :query-type/result)) + (for-template (only-in (base-env prims) :type :print-type :query-type/args :query-type/result)) (utils utils tc-utils arm) "tc-setup.rkt") @@ -72,8 +72,10 @@ (format "[can expand further: ~a]" (string-join (map ~a unexpanded))))) #`(display #,(format "~a\n~a" type cue)))] + [(_ . (~and form ((~literal :type) . _))) + (raise-syntax-error #f "must be applied to exactly one argument" #'form)] ;; Prints the _entire_ type. May be quite large. - [(_ . ((~literal :print-type) e:expr)) + [(_ . ((~literal :print-type) e)) (tc-setup #'stx #'e 'top-level expanded init tc-toplevel-form before type #`(display #,(parameterize ([print-multi-line-case-> #t]) @@ -81,8 +83,10 @@ [(tc-result1: t f o) t] [(tc-results: t) (cons 'Values t)] [(tc-any-results:) ManyUniv])))))] + [(_ . (~and form ((~literal :print-type) . _))) + (raise-syntax-error #f "must be applied to exactly one argument" #'form)] ;; given a function and input types, display the result type - [(_ . ((~literal :query-type/args) op:expr arg-type:expr ...)) + [(_ . ((~literal :query-type/args) op arg-type ...)) (with-syntax ([(dummy-arg ...) (generate-temporaries #'(arg-type ...))]) (tc-setup #'stx ;; create a dummy function with the right argument types @@ -94,8 +98,10 @@ #,(format "~a\n" (match type [(tc-result1: (and t (Function: _)) f o) t])))))] + [(_ . (~and form ((~literal :query-type/args) . _))) + (raise-syntax-error #f "must be applied to at least one argument" #'form)] ;; given a function and a desired return type, fill in the blanks - [(_ . ((~literal :query-type/result) op:expr desired-type:expr)) + [(_ . ((~literal :query-type/result) op desired-type)) (let ([expected (parse-type #'desired-type)]) (tc-setup #'stx #'op 'top-level expanded init tc-toplevel-form before type (match type @@ -108,6 +114,8 @@ [(Function: arrs) (format "~a\n" cleaned)])))] [_ (error (format "~a: not a function" (syntax->datum #'op) ))])))] + [(_ . (~and form ((~literal :query-type/result) . _))) + (raise-syntax-error #f "must be applied to exactly two arguments" #'form)] [(_ . form) (init) (tc-setup diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt index 403943cb9a..1bf7dac9d0 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/all-tests.rkt @@ -15,6 +15,7 @@ "module-tests.rkt" ;; pass "contract-tests.rkt" + "interactive-tests.rkt" racket/runtime-path rackunit rackunit/text-ui) @@ -40,6 +41,7 @@ fv-tests contract-tests keyword-tests + interactive-tests ;; this uses dynamic require because the file fails to compile when there's a test failure (λ () ((dynamic-require special 'typecheck-special-tests))))]) (f)))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/interactive-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/interactive-tests.rkt new file mode 100644 index 0000000000..d3bc2e7ade --- /dev/null +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/interactive-tests.rkt @@ -0,0 +1,80 @@ +#lang racket/base + +(require + racket/base + racket/port + racket/promise + rackunit + (for-syntax + racket/base + racket/format + syntax/parse)) + +(provide interactive-tests) + +(define promised-ns + (delay + (define ns (make-base-namespace)) + (eval '(require typed/racket) ns) + ;; Load TR code. TODO make this not needed (pr/13102) + (eval '(#%top-interaction void) ns) + ns)) + +(define-syntax (test-form-exn stx) + (syntax-parse stx + [(_ regexp:expr form:expr) + (quasisyntax/loc stx + (test-case #,(~a (syntax->datum #'form)) + (check-exn + regexp + (lambda () + (eval `(#%top-interaction . + ,(syntax->datum #'form)) (force promised-ns))))))])) + +(define-syntax (test-form stx) + (syntax-parse stx + [(_ regexp:expr form:expr) + (quasisyntax/loc stx + (test-case #,(~a (syntax->datum #'form)) + (check-regexp-match + regexp + (with-output-to-string + (lambda () + (eval `(#%top-interaction . + ,(syntax->datum #'form)) (force promised-ns)))))))])) + +(define (interactive-tests) + (test-suite "Interactive tests" + (test-form #rx"1" + (:type 1)) + (test-form (regexp-quote "(U Positive-Byte Zero)") + (:type Byte)) + (test-form (regexp-quote "(U 0 1 Byte-Larger-Than-One") + (:type #:verbose Byte)) + (test-form-exn #rx"applied to arguments" + :type) + (test-form-exn #rx"exactly one argument" + (:type)) + (test-form-exn #rx"exactly one argument" + (:type 1 2)) + (test-form-exn #rx"exactly one argument" + (:type #:verbose)) + + (test-form-exn #rx"applied to arguments" + :print-type) + (test-form-exn #rx"exactly one argument" + (:print-type)) + (test-form-exn #rx"exactly one argument" + (:print-type 1 2)) + + (test-form-exn #rx"applied to arguments" + :query-type/args) + (test-form-exn #rx"at least one argument" + (:query-type/args)) + + (test-form-exn #rx"applied to arguments" + :query-type/result) + (test-form-exn #rx"exactly two arguments" + (:query-type/result)) + (test-form-exn #rx"exactly two arguments" + (:query-type/result 1 2 3))))