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

Fix ->* pre/desc and post/desc handling.

Browse Source
This commit is contained in:
Vincent St-Amour 2016-04-11 17:12:23 -05:00
parent ee43151154
commit f33a4ba471
3 changed files with 35 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

16
pkgs/racket-test/tests/racket/contract/arrow-star.rkt
View File

@ -698,6 +698,22 @@
(regexp-match #rx"\n *something horrible\n"
(exn-message x)))))
(test/neg-blame
'->*pre/post-18
'((contract (->* (any/c) #:pre/desc #f any)
(lambda (x) x)
'pos 'neg)
2))
(test/neg-blame
'->*pre/post-19
'(let ()
(struct posn (x y))
((contract (->* (any/c) #:pre/desc #f boolean?)
posn?
'pos 'neg)
2)))
(test/spec-passed
'->*-opt-optional1
'((contract (->* () integer?) (lambda () 1) 'pos 'neg)))

6
pkgs/racket-test/tests/racket/contract/name.rkt
View File

@ -91,6 +91,12 @@
(->* (integer?) () integer? #:post #f))
(test-name '(->* (integer?) #:pre ... integer? #:post ...)
(->* (integer?) () #:pre (= 1 2) integer? #:post #f))
(test-name '(->* (integer?) #:pre/desc ... integer?)
(->* (integer?) () #:pre/desc (= 1 2) integer?))
(test-name '(->* (integer?) integer? #:post/desc ...)
(->* (integer?) () integer? #:post/desc #f))
(test-name '(->* (integer?) #:pre/desc ... integer? #:post/desc ...)
(->* (integer?) () #:pre/desc (= 1 2) integer? #:post/desc #f))
(test-name '(->d () () any) (->d () () any))
(test-name '(->d ([x ...] #:y [y ...]) ([z ...] #:w [w ...]) any)

22
racket/collects/racket/contract/private/arrow-val-first.rkt
View File

@ -876,14 +876,14 @@
'(optional-dom-kwd ...)
(list optional-dom-kwd-ctc ...)
#,rest-ctc
#,(and pre #t)
#,(cond [pre #''pre] [pre/desc #''pre/desc] [else #'#f])
#,(if rng-ctcs
#`(list #,@(for/list ([rng-ctc (in-list (syntax->list rng-ctcs))])
(syntax-property rng-ctc
'racket/contract:positive-position
this->*)))
#'#f)
#,(and post #t)
#,(cond [post #''post] [post/desc #''post/desc] [else #'#f])
#,plus-one-arity-function
#,chaperone-constructor
#,method?))
@ -1165,9 +1165,9 @@
;; includes optional arguments in list @ end
;; kwd-infos : (listof kwd-info)
;; rest : (or/c #f contract?)
;; pre? : boolean?
;; pre? : (or/c #f 'pre 'pre/desc)
;; rngs : (listof contract?)
;; post? : boolean?
;; post? : (or/c #f 'post 'post/desc)
;; plus-one-arity-function : procedure? -- special, +1 argument wrapper that accepts neg-party
;; chaperone-constructor ; procedure? -- function that builds a projection tailored to this arrow
;; method? : boolean?
@ -1346,13 +1346,15 @@
,@(if (base->-rest ctc)
(list '#:rest (contract-name (base->-rest ctc)))
(list))
,@(if (base->-pre? ctc)
(list '#:pre '...)
(list))
,@(case (base->-pre? ctc)
[(pre) (list '#:pre '...)]
[(pre/desc) (list '#:pre/desc '...)]
[(#f) (list)])
,rng-sexp
,@(if (base->-post? ctc)
(list '#:post '...)
(list)))])]))
,@(case (base->-post? ctc)
[(post) (list '#:post '...)]
[(post/desc) (list '#:post/desc '...)]
[(#f) (list)]))])]))
(define ((->-first-order ctc) x)
(define l (base->-min-arity ctc))