remove the code duplication in opt/c
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
parent
436d9f25f9
commit
caad82f91e
|
|
@ -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")
|
||||
|
|
|
|||
|
|
@ -11,7 +11,8 @@
|
|||
"private/misc.rkt"
|
||||
"private/provide.rkt"
|
||||
"private/guts.rkt"
|
||||
"private/opters.rkt" ;; required for effect to install the opters
|
||||
"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")
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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))]))]))))
|
||||
|
||||
|
|
|
|||
|
|
@ -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 ()
|
||||
|
|
|
|||
|
|
@ -106,43 +106,46 @@
|
|||
(case-lambda
|
||||
[() (make-none/c '(or/c))]
|
||||
[raw-args
|
||||
(let ([args (coerce-contracts 'or/c raw-args)])
|
||||
(let-values ([(ho-contracts flat-contracts)
|
||||
(let loop ([ho-contracts '()]
|
||||
[flat-contracts '()]
|
||||
[args args])
|
||||
(cond
|
||||
[(null? args) (values ho-contracts (reverse flat-contracts))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(cond
|
||||
[(flat-contract? arg)
|
||||
(loop ho-contracts (cons arg flat-contracts) (cdr args))]
|
||||
[else
|
||||
(loop (cons arg ho-contracts) flat-contracts (cdr args))]))]))])
|
||||
(let ([pred
|
||||
(cond
|
||||
[(null? flat-contracts) not]
|
||||
[else
|
||||
(let loop ([fst (car flat-contracts)]
|
||||
[rst (cdr flat-contracts)])
|
||||
(let ([fst-pred (flat-contract-predicate fst)])
|
||||
(cond
|
||||
[(null? rst) fst-pred]
|
||||
[else
|
||||
(let ([r (loop (car rst) (cdr rst))])
|
||||
(λ (x) (or (fst-pred x) (r x))))])))])])
|
||||
(cond
|
||||
[(null? ho-contracts)
|
||||
(make-flat-or/c pred flat-contracts)]
|
||||
[(null? (cdr ho-contracts))
|
||||
(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)))]
|
||||
[else
|
||||
(if (andmap chaperone-contract? ho-contracts)
|
||||
(make-chaperone-multi-or/c flat-contracts ho-contracts)
|
||||
(make-impersonator-multi-or/c flat-contracts ho-contracts))]))))]))
|
||||
(define args (coerce-contracts 'or/c raw-args))
|
||||
(define-values (ho-contracts flat-contracts)
|
||||
(let loop ([ho-contracts '()]
|
||||
[flat-contracts '()]
|
||||
[args args])
|
||||
(cond
|
||||
[(null? args) (values ho-contracts (reverse flat-contracts))]
|
||||
[else
|
||||
(let ([arg (car args)])
|
||||
(cond
|
||||
[(flat-contract? arg)
|
||||
(loop ho-contracts (cons arg flat-contracts) (cdr args))]
|
||||
[else
|
||||
(loop (cons arg ho-contracts) flat-contracts (cdr args))]))])))
|
||||
(define pred
|
||||
(cond
|
||||
[(null? flat-contracts) not]
|
||||
[else
|
||||
(let loop ([fst (car flat-contracts)]
|
||||
[rst (cdr flat-contracts)])
|
||||
(let ([fst-pred (flat-contract-predicate fst)])
|
||||
(cond
|
||||
[(null? rst) fst-pred]
|
||||
[else
|
||||
(let ([r (loop (car rst) (cdr rst))])
|
||||
(λ (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 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 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)
|
||||
|
|
|
|||
|
|
@ -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?)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
|
|
@ -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))))
|
||||
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user