From b3fc8b56673badcc9c0af2f9e7221cef04aaadbb Mon Sep 17 00:00:00 2001 From: Eric Dobson Date: Thu, 2 Jan 2014 20:47:25 -0800 Subject: [PATCH] Make contract generation failure tests pass, and simplify reason logic. original commit: f17f6655dd2400ffb91e1116513db4ce2056b743 --- .../static-contracts/combinators/struct.rkt | 6 +--- .../combinators/structural.rkt | 12 ++------ .../static-contracts/constraints.rkt | 28 +++++++++++-------- .../static-contracts/instantiate.rkt | 8 +----- .../unit-tests/contract-tests.rkt | 11 ++++---- .../static-contract-conversion-tests.rkt | 6 ++-- 6 files changed, 30 insertions(+), 41 deletions(-) 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 fdd00a44..f4db52b3 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 @@ -33,11 +33,7 @@ [(struct-combinator args _ mut?) (merge-restricts* (if mut? 'chaperone 'flat) - (map (lambda (a) (if mut? - (add-constraint (f a) 'chaperone - (λ (actual-kind) (error "How is this triggered"))) - (f a))) - args))]))]) + (map (lambda (a) (if (not mut?) (add-constraint (f a) 'chaperone) (f a))) args))]))]) (define (struct/sc name mut? fields) (struct-combinator fields name mut?)) 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 7f69c913..fcd58326 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 @@ -49,11 +49,7 @@ #'(lambda (v recur) (for/list ([arg (in-list (combinator-args v))] [kind (in-list (list 'pos.category-stx ...))]) - (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"))))) + (add-constraint (recur arg) kind))) #:attr combinator2 #'(λ (constructor) (λ (pos.name ...) (constructor (list pos.name ...)))) #:with matcher @@ -78,11 +74,7 @@ #:with ->restricts #'(lambda (v recur) (for/list ([arg (in-list (combinator-args v))]) - (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"))))) + (add-constraint (recur arg) 'rest.category-stx))) #: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 7889de31..bd543879 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? string? -> contract-restrict +;; add-constraint: contract-restrict? kind? -> 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? @@ -38,6 +38,7 @@ (require racket/match racket/list + racket/format racket/contract racket/dict racket/set @@ -55,8 +56,7 @@ [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? (contract-kind? . -> . string?) . -> . contract-restrict?)]) + [add-constraint (contract-restrict? contract-kind? . -> . contract-restrict?)]) contract-restrict-recursive-values contract-restrict? @@ -69,15 +69,13 @@ "kinds.rkt") (provide (contract-out - [struct constraint ([value kind-max?] - [max contract-kind?] - [reason (contract-kind? . -> . string?)])] + [struct constraint ([value kind-max?] [max contract-kind?])] [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 reason) #:transparent) + (struct constraint (value max) #:transparent) (struct kind-max (variables max) #:transparent) (struct contract-restrict (value recursive-values constraints) #:transparent)) (require 'structs) @@ -107,13 +105,20 @@ (define (variable-contract-restrict var) (contract-restrict (kind-max (free-id-set var) 'flat) (make-immutable-free-id-table) (set))) +(define (reason-string actual bound) + (define (name k) + (case k + [(flat chaperone) (~a "a " k " contract")] + [(impersonator) "an impersonator contract"])) + (~a "required " (name bound) " but generated " (name actual))) -(define (add-constraint cr max reason) + +(define (add-constraint cr max) (if (equal? 'impersonator max) cr (match cr [(contract-restrict v rec constraints) - (contract-restrict v rec (set-add constraints (constraint v max reason)))]))) + (contract-restrict v rec (set-add constraints (constraint v max)))]))) (define (add-recursive-values cr dict) (match cr @@ -184,10 +189,11 @@ [(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 reason) + [(constraint (kind-max (app dict-count 0) kind) bound) (unless (contract-kind<= kind bound) + (define reason (reason-string kind bound)) (raise (exn:fail:constraint-failure (format "Violated constraint: ~a" reason) (current-continuation-marks) - (reason kind))))]))])) + 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 65bebdb8..072bd029 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,13 +43,7 @@ [(? sc?) (sc->constraints sc recur)])) (define constraints (recur sc)) - (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)))) + (validate-constraints (add-constraint constraints max-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 6776bc6a..804ffa19 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,7 +36,6 @@ (fail-check "Reason didn't match expected."))))))) -;; These will fail when the bug is fixed. (define known-bugs (test-suite "Known Bugs" @@ -73,7 +72,7 @@ (t (-poly (a) (-vec a))) (t/fail ((-poly (a) (-vec a)) . -> . -Symbol) - "cannot generate contract for non-function") + "cannot generate contract for non-function polymorphic type") (t/fail (make-Function (list (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #f))) @@ -88,11 +87,11 @@ (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 flat contract but could only generate a chaperone contract") + "required a flat contract but generated a chaperone contract") (t/fail (-Syntax (-seq -Boolean)) - #rx"required a flat contract but could only generate a impersonator contract") + "required a flat contract but generated an impersonator contract") (t/fail (-set (-seq -Boolean)) - #rx"required a chaperone contract but could only generate a impersonator contract") + "required a chaperone contract but generated an impersonator contract") (t/fail (make-Function @@ -100,5 +99,7 @@ (make-arr* (list) -Boolean #:kws (list (make-Keyword '#:key Univ #t))) (make-arr* (list Univ Univ) -Boolean #:kws (list (make-Keyword '#:key2 Univ #t))))) "case function type with optional keyword arguments") + (t/fail (-vec (-struct #'struct-name #f (list (make-fld (-seq -Symbol) #'acc #f)) #f #t)) + "required a chaperone contract but generated an impersonator contract") )) diff --git a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt index 50ebc7a7..2b5639a7 100644 --- a/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt +++ b/pkgs/typed-racket-pkgs/typed-racket-test/tests/typed-racket/unit-tests/static-contract-conversion-tests.rkt @@ -24,12 +24,12 @@ ['location (build-source-location-list (quote-srcloc e))]) (phase1-phase0-eval (define sc - (type->static-contract e (lambda _ #f))) + (type->static-contract e (lambda (#:reason _) #f))) (if sc #`(with-check-info (['static '#,sc]) (phase1-phase0-eval (define ctc (instantiate '#,sc - (lambda _ (error "static-contract could not be converted to a contract")))) + (lambda (#:reason _) (error "static-contract could not be converted to a contract")))) #,#'#`(with-check-info (['contract '#,ctc]) (define runtime-contract #,ctc) (check-pred contract? runtime-contract)))) @@ -42,7 +42,7 @@ (define sc (phase1-phase0-eval (let/ec exit - #`'#,(type->static-contract e (lambda _ (exit #'#f)) #:typed-side typed-side)))) + #`'#,(type->static-contract e (lambda (#:reason _) (exit #'#f)) #:typed-side typed-side)))) (when sc (with-check-info (['static sc]) (fail-check "Type was incorrectly converted to contract"))))]))