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

@ -697,6 +697,22 @@
(and (exn:fail:contract? x) (and (exn:fail:contract? x)
(regexp-match #rx"\n *something horrible\n" (regexp-match #rx"\n *something horrible\n"
(exn-message x))))) (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 (test/spec-passed
'->*-opt-optional1 '->*-opt-optional1

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

@ -91,6 +91,12 @@
(->* (integer?) () integer? #:post #f)) (->* (integer?) () integer? #:post #f))
(test-name '(->* (integer?) #:pre ... integer? #:post ...) (test-name '(->* (integer?) #:pre ... integer? #:post ...)
(->* (integer?) () #:pre (= 1 2) integer? #:post #f)) (->* (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 () () any) (->d () () any))
(test-name '(->d ([x ...] #:y [y ...]) ([z ...] #:w [w ...]) any) (test-name '(->d ([x ...] #:y [y ...]) ([z ...] #:w [w ...]) any)
@ -496,4 +502,4 @@
[x-val x] [x-val x]
[y-val y] [y-val y]
and and
(= x-val y-val))))) (= x-val y-val)))))

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

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