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 99c987c5..d0719c05 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 @@ -26,7 +26,8 @@ (provide (c:contract-out [type->static-contract - (c:parametric->/c (a) ((Type/c (c:-> a)) (#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))])) + (c:parametric->/c (a) ((Type/c (c:-> #:reason (c:or/c #f string?) a)) + (#:typed-side boolean?) . c:->* . (c:or/c a static-contract?)))])) (provide type->contract define/fixup-contract? change-contract-fixups type->contract-fail) @@ -152,7 +153,7 @@ (define (type->contract ty init-fail #:typed-side [typed-side #t] #:kind [kind 'impersonator]) (let/ec escape - (define (fail) (escape (init-fail))) + (define (fail #:reason [reason #f]) (escape (init-fail #:reason reason))) (instantiate (optimize (type->static-contract ty #:typed-side typed-side fail) @@ -181,7 +182,7 @@ (define (type->static-contract type init-fail #:typed-side [typed-side #t]) (let/ec return - (define (fail) (return (init-fail))) + (define (fail #:reason reason) (return (init-fail #:reason reason))) (let loop ([type type] [typed-side (if typed-side 'typed 'untyped)] [recursive-values (hash)]) (define (t->sc t #:recursive-values (recursive-values recursive-values)) (loop t typed-side recursive-values)) @@ -244,7 +245,7 @@ [(PolyDots: _ body) (loop body)] [_ #f]))) (unless function-type? - (fail)) + (fail #:reason "cannot generate contract for non-function polymorphic type")) (let ((temporaries (generate-temporaries vs-nm))) (define rv (for/fold ((rv recursive-values)) ((temp temporaries) (v-nm vs-nm)) @@ -287,7 +288,7 @@ [(Struct: nm par (list (fld: flds acc-ids mut?) ...) proc poly? pred?) (cond [(dict-ref recursive-values nm #f)] - [proc (fail)] + [proc (fail #:reason "t->sc2")] [poly? (define nm* (generate-temporary #'n*)) (define fields @@ -310,7 +311,7 @@ [(Channel: t) (channel/sc (t->sc t))] [else - (fail)])))) + (fail #:reason "t->sc3")])))) (define (t->sc/function f fail typed-side recursive-values loop method?) (define (t->sc t #:recursive-values (recursive-values recursive-values)) @@ -378,7 +379,7 @@ (let-values ([(mand-kws opt-kws) (partition-kws kws)]) ;; Garr, I hate case->! (when (and (not (empty? kws)) case->) - (fail)) + (fail #:reason "t->sc4")) (if case-> (arr/sc (map t->sc/neg dom) (and rst (t->sc/neg rst)) (map t->sc rngs)) (function/sc @@ -395,15 +396,15 @@ ;; functions with filters or objects [(arr: dom (Values: (list (Result: rngs _ _) ...)) rst #f kws) (if (from-untyped? typed-side) - (fail) + (fail #:reason "t->sc5") (convert-arr a))] - [_ (fail)])) + [_ (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)) + (fail #:reason "t->sc7")) (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 b55f125b..738b7e7b 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,7 @@ (merge-restricts* (if mut? 'chaperone 'flat) (map (lambda (a) (if mut? - (add-constraint (f a) 'chaperone) + (add-constraint (f a) 'chaperone "reason3") (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 57408254..0e27ed2a 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 @@ -48,7 +48,7 @@ #'(lambda (v recur) (for/list ([arg (in-list (combinator-args v))] [kind (in-list (list 'pos.category-stx ...))]) - (add-constraint (recur arg) kind))) + (add-constraint (recur arg) kind "reason1"))) #:attr combinator2 #'(λ (constructor) (λ (pos.name ...) (constructor (list pos.name ...)))) #:with matcher @@ -73,7 +73,7 @@ #:with ->restricts #'(lambda (v recur) (for/list ([arg (in-list (combinator-args v))]) - (add-constraint (recur arg) 'rest.category-stx))) + (add-constraint (recur arg) 'rest.category-stx "reason2"))) #: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 f2016b66..e896f5cd 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 @@ -17,7 +17,7 @@ ;; This means that the generated contract will be the max of kind and all of the other contract ;; restricts. ;; -;; add-constraint: contract-restrict? kind? -> contract-restrict +;; add-constraint: contract-restrict? kind? string? -> contract-restrict ;; This means the kind of the generated contract can not be greater than the supplied kind. ;; ;; close-loop: (lisotf identifier?) (listof contract-restrict?) contract-restrict? -> contract-restrict? @@ -50,11 +50,12 @@ variable-contract-restrict merge-restricts* merge-restricts - add-constraint close-loop (contract-out [exn:fail:constraint-failure? predicate/c] - [validate-constraints (contract-restrict? . -> . void?)]) + [exn:fail:constraint-failure-reason (exn:fail:constraint-failure? . -> . string?)] + [validate-constraints (contract-restrict? . -> . void?)] + [add-constraint (contract-restrict? contract-kind? string? . -> . contract-restrict?)]) contract-restrict-recursive-values contract-restrict? @@ -67,19 +68,19 @@ "kinds.rkt") (provide (contract-out - [struct constraint ([value kind-max?] [max contract-kind?])] + [struct constraint ([value kind-max?] [max contract-kind?] [reason string?])] [struct kind-max ([variables free-id-table?] [max contract-kind?])] [struct contract-restrict ([value kind-max?] [recursive-values free-id-table?] [constraints (set/c constraint?)])])) - (struct constraint (value max) #:transparent) + (struct constraint (value max reason) #:transparent) (struct kind-max (variables max) #:transparent) (struct contract-restrict (value recursive-values constraints) #:transparent)) (require 'structs) (provide (struct-out kind-max)) -(struct exn:fail:constraint-failure exn:fail ()) +(struct exn:fail:constraint-failure exn:fail (reason)) (define (free-id-set . elems) (for/fold ([table (make-immutable-free-id-table)]) @@ -104,12 +105,12 @@ (contract-restrict (kind-max (free-id-set var) 'flat) (make-immutable-free-id-table) (set))) -(define (add-constraint cr max) +(define (add-constraint cr max reason) (if (equal? 'impersonator max) cr (match cr [(contract-restrict v rec constraints) - (contract-restrict v rec (set-add constraints (constraint v max)))]))) + (contract-restrict v rec (set-add constraints (constraint v max reason)))]))) (define (add-recursive-values cr dict) (match cr @@ -180,7 +181,10 @@ [(contract-restrict (kind-max (app dict-count 0) _) rec constraints) (for ([const (in-set constraints)]) (match const - [(constraint (kind-max (app dict-count 0) kind) bound) + [(constraint (kind-max (app dict-count 0) kind) bound reason) (unless (contract-kind<= kind bound) - (raise (exn:fail:constraint-failure "Violated constraint ~a" (current-continuation-marks))))]))])) + (raise (exn:fail:constraint-failure + (format "Violated constraint: ~a" reason) + (current-continuation-marks) + reason)))]))])) 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 0779c061..d2d14f75 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 @@ -16,7 +16,9 @@ (provide (c:contract-out - [instantiate ((static-contract? (c:-> c:none/c)) (contract-kind?) . c:->* . syntax?)])) + [instantiate + (c:parametric->/c (a) ((static-contract? (c:-> #:reason (c:or/c #f string?) a)) + (contract-kind?) . c:->* . (c:or/c a syntax?)))])) ;; Providing these so that tests can work directly with them. (module* internals #f @@ -27,7 +29,8 @@ ;; kind is the greatest kind of contract that is supported, if a greater kind would be produced the ;; fail procedure is called. (define (instantiate sc fail [kind 'impersonator]) - (with-handlers [(exn:fail:constraint-failure? (lambda (exn) (fail)))] + (with-handlers [(exn:fail:constraint-failure? + (lambda (exn) (fail #:reason (exn:fail:constraint-failure-reason exn))))] (instantiate/inner sc (compute-recursive-kinds (contract-restrict-recursive-values (compute-constraints sc kind)))))) @@ -40,7 +43,7 @@ [(? sc?) (sc->constraints sc recur)])) (define constraints (recur sc)) - (validate-constraints (add-constraint constraints max-kind)) + (validate-constraints (add-constraint constraints max-kind "reason4")) constraints) @@ -64,7 +67,7 @@ (for/hash (((name var) vars)) (values name (hash-ref var-values var)))) - + (define (instantiate/inner sc recursive-kinds) (define (recur sc) (match sc 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 a01d89cd..84fd09ae 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 @@ -72,10 +72,9 @@ (t (-poly (a) (-lst a))) (t (-poly (a) (-vec a))) - #| (t/fail ((-poly (a) (-vec a)) . -> . -Symbol) - "some error") - + "cannot generate contract for non-function") + #| (t/fail (make-Function (list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f)))