From 8c66be33e79c4326960efecb00c79a0f41c67a0b Mon Sep 17 00:00:00 2001 From: Vincent St-Amour Date: Mon, 17 Dec 2012 13:53:21 -0500 Subject: [PATCH] Fix contract generation for functions with optionals and keyword arguments. Closes PR13354. --- .../succeed/arrow-star-contracts.rkt | 120 ++++++++++++++++++ .../typed-racket/private/type-contract.rkt | 14 +- 2 files changed, 128 insertions(+), 6 deletions(-) create mode 100644 collects/tests/typed-racket/succeed/arrow-star-contracts.rkt diff --git a/collects/tests/typed-racket/succeed/arrow-star-contracts.rkt b/collects/tests/typed-racket/succeed/arrow-star-contracts.rkt new file mode 100644 index 0000000000..a81faeeb7c --- /dev/null +++ b/collects/tests/typed-racket/succeed/arrow-star-contracts.rkt @@ -0,0 +1,120 @@ +#lang racket/base + +(require typed/rackunit) + +(module defs typed/racket/base + (provide (all-defined-out)) + + (: foo0k (case-> ([#:kw Real] -> Real))) + (define (foo0k #:kw [kw 0]) + kw) + + (: foo01k (case-> ([#:kw Real] -> Real) + (Real [#:kw Real] -> Real))) + (define (foo01k [x 0] #:kw [kw 0]) + (+ x kw)) + + (: foo012k (case-> ([#:kw Real] -> Real) + (Real [#:kw Real] -> Real) + (Real Real [#:kw Real] -> Real))) + (define (foo012k [x 0] [y 0] #:kw [kw 0]) + (+ x y kw)) + + (: foo12k (case-> (Real [#:kw Real] -> Real) + (Real Real [#:kw Real] -> Real))) + (define (foo12k x [y 0] #:kw [kw 0]) + (+ x y kw)) + + (: foo123k (case-> (Real [#:kw Real] -> Real) + (Real Real [#:kw Real] -> Real) + (Real Real Real [#:kw Real] -> Real))) + (define (foo123k x [y 0] [z 0] #:kw [kw 0]) + (+ x y z kw)) + + (: foo23k (case-> (Real Real [#:kw Real] -> Real) + (Real Real Real [#:kw Real] -> Real))) + (define (foo23k x y [z 0] #:kw [kw 0]) + (+ x y z kw)) + + (: foo234k (case-> (Real Real [#:kw Real] -> Real) + (Real Real Real [#:kw Real] -> Real) + (Real Real Real Real [#:kw Real] -> Real))) + (define (foo234k x y [z 0] [w 0] #:kw [kw 0]) + (+ x y z w kw)) + ) + +(require 'defs) + +(void foo0k) +(void foo01k) +(void foo12k) + +(check-equal? (foo0k) 0) +(check-exn exn:fail:contract? (λ () (foo0k 1))) +(check-equal? (foo0k #:kw 10) 10) +(check-exn exn:fail:contract? (λ () (foo0k 1 #:kw 10))) + +(check-equal? (foo01k) 0) +(check-equal? (foo01k 1) 1) +(check-exn exn:fail:contract? (λ () (foo01k 1 1))) +(check-equal? (foo01k #:kw 10) 10) +(check-equal? (foo01k 1 #:kw 10) 11) +(check-exn exn:fail:contract? (λ () (foo01k 1 1 #:kw 10))) + +(check-exn exn:fail:contract? (λ () (foo12k))) +(check-equal? (foo12k 1) 1) +(check-equal? (foo12k 1 1) 2) +(check-exn exn:fail:contract? (λ () (foo12k 1 1 1))) +(check-exn exn:fail:contract? (λ () (foo12k #:kw 10))) +(check-equal? (foo12k 1 #:kw 10) 11) +(check-equal? (foo12k 1 1 #:kw 10) 12) +(check-exn exn:fail:contract? (λ () (foo12k 1 1 1 #:kw 10))) + +(void foo012k) +(void foo123k) +(void foo23k) +(void foo234k) + +(check-equal? (foo012k) 0) +(check-equal? (foo012k 1) 1) +(check-equal? (foo012k 1 1) 2) +(check-exn exn:fail:contract? (λ () (foo012k 1 1 1))) +(check-equal? (foo012k #:kw 10) 10) +(check-equal? (foo012k 1 #:kw 10) 11) +(check-equal? (foo012k 1 1 #:kw 10) 12) +(check-exn exn:fail:contract? (λ () (foo012k 1 1 1 #:kw 10))) + +(check-exn exn:fail:contract? (λ () (foo123k))) +(check-equal? (foo123k 1) 1) +(check-equal? (foo123k 1 1) 2) +(check-equal? (foo123k 1 1 1) 3) +(check-exn exn:fail:contract? (λ () (foo123k 1 1 1 1))) +(check-exn exn:fail:contract? (λ () (foo123k #:kw 10))) +(check-equal? (foo123k 1 #:kw 10) 11) +(check-equal? (foo123k 1 1 #:kw 10) 12) +(check-equal? (foo123k 1 1 1 #:kw 10) 13) +(check-exn exn:fail:contract? (λ () (foo123k 1 1 1 1 #:kw 10))) + +(check-exn exn:fail:contract? (λ () (foo23k))) +(check-exn exn:fail:contract? (λ () (foo23k 1))) +(check-equal? (foo23k 1 1) 2) +(check-equal? (foo23k 1 1 1) 3) +(check-exn exn:fail:contract? (λ () (foo23k 1 1 1 1))) +(check-exn exn:fail:contract? (λ () (foo23k #:kw 10))) +(check-exn exn:fail:contract? (λ () (foo23k 1 #:kw 10))) +(check-equal? (foo23k 1 1 #:kw 10) 12) +(check-equal? (foo23k 1 1 1 #:kw 10) 13) +(check-exn exn:fail:contract? (λ () (foo23k 1 1 1 1 #:kw 10))) + +(check-exn exn:fail:contract? (λ () (foo234k))) +(check-exn exn:fail:contract? (λ () (foo234k 1))) +(check-equal? (foo234k 1 1) 2) +(check-equal? (foo234k 1 1 1) 3) +(check-equal? (foo234k 1 1 1 1) 4) +(check-exn exn:fail:contract? (λ () (foo234k 1 1 1 1 1))) +(check-exn exn:fail:contract? (λ () (foo234k #:kw 10))) +(check-exn exn:fail:contract? (λ () (foo234k 1 #:kw 10))) +(check-equal? (foo234k 1 1 #:kw 10) 12) +(check-equal? (foo234k 1 1 1 #:kw 10) 13) +(check-equal? (foo234k 1 1 1 1 #:kw 10) 14) +(check-exn exn:fail:contract? (λ () (foo234k 1 1 1 1 1 #:kw 10))) diff --git a/collects/typed-racket/private/type-contract.rkt b/collects/typed-racket/private/type-contract.rkt index 7231411976..383e3af746 100644 --- a/collects/typed-racket/private/type-contract.rkt +++ b/collects/typed-racket/private/type-contract.rkt @@ -153,15 +153,17 @@ [(and (> (length arrs) 1) ;; Keyword args, range and rest specs all the same. - (let ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws) - (list rng rest-spec kws)]) - arrs)]) - (foldl equal? (first xs) (rest xs))) + (let* ([xs (map (match-lambda [(arr: _ rng rest-spec _ kws) + (list rng rest-spec kws)]) + arrs)] + [first-x (first xs)]) + (for/and ([x (in-list (rest xs))]) + (equal? x first-x))) ;; Positionals are monotonically increasing by at most one. (let-values ([(_ ok?) - (for/fold ([positionals '()] + (for/fold ([positionals (arr-dom (first arrs))] [ok-so-far? #t]) - ([arr (in-list arrs)]) + ([arr (in-list (rest arrs))]) (match arr [(arr: dom _ _ _ _) (define ldom (length dom))