From 6b83691093b82fede3075e9936c1af62517e9312 Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 2 Jan 2014 17:22:38 -0800 Subject: [PATCH] Made error messages better for contract generation failures. original commit: 1acd1537e8e439376da4c925dd4cc96334467f16 --- .../typed-racket/private/type-contract.rkt | 31 +++++++++++-------- .../static-contracts/combinators/struct.rkt | 3 +- .../combinators/structural.rkt | 13 ++++++-- .../static-contracts/constraints.rkt | 9 ++++-- .../static-contracts/instantiate.rkt | 8 ++++- .../unit-tests/contract-tests.rkt | 16 ++++------ 6 files changed, 50 insertions(+), 30 deletions(-) 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 d0719c05..5abbc124 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 @@ -14,6 +14,7 @@ racket/match racket/syntax racket/list racket/format racket/dict + unstable/list unstable/sequence (static-contracts instantiate optimize structures combinators) ;; TODO make this from contract-req @@ -288,7 +289,7 @@ [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?) (cond [(dict-ref recursive-values nm #f)] - [proc (fail #:reason "t->sc2")] + [proc (fail #:reason "procedural structs are not supported")] [poly? (define nm* (generate-temporary #'n*)) (define fields @@ -311,7 +312,7 @@ [(Channel: t) (channel/sc (t->sc t))] [else - (fail #:reason "t->sc3")])))) + (fail #:reason "contract generation not supported for this type")])))) (define (t->sc/function f fail typed-side recursive-values loop method?) (define (t->sc t #:recursive-values (recursive-values recursive-values)) @@ -372,14 +373,15 @@ (define rest (and rst (listof/sc (t->sc/neg rst)))) (function/sc (process-dom mand-args) opt-args mand-kws opt-kws rest range)])] [else - (define ((f [case-> #f]) a) + (define ((f case->) a) (define (convert-arr arr) (match arr [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws) (let-values ([(mand-kws opt-kws) (partition-kws kws)]) ;; Garr, I hate case->! (when (and (not (empty? kws)) case->) - (fail #:reason "t->sc4")) + (fail #:reason (~a "cannot generate contract for case function type" + " with optional keyword arguments"))) (if case-> (arr/sc (map t->sc/neg dom) (and rst (t->sc/neg rst)) (map t->sc rngs)) (function/sc @@ -396,15 +398,18 @@ ;; functions with filters or objects [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws) (if (from-untyped? typed-side) - (fail #:reason "t->sc5") - (convert-arr a))] - [_ (fail #:reason "t->sc6")])) - (unless (no-duplicates (for/list ([t arrs]) - (match t - [(arr: dom _ _ _ _) (length dom)] - ;; is there something more sensible here? - [(top-arr:) (int-err "got top-arr")]))) - (fail #:reason "t->sc7")) + (fail #:reason (~a "cannot generate contract for function type" + " with filters or objects.")) + (convert-arr a))])) + (define arities + (for/list ([t 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)) + (when maybe-dup + (fail #:reason (~a "function type has two cases of arity " maybe-dup))) (if (= (length arrs) 1) ((f #f) (first arrs)) (case->/sc (map (f #t) arrs)))])] diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt index 738b7e7b..fdd00a44 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/struct.rkt @@ -34,7 +34,8 @@ (merge-restricts* (if mut? 'chaperone 'flat) (map (lambda (a) (if mut? - (add-constraint (f a) 'chaperone "reason3") + (add-constraint (f a) 'chaperone + (λ (actual-kind) (error "How is this triggered"))) (f a))) args))]))]) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt index 0e27ed2a..7f69c913 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/combinators/structural.rkt @@ -8,6 +8,7 @@ racket/list racket/match (for-syntax racket/base racket/syntax syntax/stx syntax/parse) racket/set + racket/format unstable/contract (for-template racket/base racket/contract/base @@ -48,7 +49,11 @@ #'(lambda (v recur) (for/list ([arg (in-list (combinator-args v))] [kind (in-list (list 'pos.category-stx ...))]) - (add-constraint (recur arg) kind "reason1"))) + (add-constraint (recur arg) kind + (λ (actual-kind) + ;;TODO add code for a vs an + (~a "required a " kind " contract but could only generate a " + actual-kind " contract"))))) #:attr combinator2 #'(λ (constructor) (λ (pos.name ...) (constructor (list pos.name ...)))) #:with matcher @@ -73,7 +78,11 @@ #:with ->restricts #'(lambda (v recur) (for/list ([arg (in-list (combinator-args v))]) - (add-constraint (recur arg) 'rest.category-stx "reason2"))) + (add-constraint (recur arg) 'rest.category-stx + (λ (actual-kind) + ;;TODO add code for a vs an + (~a "required a " 'rest.category-stx " contract but could only generate a " + actual-kind " contract"))))) #:with matcher #'(define-match-expander matcher-name (syntax-parser diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/constraints.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/constraints.rkt index e896f5cd..7889de31 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/constraints.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/constraints.rkt @@ -55,7 +55,8 @@ [exn:fail:constraint-failure? predicate/c] [exn:fail:constraint-failure-reason (exn:fail:constraint-failure? . -> . string?)] [validate-constraints (contract-restrict? . -> . void?)] - [add-constraint (contract-restrict? contract-kind? string? . -> . contract-restrict?)]) + [add-constraint + (contract-restrict? contract-kind? (contract-kind? . -> . string?) . -> . contract-restrict?)]) contract-restrict-recursive-values contract-restrict? @@ -68,7 +69,9 @@ "kinds.rkt") (provide (contract-out - [struct constraint ([value kind-max?] [max contract-kind?] [reason string?])] + [struct constraint ([value kind-max?] + [max contract-kind?] + [reason (contract-kind? . -> . string?)])] [struct kind-max ([variables free-id-table?] [max contract-kind?])] [struct contract-restrict ([value kind-max?] [recursive-values free-id-table?] @@ -186,5 +189,5 @@ (raise (exn:fail:constraint-failure (format "Violated constraint: ~a" reason) (current-continuation-marks) - reason)))]))])) + (reason kind))))]))])) diff --git a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt index d2d14f75..65bebdb8 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-lib/typed-racket/static-contracts/instantiate.rkt @@ -43,7 +43,13 @@ [(? sc?) (sc->constraints sc recur)])) (define constraints (recur sc)) - (validate-constraints (add-constraint constraints max-kind "reason4")) + (validate-constraints + (add-constraint + constraints + max-kind + (λ (actual-kind) + ;;TODO add code for a vs an + (format "required a ~a contract but could only generate a ~a contract" max-kind actual-kind)))) constraints) 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 84fd09ae..6776bc6a 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 @@ -36,11 +36,11 @@ (fail-check "Reason didn't match expected."))))))) +;; These will fail when the bug is fixed. (define known-bugs (test-suite "Known Bugs" ;; Polydotted functions should work - #; (t/fail (-polydots (a) (->... (list) (a a) -Symbol)) "not supported for this type") @@ -74,7 +74,6 @@ (t/fail ((-poly (a) (-vec a)) . -> . -Symbol) "cannot generate contract for non-function") - #| (t/fail (make-Function (list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f))) @@ -86,23 +85,20 @@ (-> -Boolean -Boolean) (-> -Symbol -Symbol)) "two cases of arity 1") - (t/fail (-Syntax (-HT -Symbol -Symbol)) - "first-order contract, but got a hashtable.") (t/fail (-struct #'struct-name #f (list (make-fld -Symbol #'acc #f)) (-> -Symbol)) "procedural structs are not supported") (t/fail (-Syntax (-> -Boolean -Boolean)) - #rx"required a first-order .* generate a higher-order") + #rx"required a flat contract but could only generate a chaperone contract") + (t/fail (-Syntax (-seq -Boolean)) + #rx"required a flat contract but could only generate a impersonator contract") (t/fail (-set (-seq -Boolean)) - #rx"required a chaperone or flat contract .* generate an impersonator") + #rx"required a chaperone contract but could only generate a impersonator contract") (t/fail (make-Function (list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #t))) (make-arr* (list Univ Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #t))))) - "some error") + "case function type with optional keyword arguments") - (t/fail (-Syntax (-struct #'struct-name #f (list (make-fld -Symbol #'acc #t)) #f #t)) - "some error") - |# ))