suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

fixes a bug in case->, closes #3098

Browse Source 
also use the contract equivalence predicate instead of
two calls to contract stronger
This commit is contained in:
Robby Findler 2020-04-09 15:35:36 -05:00
parent 99af295d99
commit 7f9784775f
2 changed files with 20 additions and 7 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
pkgs/racket-test/tests/racket/contract/case-arrow.rkt
View File

@ -182,6 +182,19 @@
[(x) 1])
'pos 'neg)
1))
(test/spec-passed/result
'contract->case->16
'((contract
(case-> (-> #f any)
(-> #t #f any/c))
(case-lambda
[(x) x]
[(y z) z])
'pos
'neg)
#f)
#f)
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
@ -192,4 +205,4 @@
(test/well-formed '(case-> (-> integer? integer?)))
(test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? integer?)))
(test/well-formed '(case-> (-> integer? integer?) (-> integer? integer? any)))
(test/well-formed '(case-> (-> integer? any) (-> integer? integer? any))))
(test/well-formed '(case-> (-> integer? any) (-> integer? integer? any))))

12
racket/collects/racket/contract/private/case-arrow.rkt
View File

@ -191,8 +191,8 @@
"expected no keywords, got keyword ~a" (car kwds))))
;; dom-ctcs : (listof (listof contract))
;; rst-ctcs : (listof contract)
;; rng-ctcs : (listof (listof contract))
;; rst-ctcs : (listof (or/c #f contract))
;; rng-ctcs : (listof (or/c #f (listof contract)))
;; specs : (listof (list boolean exact-positive-integer))
;; indicates the required arities of the input functions
;; mctc? : was created with case->m or object-contract
@ -334,7 +334,7 @@
#:when x)
(append acc x)))
;; Takes a list of (listof projection), and returns one of the
;; Takes a list of (or/c #f (listof projection)), and returns one of the
;; lists if all the lists contain the same projections. If the list is
;; null, it returns #f.
(define (same-range-contracts rng-ctcss)
@ -342,11 +342,11 @@
[(null? rng-ctcss) #f]
[else
(define fst (car rng-ctcss))
(and (for/and ([ps (in-list (cdr rng-ctcss))])
(and fst
(for/and ([ps (in-list (cdr rng-ctcss))])
(and ps
(= (length fst) (length ps))
(for/and ([c (in-list ps)]
[fst-c (in-list fst)])
(and (contract-struct-stronger? c fst-c)
(contract-struct-stronger? fst-c c)))))
(contract-struct-equivalent? c fst-c))))
fst)]))