From deaf4861c288fdebadebad4a52a943c3ceb83599 Mon Sep 17 00:00:00 2001 From: Asumu Takikawa Date: Tue, 17 Sep 2013 16:24:47 -0400 Subject: [PATCH] Improve type->contract error messages original commit: 0b78356be72274c07553047f5f95614e329617c3 --- .../typed-racket/base-env/prims.rkt | 10 ++- .../typed-racket/private/type-contract.rkt | 70 +++++++++++++------ .../typed-racket/private/with-types.rkt | 4 +- .../typecheck/provide-handling.rkt | 2 +- .../unit-tests/contract-tests.rkt | 18 +++-- 5 files changed, 67 insertions(+), 37 deletions(-) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt index 88266817..dac67f54 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/base-env/prims.rkt @@ -85,7 +85,7 @@ This file defines two sorts of primitives. All of them are provided into any mod (lazy-require ["../rep/type-rep.rkt" (make-Opaque Error?)] [syntax/define (normalize-definition)] [typed-racket/private/parse-type (parse-type)] - [typed-racket/private/type-contract (type->contract)] + [typed-racket/private/type-contract (type->contract type->contract-fail)] [typed-racket/env/type-name-env (register-type-name)])) (define-for-syntax (ignore stx) (ignore-property stx #t)) @@ -161,8 +161,7 @@ This file defines two sorts of primitives. All of them are provided into any mod ;; this is for a `require/typed', so the value is not ;; from the typed side #:typed-side #f - (lambda () - (tc-error/stx #'ty "Type ~a could not be converted to a contract." typ))))) + (type->contract-fail typ #'ty)))) ;; in the fix-up case, the contract is just an identifier ;; that is defined below (generate-temporary #'nm.nm))) @@ -270,7 +269,7 @@ This file defines two sorts of primitives. All of them are provided into any mod #:kind 'flat ;; the value is not from the typed side #:typed-side #f - (lambda () (tc-error/stx #'ty "Type ~a could not be converted to a predicate." typ))) + (type->contract-fail typ #'ty #:ctc-str "predicate")) #t) (Any -> Boolean : ty)))))])) @@ -316,8 +315,7 @@ This file defines two sorts of primitives. All of them are provided into any mod typ ;; the value is not from the typed side #:typed-side #f - (lambda () - (tc-error/stx #'ty "Type ~a could not be converted to a contract" typ))))))])])) + (type->contract-fail typ #'ty)))))])])) (define-for-syntax (fail stx) (syntax-parse stx diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt index c910d5d4..019dd7c7 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/type-contract.rkt @@ -2,7 +2,8 @@ ;; Contract generation for Typed Racket -(provide type->contract define/fixup-contract? change-contract-fixups) +(provide type->contract define/fixup-contract? change-contract-fixups + type->contract-fail) (require "../utils/utils.rkt" @@ -14,6 +15,8 @@ (prefix-in t: (types abbrev numeric-tower)) (private parse-type syntax-properties) racket/match syntax/stx racket/syntax racket/list + racket/format + unstable/list unstable/sequence (contract-req) (for-template racket/base racket/contract racket/set (utils any-wrap) @@ -44,6 +47,19 @@ (typechecker:flat-contract-def stx) (typechecker:contract-def/maker stx))) +;; type->contract-fail : Syntax Type #:ctc-str String +;; -> #:reason (Option String) -> Void +;; Curried function that produces a function to report +;; type->contract failures +(define ((type->contract-fail to-check to-report + #:ctc-str [ctc-str "contract"]) + #:reason [reason #f]) + (tc-error/stx + to-report + (~a "Type ~a could not be converted to a " + ctc-str + (if reason (~a ": " reason) ".")) + to-check)) (define (generate-contract-def stx) (define prop (define/fixup-contract? stx)) @@ -61,11 +77,7 @@ ;; this is for a `require/typed', so the value is not from the typed side #:typed-side #f #:kind kind - (λ () - (tc-error/stx - prop - "Type ~a could not be converted to a contract." - typ)))]) + (type->contract-fail typ prop))]) (quasisyntax/loc stx (define-values (n) @@ -81,9 +93,6 @@ e (generate-contract-def e)))) -(define (no-duplicates l) - (= (length l) (length (remove-duplicates l)))) - ;; To avoid misspellings (define impersonator-sym 'impersonator) (define chaperone-sym 'chaperone) @@ -230,7 +239,9 @@ null (map t->c rngs) (and rst (t->c/neg rst))) - (exit (fail)))] + (exit (fail #:reason + (~a "cannot generate contract for function type" + " with filters or objects."))))] [_ (exit (fail))])) (with-syntax* ([(dom* ...) (process-dom dom*)] @@ -246,12 +257,16 @@ #'(dom* ... rst-spec ... . -> . rng*) #'((dom* ...) (opt-dom* ...) rst-spec ... . ->* . rng*)) #'(dom* ... . -> . rng*))))) - (unless (no-duplicates (for/list ([t (in-list arrs)]) - (match t - [(arr: dom _ _ _ _) (length dom)] - ;; is there something more sensible here? - [(top-arr:) (int-err "got top-arr")]))) - (exit (fail))) + (define arities (for/list ([t (in-list arrs)]) + (match t + [(arr: dom _ _ _ _) (length dom)] + ;; is there something more sensible here? + [(top-arr:) (int-err "got top-arr")]))) + (define maybe-dup (check-duplicate arities #:same? =)) + (when maybe-dup + (define reason + (~a "function type has two cases of arity " maybe-dup)) + (exit (fail #:reason reason))) (match (map (f (not (= 1 (length arrs)))) arrs) [(list e) e] [l #`(case-> #,@l)])])] @@ -259,10 +274,16 @@ ;; Helpers for contract requirements (define (set-impersonator!) - (when (not (equal? kind impersonator-sym)) (exit (fail))) + (when (not (equal? kind impersonator-sym)) + (exit (fail #:reason + (~a "required a chaperone or flat contract but could" + " only generate an impersonator contract.")))) (increase-current-contract-kind! impersonator-sym)) (define (set-chaperone!) - (when (equal? kind flat-sym) (exit (fail))) + (when (equal? kind flat-sym) + (exit (fail #:reason + (~a "required a first-order contract but could" + " only generate a higher-order contract.")))) (increase-current-contract-kind! chaperone-sym)) @@ -341,7 +362,8 @@ #`(and/c #,(t->c par) (flat-contract #,p?))] [(Union: elems) (let-values ([(vars notvars) (partition F? elems)]) - (unless (>= 1 (length vars)) (exit (fail))) + (unless (>= 1 (length vars)) + (exit (fail #:reason "union type includes multiple distinct type variables"))) (with-syntax ([cnts (append (map t->c vars) (map t->c notvars))]) #'(or/c . cnts)))] @@ -386,7 +408,7 @@ [(PolyDots: _ body) (loop body)] [_ #f]))) (unless function-type? - (exit (fail))) + (exit (fail #:reason "cannot generate contract for non-function polymorphic type"))) (if (not (from-untyped? typed-side)) ;; in typed positions, no checking needed for the variables (parameterize ([vars (append (for/list ([v (in-list vs)]) (list v #'any/c)) (vars))]) @@ -431,9 +453,11 @@ [(assf (λ (t) (type-equal? t ty)) structs-seen) => cdr] - [proc (exit (fail))] + [proc (exit (fail #:reason "procedural structs are not supported"))] [(and (equal? kind flat-sym) (ormap values mut?)) - (exit (fail))] + (exit (fail #:reason + (~a "expected a first-order contract, but got" + " a struct with at least one mutable field")))] [poly? (with-syntax* ([struct-ctc (generate-temporary 'struct-ctc)]) (define field-contracts @@ -462,6 +486,6 @@ (when (equal? kind flat-sym) (exit (fail))) #`(hash/c #,(t->c k #:kind chaperone-sym) #,(t->c v) #:immutable 'dont-care)] [else - (exit (fail))])))) + (exit (fail #:reason "contract generation not supported for this type"))])))) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt index 248e7071..7df49b58 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/private/with-types.rkt @@ -27,8 +27,8 @@ (define old-context (unbox typed-context?)) (unless (not old-context) (tc-error/stx stx "with-type cannot be used in a typed module.")) - (define ((no-contract t [stx stx])) - (tc-error/stx stx "Type ~a could not be converted to a contract." t)) + (define (no-contract t [stx stx]) + (type->contract-fail t stx)) (set-box! typed-context? #t) (init) (define fv-types (for/list ([t (in-syntax fvtys)]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt index a111adf8..fd1a6b67 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/typecheck/provide-handling.rkt @@ -132,7 +132,7 @@ ;; mk-value-triple : identifier? identifier? (or/c syntax? #f) -> triple/c (define (mk-value-triple internal-id new-id ty) - (define contract (type->contract ty (λ () #f))) + (define contract (type->contract ty (λ (#:reason [reason #f]) #f))) (with-syntax* ([id internal-id] [untyped-id (freshen-id #'id)] diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt index 2cd0de7a..1a8a8922 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/contract-tests.rkt @@ -8,13 +8,21 @@ rackunit) (define-syntax-rule (t e) - (test-not-exn (format "~a" e) (lambda () (type->contract e (lambda _ (error "type could not be converted to contract")))))) + (test-not-exn + (format "~a" e) + (λ () + (type->contract + e + (λ (#:reason [reason #f]) + (error "type could not be converted to contract")))))) (define-syntax-rule (t/fail e) - (test-not-exn (format "~a" e) (lambda () - (let/ec exit - (type->contract e (lambda _ (exit #t))) - (error "type could be converted to contract"))))) + (test-not-exn + (format "~a" e) + (λ () + (let/ec exit + (type->contract e (λ (#:reason [reason #f]) (exit #t))) + (error "type could be converted to contract"))))) (define (contract-tests) (test-suite "Contract Tests"