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

remove the code duplication in opt/c

Browse Source 
The code duplication was there only to support
constructing the name for the optimized contract;
instead we actually just built the name as we go
(the old version actually built the old contract
 and then used that to get the name)

also:
 - racket/contract/base now requires basic-opters.rkt
   so all of the opters are registered when racket/contract/base
   is loaded, not just the non-basic ones
 - fix the ordering of the names of subcontracts in or/c
 - make opt-contracts print a more meaningful name
This commit is contained in:
Robby Findler 2013-04-08 22:51:35 -05:00
parent 436d9f25f9
commit caad82f91e
10 changed files with 179 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
collects/racket/contract.rkt
View File

@ -3,7 +3,6 @@
"contract/combinator.rkt"
"contract/parametric.rkt"
"contract/region.rkt"
"contract/private/basic-opters.rkt"
"contract/private/legacy.rkt"
"contract/private/ds.rkt"
"contract/private/generate.rkt")

1
collects/racket/contract/base.rkt
View File

@ -12,6 +12,7 @@
"private/provide.rkt"
"private/guts.rkt"
"private/opters.rkt" ;; required for effect to install the opters
"private/basic-opters.rkt" ;; required for effect to install the opters
"private/opt.rkt"
"private/out.rkt")

13
collects/racket/contract/private/basic-opters.rkt
View File

