refactored contract opters so they return structs instead
of (8!) multiple values original commit: 7221d01483eb92086ae98a16c63ae716e97ae267
This commit is contained in:
Robby Findler
parent
d8e0ca691a
commit
71d054cc1f
|
|
@ -377,154 +377,3 @@
|
||||||
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
|
(define-syntax (opt-> stx) (make-opt->/proc #f stx select/h #'case-> #'->))
|
||||||
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
|
(define-syntax (opt->* stx) (make-opt->*/proc #f stx stx select/h #'case-> #'->))
|
||||||
|
|
||||||
;;
|
|
||||||
;; arrow opter
|
|
||||||
;;
|
|
||||||
(define/opter (-> opt/i opt/info stx)
|
|
||||||
(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 doms-chaperone?)
|
|
||||||
(let loop ([vars dom-vars]
|
|
||||||
[doms doms]
|
|
||||||
[next-doms null]
|
|
||||||
[lifts-doms null]
|
|
||||||
[superlifts-doms null]
|
|
||||||
[partials-doms null]
|
|
||||||
[stronger-ribs null]
|
|
||||||
[chaperone? #t])
|
|
||||||
(cond
|
|
||||||
[(null? doms) (values (reverse next-doms)
|
|
||||||
lifts-doms
|
|
||||||
superlifts-doms
|
|
||||||
partials-doms
|
|
||||||
stronger-ribs
|
|
||||||
chaperone?)]
|
|
||||||
[else
|
|
||||||
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
|
|
||||||
(opt/i (opt/info-swap-blame opt/info) (car doms))])
|
|
||||||
(loop (cdr vars)
|
|
||||||
(cdr doms)
|
|
||||||
(cons (with-syntax ((next next)
|
|
||||||
(car-vars (car vars)))
|
|
||||||
(syntax (let ((val car-vars)) next)))
|
|
||||||
next-doms)
|
|
||||||
(append lifts-doms lift)
|
|
||||||
(append superlifts-doms superlift)
|
|
||||||
(append partials-doms partial)
|
|
||||||
(append this-stronger-ribs stronger-ribs)
|
|
||||||
(and chaperone? this-chaperone?)))]))]
|
|
||||||
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng rngs-chaperone?)
|
|
||||||
(let loop ([vars rng-vars]
|
|
||||||
[rngs rngs]
|
|
||||||
[next-rngs null]
|
|
||||||
[lifts-rngs null]
|
|
||||||
[superlifts-rngs null]
|
|
||||||
[partials-rngs null]
|
|
||||||
[stronger-ribs null]
|
|
||||||
[chaperone? #t])
|
|
||||||
(cond
|
|
||||||
[(null? rngs) (values (reverse next-rngs)
|
|
||||||
lifts-rngs
|
|
||||||
superlifts-rngs
|
|
||||||
partials-rngs
|
|
||||||
stronger-ribs
|
|
||||||
chaperone?)]
|
|
||||||
[else
|
|
||||||
(let-values ([(next lift superlift partial _ __ this-stronger-ribs this-chaperone?)
|
|
||||||
(opt/i opt/info (car rngs))])
|
|
||||||
(loop (cdr vars)
|
|
||||||
(cdr rngs)
|
|
||||||
(cons (with-syntax ((next next)
|
|
||||||
(car-vars (car vars)))
|
|
||||||
(syntax (let ((val car-vars)) next)))
|
|
||||||
next-rngs)
|
|
||||||
(append lifts-rngs lift)
|
|
||||||
(append superlifts-rngs superlift)
|
|
||||||
(append partials-rngs partial)
|
|
||||||
(append this-stronger-ribs stronger-ribs)
|
|
||||||
(and this-chaperone? chaperone?)))]))])
|
|
||||||
(values
|
|
||||||
(with-syntax ((blame (opt/info-blame opt/info))
|
|
||||||
((dom-arg ...) dom-vars)
|
|
||||||
((rng-arg ...) rng-vars)
|
|
||||||
((next-dom ...) next-doms)
|
|
||||||
(dom-len (length dom-vars))
|
|
||||||
((next-rng ...) next-rngs))
|
|
||||||
(syntax (begin
|
|
||||||
(check-procedure val dom-len 0 '() '() #| keywords |# blame)
|
|
||||||
(λ (dom-arg ...)
|
|
||||||
(let-values ([(rng-arg ...) (val next-dom ...)])
|
|
||||||
(values next-rng ...))))))
|
|
||||||
(append lifts-doms lifts-rngs)
|
|
||||||
(append superlifts-doms superlifts-rngs)
|
|
||||||
(append partials-doms partials-rngs)
|
|
||||||
#f
|
|
||||||
#f
|
|
||||||
(append stronger-ribs-dom stronger-ribs-rng)
|
|
||||||
(and rngs-chaperone? doms-chaperone?))))
|
|
||||||
|
|
||||||
(define (opt/arrow-any-ctc doms)
|
|
||||||
(let*-values ([(dom-vars) (generate-temporaries doms)]
|
|
||||||
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom doms-chaperone?)
|
|
||||||
(let loop ([vars dom-vars]
|
|
||||||
[doms doms]
|
|
||||||
[next-doms null]
|
|
||||||
[lifts-doms null]
|
|
||||||
[superlifts-doms null]
|
|
||||||
[partials-doms null]
|
|
||||||
[stronger-ribs null]
|
|
||||||
[chaperone? #t])
|
|
||||||
(cond
|
|
||||||
[(null? doms) (values (reverse next-doms)
|
|
||||||
lifts-doms
|
|
||||||
superlifts-doms
|
|
||||||
partials-doms
|
|
||||||
stronger-ribs
|
|
||||||
chaperone?)]
|
|
||||||
[else
|
|
||||||
(let-values ([(next lift superlift partial flat _ this-stronger-ribs this-chaperone?)
|
|
||||||
(opt/i (opt/info-swap-blame opt/info) (car doms))])
|
|
||||||
(loop (cdr vars)
|
|
||||||
(cdr doms)
|
|
||||||
(cons (with-syntax ((next next)
|
|
||||||
(car-vars (car vars)))
|
|
||||||
(syntax (let ((val car-vars)) next)))
|
|
||||||
next-doms)
|
|
||||||
(append lifts-doms lift)
|
|
||||||
(append superlifts-doms superlift)
|
|
||||||
(append partials-doms partial)
|
|
||||||
(append this-stronger-ribs stronger-ribs)
|
|
||||||
(and chaperone? this-chaperone?)))]))])
|
|
||||||
(values
|
|
||||||
(with-syntax ((blame (opt/info-blame opt/info))
|
|
||||||
((dom-arg ...) dom-vars)
|
|
||||||
((next-dom ...) next-doms)
|
|
||||||
(dom-len (length dom-vars)))
|
|
||||||
(syntax (begin
|
|
||||||
(check-procedure val dom-len 0 '() '() #|keywords|# blame)
|
|
||||||
(λ (dom-arg ...)
|
|
||||||
(val next-dom ...)))))
|
|
||||||
lifts-doms
|
|
||||||
superlifts-doms
|
|
||||||
partials-doms
|
|
||||||
#f
|
|
||||||
#f
|
|
||||||
stronger-ribs-dom
|
|
||||||
doms-chaperone?)))
|
|
||||||
|
|
||||||
(syntax-case* stx (-> values any) module-or-top-identifier=?
|
|
||||||
[(-> 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
|
|
||||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
|
||||||
(syntax->list (syntax (rng ...)))))]
|
|
||||||
[(-> 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
|
|
||||||
(opt/arrow-any-ctc (syntax->list (syntax (dom ...)))))]
|
|
||||||
[(-> 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
|
|
||||||
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
|
||||||
(list #'rng)))]))
|
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user