@ -10,7 +10,7 @@
;;
;; opt/pred helper
;;
(define-for-syntax (opt/pred opt/info pred)
(define-for-syntax (opt/pred opt/info pred #:name [name (syntax-e pred)])
(with-syntax ((pred pred))
(build-optres
#:exp
@ -26,7 +26,8 @@
#:flat (syntax (pred val))
#:opt #f
#:stronger-ribs null
#:chaperone #t)))
#:chaperone #t
#:name #`'#,name)))
(define (raise-opt/pred-error blame val pred-name)
(raise-blame-error
@ -61,12 +62,13 @@
#:flat #'#t
#:opt #f
#:stronger-ribs null
#:chaperone #t)]))
#:chaperone #t
#:name #''any/c)]))
;;
;; false/c
;;
(define/opter (false/c opt/i opt/info stx) (opt/pred opt/info #'not))
(define/opter (false/c opt/i opt/info stx) (opt/pred opt/info #'not #:name '#f))
;;
;; flat-contract helper
@ -106,7 +108,8 @@
#:flat (syntax (lift-pred val))
#:opt #f
#:stronger-ribs null
#:chaperone #t)))]))
#:chaperone #t
#:name #'(object-name lift-pred))))]))
;;
;; flat-contract and friends

22
collects/racket/contract/private/ds-helpers.rkt
View File

@ -177,13 +177,20 @@ which are then called when the contract's fields are explored
[maker-args '()]
[lifts-ps '()]
[superlifts-ps '()]
[stronger-ribs-ps '()])
[stronger-ribs-ps '()]
[any-deps? #f]
[names '()])
(cond
[(null? clauses)
(values (reverse maker-args)
lifts-ps
superlifts-ps
stronger-ribs-ps)]
stronger-ribs-ps
(if any-deps? ;; the else branch here is an ugly hack
#`(list '#,name #,@(reverse names))
#`(list '#,(string->symbol (regexp-replace #rx"/dc$" (symbol->string name) "/c"))
#,@(map (λ (x) #`(cadr #,x))
(reverse names)))))]
[else
(let ([clause (car clauses)]
[let-var (car let-vars)]
@ -217,7 +224,10 @@ which are then called when the contract's fields are explored
(cons maker-arg maker-args)
lifts-ps
superlifts-ps
stronger-ribs-ps))]
stronger-ribs-ps
#t
(cons #`(list 'id '(... ...))
names)))]
[(id (x ...) ctc-exp)
(begin
(unless (identifier? (syntax id))
@ -242,7 +252,11 @@ which are then called when the contract's fields are explored
(cons maker-arg maker-args)
(append lifts-ps (optres-lifts an-optres))
(append superlifts-ps (optres-superlifts an-optres))
(append stronger-ribs-ps (optres-stronger-ribs an-optres))))]
(append stronger-ribs-ps (optres-stronger-ribs an-optres))
any-deps?
(cons
#`(list 'id #,(optres-name an-optres))
names)))]
[(id ctc-exp)
(raise-syntax-error name "expected identifier" stx (syntax id))]))]))))

10
collects/racket/contract/private/ds.rkt
View File

@ -354,7 +354,7 @@ it around flattened out.
(cdr free-vars))])))
(let*-values ([(inner-val) #'val]
[(clauses lifts superlifts stronger-ribs)
[(clauses lifts superlifts stronger-ribs names)
(build-enforcer-clauses opt/i
(opt/info-change-val inner-val opt/info)
name
@ -379,7 +379,8 @@ it around flattened out.
(values f-x ...)))))
lifts
superlifts
stronger-ribs))))
stronger-ribs
names))))
;;
;; struct/dc opter
@ -391,7 +392,7 @@ it around flattened out.
(helper-id-var (car (generate-temporaries (syntax (helper)))))
(contract/info-var (car (generate-temporaries (syntax (contract/info)))))
(id-var (car (generate-temporaries (syntax (id))))))
(let-values ([(enforcer lifts superlifts stronger-ribs)
(let-values ([(enforcer lifts superlifts stronger-ribs names)
(build-enforcer opt/i
opt/info
'struct/dc
@ -470,7 +471,8 @@ it around flattened out.
#:flat #f
#:opt #f
#:stronger-ribs stronger-ribs
#:chaperone #f)))))))])))))))
#:chaperone #f
#:name names)))))))])))))))
(define-syntax (define-contract-struct stx)
(syntax-case stx ()

41
collects/racket/contract/private/misc.rkt
View File

@ -106,8 +106,8 @@
(case-lambda
[() (make-none/c '(or/c))]
[raw-args
(let ([args (coerce-contracts 'or/c raw-args)])
(let-values ([(ho-contracts flat-contracts)
(define args (coerce-contracts 'or/c raw-args))
(define-values (ho-contracts flat-contracts)
(let loop ([ho-contracts '()]
[flat-contracts '()]
[args args])
@ -119,8 +119,8 @@
[(flat-contract? arg)
(loop ho-contracts (cons arg flat-contracts) (cdr args))]
[else
(loop (cons arg ho-contracts) flat-contracts (cdr args))]))]))])
(let ([pred
(loop (cons arg ho-contracts) flat-contracts (cdr args))]))])))
(define pred
(cond
[(null? flat-contracts) not]
[else
@ -131,18 +131,21 @@
[(null? rst) fst-pred]
[else
(let ([r (loop (car rst) (cdr rst))])
(λ (x) (or (fst-pred x) (r x))))])))])])
(λ (x) (or (fst-pred x) (r x))))])))]))
(cond
[(null? ho-contracts)
(make-flat-or/c pred flat-contracts)]
[(null? (cdr ho-contracts))
(define name (apply build-compound-type-name 'or/c args))
(if (chaperone-contract? (car ho-contracts))
(make-chaperone-single-or/c pred flat-contracts (car ho-contracts))
(make-impersonator-single-or/c pred flat-contracts (car ho-contracts)))]
(make-chaperone-single-or/c name pred flat-contracts (car ho-contracts))
(make-impersonator-single-or/c name pred flat-contracts (car ho-contracts)))]
[else
(define name (apply build-compound-type-name 'or/c args))
(if (andmap chaperone-contract? ho-contracts)
(make-chaperone-multi-or/c flat-contracts ho-contracts)
(make-impersonator-multi-or/c flat-contracts ho-contracts))]))))]))
(make-chaperone-multi-or/c name flat-contracts ho-contracts)
(make-impersonator-multi-or/c name flat-contracts ho-contracts))])]))
(define (single-or/c-projection ctc)
(let ([c-proc (contract-projection (single-or/c-ho-ctc ctc))]
@ -155,12 +158,6 @@
[(pred val) val]
[else (partial-contract val)])))))
(define (single-or/c-name ctc)
(apply build-compound-type-name
'or/c
(single-or/c-ho-ctc ctc)
(single-or/c-flat-ctcs ctc)))
(define (single-or/c-first-order ctc)
(let ([pred (single-or/c-pred ctc)]
[ho (contract-first-order (single-or/c-ho-ctc ctc))])
@ -177,7 +174,7 @@
this-ctcs
that-ctcs)))))
(define-struct single-or/c (pred flat-ctcs ho-ctc))
(define-struct single-or/c (name pred flat-ctcs ho-ctc))
(define-struct (chaperone-single-or/c single-or/c) ()
#:property prop:chaperone-contract
@ -242,13 +239,6 @@
candidate-proc
candidate-contract)]))])))))
(define (multi-or/c-name ctc)
(apply build-compound-type-name
'or/c
(append
(multi-or/c-flat-ctcs ctc)
(reverse (multi-or/c-ho-ctcs ctc)))))
(define (multi-or/c-first-order ctc)
(let ([flats (map flat-contract-predicate (multi-or/c-flat-ctcs ctc))]
[hos (map (λ (x) (contract-first-order x)) (multi-or/c-ho-ctcs ctc))])
@ -267,7 +257,7 @@
(and (= (length this-ctcs) (length that-ctcs))
(andmap contract-stronger? this-ctcs that-ctcs)))))
(define-struct multi-or/c (flat-ctcs ho-ctcs))
(define-struct multi-or/c (name flat-ctcs ho-ctcs))
(define-struct (chaperone-multi-or/c multi-or/c) ()
#:property prop:chaperone-contract
@ -328,8 +318,7 @@
#:generate
(λ (ctc)
(λ (fuel)
(generate/direct (oneof (flat-or/c-flat-ctcs ctc)) fuel)))
))
(generate/direct (oneof (flat-or/c-flat-ctcs ctc)) fuel)))))
(define (and-name ctc)

17
collects/racket/contract/private/opt-guts.rkt
View File

@ -33,6 +33,7 @@
optres-stronger-ribs
optres-chaperone
optres-no-negative-blame?
optres-name
build-optres
combine-two-chaperone?s
@ -40,9 +41,9 @@
;; (define/opter (<contract-combinator> opt/i opt/info stx) body)
;;
;; An opter is to a function with the following signature:
;; An opter is a function with the following signature:
;;
;; opter : (syntax opt/info -> <opter-results>) opt/info list-of-ids -> opt-res
;; opter : (syntax opt/info -> optres) opt/info list-of-ids -> optres
;;
;; The first argument can be used to recursively process sub-contracts
;; It returns what an opter returns and its results should be accumulated
@ -90,7 +91,8 @@
opt
stronger-ribs
chaperone
no-negative-blame?))
no-negative-blame?
name))
(define (build-optres #:exp exp
#:lifts lifts
#:superlifts superlifts
@ -99,7 +101,8 @@
#:opt opt
#:stronger-ribs stronger-ribs
#:chaperone chaperone
#:no-negative-blame? [no-negative-blame? (syntax? flat)])
#:no-negative-blame? [no-negative-blame? (syntax? flat)]
#:name [name #''unknown-name])
(optres exp
lifts
superlifts
@ -108,7 +111,8 @@
opt
stronger-ribs
chaperone
no-negative-blame?))
no-negative-blame?
name))
;; a hash table of opters
(define opters-table
@ -274,7 +278,8 @@
#:flat #f
#:opt #'lift-var
#:stronger-ribs null
#:chaperone #'(chaperone-contract? lift-var))))
#:chaperone #'(chaperone-contract? lift-var)
#:name #'(contract-name lift-var))))
;; combine-two-chaperone?s : (or/c boolean? syntax?) (or/c boolean? syntax?) -> (or/c boolean? syntax?)
(define (combine-two-chaperone?s chaperone-a? chaperone-b?)

14
collects/racket/contract/private/opt.rkt
View File

@ -94,7 +94,8 @@
#:flat predicate
#:opt #f
#:stronger-ribs null
#:chaperone #t))
#:chaperone #t
#:name #`'#,konst))
(define (opt-constant-contract-failure blame val compare should-be)
(raise-blame-error blame val '(expected "a value ~a to ~e") compare should-be))
@ -185,7 +186,7 @@
#,(bind-superlifts
(optres-partials an-optres)
#`(λ (val) #,(optres-exp an-optres)))))
(λ () e)
#,(optres-name an-optres)
(λ (this that) #f)
(vector)
(begin-lifted (box #f))
@ -202,8 +203,7 @@
[else
(define info (make-opt/info #'ctc #'val #'blame #f '() #f #f #'this #'that))
(define an-optres (opt/i info #'e))
#`(let ([ctc e] ;;; hm... what to do about this?!
[val val-e]
#`(let ([val val-e]
[blame blame-e])
#,(bind-superlifts
(optres-superlifts an-optres)
@ -292,13 +292,13 @@
;; the stronger-vars don't seem to be used anymore for stronger; probably
;; they should be folded into the lifts and then there should be a separate
;; setup for consolidating stronger checks
(define-struct opt-contract (proj orig-ctc stronger stronger-vars stamp chaperone?)
#:property orig-ctc-prop (λ (ctc) ((opt-contract-orig-ctc ctc)))
(define-struct opt-contract (proj name stronger stronger-vars stamp chaperone?)
#:property prop:opt-chaperone-contract (λ (ctc) (opt-contract-chaperone? ctc))
#:property prop:custom-write (λ (val port mode) (fprintf port "#<opt-contract: ~.s>" (opt-contract-name val)))
#:property prop:contract
(build-contract-property
#:projection (λ (ctc) ((opt-contract-proj ctc) ctc))
#:name (λ (ctc) (contract-name ((orig-ctc-get ctc) ctc)))
#:name (λ (ctc) (opt-contract-name ctc))
#:stronger
(λ (this that)
(and (opt-contract? that)

124
collects/racket/contract/private/opters.rkt
View File

@ -20,7 +20,6 @@
(val (opt/info-val opt/info)))
(syntax (partial-var val)))
(list (cons lift-var
;; FIXME needs to get the contract name somehow
(with-syntax ((uctc uctc))
(syntax (coerce-contract 'opt/c uctc)))))
'()
@ -28,13 +27,15 @@
partial-var
(with-syntax ((lift-var lift-var)
(blame (opt/info-blame opt/info)))
(syntax ((contract-projection lift-var) blame))))))))
(syntax ((contract-projection lift-var) blame)))))
#`(contract-name #,lift-var))))
(define (opt/or-ctc ps)
(define lift-from-hos null)
(define superlift-from-hos null)
(define partial-from-hos null)
(define-values (opt-ps lift-ps superlift-ps partial-ps stronger-ribs hos ho-ctc chaperone? no-negative-blame)
(define name-from-hos #f)
(define-values (opt-ps lift-ps superlift-ps partial-ps stronger-ribs hos ho-ctc chaperone? no-negative-blame names)
(let loop ([ps ps]
[next-ps null]
[lift-ps null]
@ -44,7 +45,8 @@
[hos null]
[ho-ctc #f]
[chaperone? #t]
[no-negative-blame #t])
[no-negative-blame #t]
[names '()])
(cond
[(null? ps) (values next-ps
lift-ps
@ -54,7 +56,8 @@
(reverse hos)
ho-ctc
chaperone?
no-negative-blame)]
no-negative-blame
(reverse names))]
[else
(define ps-optres (opt/i opt/info (car ps)))
(if (optres-flat ps-optres)
@ -67,7 +70,8 @@
hos
ho-ctc
(combine-two-chaperone?s chaperone? (optres-chaperone ps-optres))
(combine-two-no-negative-blame no-negative-blame (optres-no-negative-blame? ps-optres)))
(combine-two-no-negative-blame no-negative-blame (optres-no-negative-blame? ps-optres))
(cons (optres-name ps-optres) names))
(if (null? hos)
(loop (cdr ps)
next-ps
@ -78,7 +82,8 @@
(cons (car ps) hos)
(optres-exp ps-optres)
(combine-two-chaperone?s chaperone? (optres-chaperone ps-optres))
(combine-two-no-negative-blame no-negative-blame (optres-no-negative-blame? ps-optres)))
(combine-two-no-negative-blame no-negative-blame (optres-no-negative-blame? ps-optres))
(cons (optres-name ps-optres) names))
(loop (cdr ps)
next-ps
lift-ps
@ -88,7 +93,8 @@
(cons (car ps) hos)
ho-ctc
chaperone?
no-negative-blame)))])))
no-negative-blame
names)))])))
(with-syntax ((next-ps
(with-syntax (((opt-p ...) (reverse opt-ps)))
(syntax (or opt-p ...)))))
@ -111,10 +117,11 @@
(if next-ps val ho-ctc)))]
;; FIXME something's not right with this case.
[(> (length hos) 1)
(define-values (exp new-lifts new-superlifts new-partials) (opt/or-unknown stx))
(define-values (exp new-lifts new-superlifts new-partials name) (opt/or-unknown stx))
(set! lift-from-hos new-lifts)
(set! superlift-from-hos new-superlifts)
(set! partial-from-hos new-partials)
(set! name-from-hos name)
#`(if next-ps val #,exp)])
#:lifts
(append lift-ps lift-from-hos)
@ -127,7 +134,8 @@
#:opt #f
#:stronger-ribs stronger-ribs
#:chaperone chaperone?
#:no-negative-blame? no-negative-blame)))
#:no-negative-blame? no-negative-blame
#:name (or name-from-hos #`(list 'or/c #,@names)))))
(syntax-case stx (or/c)
[(or/c p ...)
@ -176,8 +184,8 @@
(with-syntax ([this this]
[that that])
(syntax (<= this that))))))
#:chaperone
#t)))))]))
#:chaperone #t
#:name #''(between/c n m))))))]))
(define (raise-opt-between/c-error blame val lo hi)
(raise-blame-error
@ -186,7 +194,7 @@
'(expected: "a number between ~a and ~a" given: "~e")
lo hi val))
(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg)
(define-for-syntax (single-comparison-opter opt/info stx check-arg comparison arg name)
(with-syntax ([comparison comparison])
(let*-values ([(lift-low lifts2) (lift/binding arg 'single-comparison-val empty-lifts)])
(with-syntax ([m lift-low])
@ -214,7 +222,8 @@
(with-syntax ([this this]
[that that])
(syntax (comparison this that))))))
#:chaperone #t)))))))
#:chaperone #t
#:name #`'(#,name m))))))))
(define (raise-opt-single-comparison-opter-error blame val comparison m)
(raise-blame-error
@ -233,7 +242,8 @@
(λ (m) (with-syntax ([m m])
#'(check-unary-between/c '=/c m)))
#'=
#'x)]))
#'x
'=/c)]))
(define/opter (>=/c opt/i opt/info stx)
(syntax-case stx (>=/c)
@ -244,7 +254,8 @@
(λ (m) (with-syntax ([m m])
#'(check-unary-between/c '>=/c m)))
#'>=
#'low)]))
#'low
'>=/c)]))
(define/opter (<=/c opt/i opt/info stx)
(syntax-case stx (<=/c)
@ -255,7 +266,8 @@
(λ (m) (with-syntax ([m m])
#'(check-unary-between/c '<=/c m)))
#'<=
#'high)]))
#'high
'<=/c)]))
(define/opter (>/c opt/i opt/info stx)
(syntax-case stx (>/c)
@ -266,7 +278,8 @@
(λ (m) (with-syntax ([m m])
#'(check-unary-between/c '>/c m)))
#'>
#'low)]))
#'low
'>/c)]))
(define/opter (</c opt/i opt/info stx)
(syntax-case stx (</c)
@ -277,7 +290,8 @@
(λ (m) (with-syntax ([m m])
#'(check-unary-between/c '</c m)))
#'<
#'high)]))
#'high
'</c)]))
;; only used by the opters
(define (flat-contract/predicate? pred)
@ -326,7 +340,8 @@
#:stronger-ribs
(append (optres-stronger-ribs optres-hd) (optres-stronger-ribs optres-tl))
#:chaperone
(combine-two-chaperone?s (optres-chaperone optres-hd) (optres-chaperone optres-tl)))))
(combine-two-chaperone?s (optres-chaperone optres-hd) (optres-chaperone optres-tl))
#:name #`(list 'cons/c #,(optres-name optres-hd) #,(optres-name optres-tl)))))
(syntax-case stx (cons/c)
[(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)]))
@ -374,7 +389,11 @@
#f)
#:opt #f
#:stronger-ribs (optres-stronger-ribs optres-ele)
#:chaperone (optres-chaperone optres-ele))))
#:chaperone (optres-chaperone optres-ele)
#:name #`(list '#,(if non-empty?
'non-empty-listof
'listof)
#,(optres-name optres-ele)))))
(define/opter (listof opt/i opt/info stx)
(syntax-case stx ()
@ -392,7 +411,7 @@
(define (opt/arrow-ctc doms rngs)
(let*-values ([(dom-vars rng-vars) (values (generate-temporaries doms)
(generate-temporaries rngs))]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone?)
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone? dom-names)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
@ -400,14 +419,16 @@
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null]
[chaperone? #t])
[chaperone? #t]
[dom-names '()])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs
chaperone?)]
chaperone?
(reverse dom-names))]
[else
(define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms)))
(loop (cdr vars)
@ -421,8 +442,9 @@
(append superlifts-doms (optres-superlifts optres-dom))
(append partials-doms (optres-partials optres-dom))
(append (optres-stronger-ribs optres-dom) stronger-ribs)
(combine-two-chaperone?s chaperone? (optres-chaperone optres-dom)))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone?)
(combine-two-chaperone?s chaperone? (optres-chaperone optres-dom))
(cons (optres-name optres-dom) dom-names))]))]
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rng-chaperone? rng-names)
(let loop ([vars rng-vars]
[rngs rngs]
[next-rngs null]
@ -430,14 +452,16 @@
[superlifts-rngs null]
[partials-rngs null]
[stronger-ribs null]
[chaperone? #t])
[chaperone? #t]
[rng-names '()])
(cond
[(null? rngs) (values (reverse next-rngs)
lifts-rngs
superlifts-rngs
partials-rngs
stronger-ribs
chaperone?)]
chaperone?
(reverse rng-names))]
[else
(define optres-rng (opt/i opt/info (car rngs)))
(loop (cdr vars)
@ -451,7 +475,8 @@
(append superlifts-rngs (optres-superlifts optres-rng))
(append partials-rngs (optres-partials optres-rng))
(append (optres-stronger-ribs optres-rng) stronger-ribs)
(combine-two-chaperone?s chaperone? (optres-chaperone optres-rng)))]))])
(combine-two-chaperone?s chaperone? (optres-chaperone optres-rng))
(cons (optres-name optres-rng) rng-names))]))])
(values
(with-syntax ((val (opt/info-val opt/info))
(blame (opt/info-blame opt/info))
@ -482,11 +507,16 @@
#f
#f
(append stronger-ribs-dom stronger-ribs-rng)
(combine-two-chaperone?s dom-chaperone? rng-chaperone?))))
(combine-two-chaperone?s dom-chaperone? rng-chaperone?)
#`(list '->
#,@dom-names
#,(if (= 1 (length rng-names))
(car rng-names)
#`(list 'values #,@rng-names))))))
(define (opt/arrow-any-ctc doms)
(let*-values ([(dom-vars) (generate-temporaries doms)]
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone?)
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom dom-chaperone? names)
(let loop ([vars dom-vars]
[doms doms]
[next-doms null]
@ -494,14 +524,16 @@
[superlifts-doms null]
[partials-doms null]
[stronger-ribs null]
[chaperone? #t])
[chaperone? #t]
[names '()])
(cond
[(null? doms) (values (reverse next-doms)
lifts-doms
superlifts-doms
partials-doms
stronger-ribs
chaperone?)]
chaperone?
(reverse names))]
[else
(define optres-dom (opt/i (opt/info-swap-blame opt/info) (car doms)))
(loop (cdr vars)
@ -512,7 +544,8 @@
(append superlifts-doms (optres-superlifts optres-dom))
(append partials-doms (optres-partials optres-dom))
(append (optres-stronger-ribs optres-dom) stronger-ribs)
(combine-two-chaperone?s chaperone? (optres-chaperone optres-dom)))]))])
(combine-two-chaperone?s chaperone? (optres-chaperone optres-dom))
(cons (optres-name optres-dom) names))]))])
(values
(with-syntax ((blame (opt/info-blame opt/info))
((dom-arg ...) dom-vars)
@ -532,7 +565,10 @@
#f
#f
stronger-ribs-dom
dom-chaperone?)))
dom-chaperone?
#`(list '->
#,@names
'any))))
(syntax-case* stx (-> values any any/c) module-or-top-identifier=?
[(-> any/c ... any)
@ -551,35 +587,39 @@
#:flat #'(procedure-arity-includes? val n)
#:opt #f
#:stronger-ribs null
#:chaperone #t))]
#:chaperone #t
#:name #`'(-> #,@(build-list (syntax-e #'n) (λ (x) 'any/c)) any)))]
[(-> dom ... (values rng ...))
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?)
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone? name)
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(syntax->list (syntax (rng ...))))])
(if (eq? chaperone? #t)
(build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?)
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?
#:name name)
(opt/unknown opt/i opt/info stx))))]
[(-> dom ... any)
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?)
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone? name)
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))])
(if (eq? chaperone? #t)
(build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?)
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?
#:name name)
(opt/unknown opt/i opt/info stx))))]
[(-> dom ... rng)
(if (ormap (λ (x) (keyword? (syntax-e x))) (syntax->list #'(dom ...)))
(opt/unknown opt/i opt/info stx) ;; give up if there is a mandatory keyword
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone?)
(let-values ([(next lift superlift partial flat opt stronger-ribs chaperone? name)
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
(list #'rng))])
(if (eq? chaperone? #t)
(build-optres #:exp next #:lifts lift #:superlifts superlift #:partials partial
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?)
#:flat flat #:opt opt #:stronger-ribs stronger-ribs #:chaperone chaperone?
#:name name)
(opt/unknown opt/i opt/info stx))))]))
(define (raise-flat-arrow-err blame val n)

4
collects/tests/racket/contract-test.rktl
View File

@ -12274,7 +12274,7 @@ so that propagation occurs.
(or/c integer? boolean?))
(test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(or/c (-> (>=/c 5) (>=/c 5)) boolean?))
(test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5)))
(or/c boolean? (-> (>=/c 5) (>=/c 5))))
(test-name '(or/c (-> (>=/c 5) (>=/c 5))
(-> (<=/c 5) (<=/c 5) (<=/c 5)))
@ -12849,7 +12849,7 @@ so that propagation occurs.
(flat-contract boolean?)))
(test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(or/c (-> (>=/c 5) (>=/c 5)) boolean?))
(test-name '(or/c (-> (>=/c 5) (>=/c 5)) boolean?)
(test-name '(or/c boolean? (-> (>=/c 5) (>=/c 5)))
(or/c boolean? (-> (>=/c 5) (>=/c 5))))