462 lines
23 KiB
Scheme
462 lines
23 KiB
Scheme
(module contract-arrow mzscheme
|
|
(require (lib "etc.ss")
|
|
"contract-guts.ss"
|
|
"contract-arr-checks.ss"
|
|
"contract-opt.ss")
|
|
(require-for-syntax "contract-opt-guts.ss"
|
|
"contract-helpers.ss"
|
|
"contract-arr-obj-helpers.ss"
|
|
(lib "stx.ss" "syntax")
|
|
(lib "name.ss" "syntax"))
|
|
|
|
(provide ->
|
|
->d
|
|
->*
|
|
->d*
|
|
->r
|
|
->pp
|
|
->pp-rest
|
|
case->
|
|
opt->
|
|
opt->*
|
|
unconstrained-domain->
|
|
check-procedure)
|
|
|
|
(define-syntax (unconstrained-domain-> stx)
|
|
(syntax-case stx ()
|
|
[(_ rngs ...)
|
|
(with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))]
|
|
[(proj-x ...) (generate-temporaries #'(rngs ...))]
|
|
[(p-app-x ...) (generate-temporaries #'(rngs ...))]
|
|
[(res-x ...) (generate-temporaries #'(rngs ...))])
|
|
#'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...)
|
|
(let ([proj-x ((proj-get rngs-x) rngs-x)] ...)
|
|
(make-proj-contract
|
|
(build-compound-type-name 'unconstrained-domain-> ((name-get rngs-x) rngs-x) ...)
|
|
(λ (pos-blame neg-blame src-info orig-str)
|
|
(let ([p-app-x (proj-x pos-blame neg-blame src-info orig-str)] ...)
|
|
(λ (val)
|
|
(if (procedure? val)
|
|
(λ args
|
|
(let-values ([(res-x ...) (apply val args)])
|
|
(values (p-app-x res-x) ...)))
|
|
(raise-contract-error val
|
|
src-info
|
|
pos-blame
|
|
orig-str
|
|
"expected a procedure")))))
|
|
procedure?))))]))
|
|
|
|
;; FIXME: need to pass in the name of the contract combinator.
|
|
(define (build--> name doms doms-rest rngs rng-any? func)
|
|
(let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)]
|
|
[rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)]
|
|
[doms-rest/c (and doms-rest (coerce-contract name doms-rest))])
|
|
(make--> rng-any? doms/c doms-rest/c rngs/c func)))
|
|
|
|
(define-struct/prop -> (rng-any? doms dom-rest rngs func)
|
|
((proj-prop (λ (ctc)
|
|
(let* ([doms/c (map (λ (x) ((proj-get x) x))
|
|
(if (->-dom-rest ctc)
|
|
(append (->-doms ctc) (list (->-dom-rest ctc)))
|
|
(->-doms ctc)))]
|
|
[rngs/c (map (λ (x) ((proj-get x) x)) (->-rngs ctc))]
|
|
[func (->-func ctc)]
|
|
[dom-length (length (->-doms ctc))]
|
|
[check-proc
|
|
(if (->-dom-rest ctc)
|
|
check-procedure/more
|
|
check-procedure)])
|
|
(lambda (pos-blame neg-blame src-info orig-str)
|
|
(let ([partial-doms (map (λ (dom) (dom neg-blame pos-blame src-info orig-str))
|
|
doms/c)]
|
|
[partial-ranges (map (λ (rng) (rng pos-blame neg-blame src-info orig-str))
|
|
rngs/c)])
|
|
(apply func
|
|
(λ (val) (check-proc val dom-length src-info pos-blame orig-str))
|
|
(append partial-doms partial-ranges)))))))
|
|
(name-prop (λ (ctc) (single-arrow-name-maker
|
|
(->-doms ctc)
|
|
(->-dom-rest ctc)
|
|
(->-rng-any? ctc)
|
|
(->-rngs ctc))))
|
|
(first-order-prop
|
|
(λ (ctc)
|
|
(let ([l (length (->-doms ctc))])
|
|
(if (->-dom-rest ctc)
|
|
(λ (x)
|
|
(and (procedure? x)
|
|
(procedure-accepts-and-more? x l)))
|
|
(λ (x)
|
|
(and (procedure? x)
|
|
(procedure-arity-includes? x l)))))))
|
|
(stronger-prop
|
|
(λ (this that)
|
|
(and (->? that)
|
|
(= (length (->-doms that))
|
|
(length (->-doms this)))
|
|
(andmap contract-stronger?
|
|
(->-doms that)
|
|
(->-doms this))
|
|
(= (length (->-rngs that))
|
|
(length (->-rngs this)))
|
|
(andmap contract-stronger?
|
|
(->-rngs this)
|
|
(->-rngs that)))))))
|
|
|
|
(define (single-arrow-name-maker doms/c doms-rest rng-any? rngs)
|
|
(cond
|
|
[doms-rest
|
|
(build-compound-type-name
|
|
'->*
|
|
(apply build-compound-type-name doms/c)
|
|
doms-rest
|
|
(cond
|
|
[rng-any? 'any]
|
|
[else (apply build-compound-type-name rngs)]))]
|
|
[else
|
|
(let ([rng-name
|
|
(cond
|
|
[rng-any? 'any]
|
|
[(null? rngs) '(values)]
|
|
[(null? (cdr rngs)) (car rngs)]
|
|
[else (apply build-compound-type-name 'values rngs)])])
|
|
(apply build-compound-type-name '-> (append doms/c (list rng-name))))]))
|
|
|
|
(define arity-one-wrapper
|
|
(lambda (chk a3 c5) (lambda (val) (chk val) (lambda (a1) (c5 (val (a3 a1)))))))
|
|
|
|
(define arity-two-wrapper
|
|
(lambda (chk a3 b4 c5) (lambda (val) (chk val) (lambda (a1 b2) (c5 (val (a3 a1) (b4 b2)))))))
|
|
|
|
(define arity-three-wrapper
|
|
(lambda (chk a9 b10 c11 r12) (lambda (val) (chk val) (lambda (a6 b7 c8) (r12 (val (a9 a6) (b10 b7) (c11 c8)))))))
|
|
|
|
(define arity-four-wrapper
|
|
(lambda (chk a17 b18 c19 d20 r21) (lambda (val) (chk val) (lambda (a13 b14 c15 d16) (r21 (val (a17 a13) (b18 b14) (c19 c15) (d20 d16)))))))
|
|
|
|
(define arity-five-wrapper
|
|
(lambda (chk a27 b28 c29 d30 e31 r32)
|
|
(lambda (val) (chk val) (lambda (a22 b23 c24 d25 e26) (r32 (val (a27 a22) (b28 b23) (c29 c24) (d30 d25) (e31 e26)))))))
|
|
|
|
(define arity-six-wrapper
|
|
(lambda (chk a39 b40 c41 d42 e43 f44 r45)
|
|
(lambda (val) (chk val) (lambda (a33 b34 c35 d36 e37 f38) (r45 (val (a39 a33) (b40 b34) (c41 c35) (d42 d36) (e43 e37) (f44 f38)))))))
|
|
|
|
(define arity-seven-wrapper
|
|
(lambda (chk a53 b54 c55 d56 e57 f58 g59 r60)
|
|
(lambda (val) (chk val) (lambda (a46 b47 c48 d49 e50 f51 g52) (r60 (val (a53 a46) (b54 b47) (c55 c48) (d56 d49) (e57 e50) (f58 f51) (g59 g52)))))))
|
|
|
|
(define-syntax-set (-> ->*)
|
|
(define (->/proc stx)
|
|
(let-values ([(stx _1 _2) (->/proc/main stx)])
|
|
stx))
|
|
|
|
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
|
(define (->/proc/main stx)
|
|
(let-values ([(dom-names rng-names dom-ctcs rng-ctcs inner-args/body use-any?) (->-helper stx)])
|
|
(with-syntax ([(args body) inner-args/body])
|
|
(with-syntax ([(dom-names ...) dom-names]
|
|
[(rng-names ...) rng-names]
|
|
[(dom-ctcs ...) dom-ctcs]
|
|
[(rng-ctcs ...) rng-ctcs]
|
|
[inner-lambda
|
|
(add-name-prop
|
|
(syntax-local-infer-name stx)
|
|
(syntax (lambda args body)))]
|
|
[use-any? use-any?])
|
|
(with-syntax ([outer-lambda
|
|
(let* ([lst (syntax->list #'args)]
|
|
[len (and lst (length lst))])
|
|
(if (and #f ;; this optimization disables the names so is turned off for now
|
|
lst
|
|
(not (syntax-e #'use-any?))
|
|
(= len (length (syntax->list #'(dom-names ...))))
|
|
(= 1 (length (syntax->list #'(rng-names ...))))
|
|
(<= 1 len 7))
|
|
(case len
|
|
[(1) #'arity-one-wrapper]
|
|
[(2) #'arity-two-wrapper]
|
|
[(3) #'arity-three-wrapper]
|
|
[(4) #'arity-four-wrapper]
|
|
[(5) #'arity-five-wrapper]
|
|
[(6) #'arity-six-wrapper]
|
|
[(7) #'arity-seven-wrapper])
|
|
(syntax
|
|
(lambda (chk dom-names ... rng-names ...)
|
|
(lambda (val)
|
|
(chk val)
|
|
inner-lambda)))))])
|
|
(values
|
|
(syntax (build--> '->
|
|
(list dom-ctcs ...)
|
|
#f
|
|
(list rng-ctcs ...)
|
|
use-any?
|
|
outer-lambda))
|
|
inner-args/body
|
|
(syntax (dom-names ... rng-names ...))))))))
|
|
|
|
(define (->-helper stx)
|
|
(syntax-case* stx (-> any values) module-or-top-identifier=?
|
|
[(-> doms ... any)
|
|
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(ignored) (generate-temporaries (syntax (rng)))])
|
|
(values (syntax (dom-ctc ...))
|
|
(syntax (ignored))
|
|
(syntax (doms ...))
|
|
(syntax (any/c))
|
|
(syntax ((args ...) (val (dom-ctc args) ...)))
|
|
#t))]
|
|
[(-> doms ... (values rngs ...))
|
|
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
|
[(rng-ctc ...) (generate-temporaries (syntax (rngs ...)))])
|
|
(values (syntax (dom-ctc ...))
|
|
(syntax (rng-ctc ...))
|
|
(syntax (doms ...))
|
|
(syntax (rngs ...))
|
|
(syntax ((args ...)
|
|
(let-values ([(rng-x ...) (val (dom-ctc args) ...)])
|
|
(values (rng-ctc rng-x) ...))))
|
|
#f))]
|
|
[(_ doms ... rng)
|
|
(with-syntax ([(args ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(dom-ctc ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(rng-ctc) (generate-temporaries (syntax (rng)))])
|
|
(values (syntax (dom-ctc ...))
|
|
(syntax (rng-ctc))
|
|
(syntax (doms ...))
|
|
(syntax (rng))
|
|
(syntax ((args ...) (rng-ctc (val (dom-ctc args) ...))))
|
|
#f))]))
|
|
|
|
(define (->*/proc stx)
|
|
(let-values ([(stx _1 _2) (->*/proc/main stx)])
|
|
stx))
|
|
|
|
;; ->/proc/main : syntax -> (values syntax[contract-record] syntax[args/lambda-body] syntax[names])
|
|
(define (->*/proc/main stx)
|
|
(syntax-case* stx (->* any) module-or-top-identifier=?
|
|
[(->* (doms ...) any)
|
|
(->/proc/main (syntax (-> doms ... any)))]
|
|
[(->* (doms ...) (rngs ...))
|
|
(->/proc/main (syntax (-> doms ... (values rngs ...))))]
|
|
[(->* (doms ...) rst (rngs ...))
|
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(rst-x) (generate-temporaries (syntax (rst)))]
|
|
[(rest-arg) (generate-temporaries (syntax (rst)))]
|
|
[(rng-x ...) (generate-temporaries (syntax (rngs ...)))]
|
|
[(rng-args ...) (generate-temporaries (syntax (rngs ...)))])
|
|
(let ([inner-args/body
|
|
(syntax ((args ... . rest-arg)
|
|
(let-values ([(rng-args ...) (apply val (dom-x args) ... (rst-x rest-arg))])
|
|
(values (rng-x rng-args) ...))))])
|
|
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
|
(add-name-prop
|
|
(syntax-local-infer-name stx)
|
|
(syntax (lambda args body))))])
|
|
(with-syntax ([outer-lambda
|
|
(syntax
|
|
(lambda (chk dom-x ... rst-x rng-x ...)
|
|
(lambda (val)
|
|
(chk val)
|
|
inner-lambda)))])
|
|
(values (syntax (build--> '->*
|
|
(list doms ...)
|
|
rst
|
|
(list rngs ...)
|
|
#f
|
|
outer-lambda))
|
|
inner-args/body
|
|
(syntax (dom-x ... rst-x rng-x ...)))))))]
|
|
[(->* (doms ...) rst any)
|
|
(with-syntax ([(dom-x ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(args ...) (generate-temporaries (syntax (doms ...)))]
|
|
[(rst-x) (generate-temporaries (syntax (rst)))]
|
|
[(rest-arg) (generate-temporaries (syntax (rst)))])
|
|
(let ([inner-args/body
|
|
(syntax ((args ... . rest-arg)
|
|
(apply val (dom-x args) ... (rst-x rest-arg))))])
|
|
(with-syntax ([inner-lambda (with-syntax ([(args body) inner-args/body])
|
|
(add-name-prop
|
|
(syntax-local-infer-name stx)
|
|
(syntax (lambda args body))))])
|
|
(with-syntax ([outer-lambda
|
|
(syntax
|
|
(lambda (chk dom-x ... rst-x ignored)
|
|
(lambda (val)
|
|
(chk val)
|
|
inner-lambda)))])
|
|
(values (syntax (build--> '->*
|
|
(list doms ...)
|
|
rst
|
|
(list any/c)
|
|
#t
|
|
outer-lambda))
|
|
inner-args/body
|
|
(syntax (dom-x ... rst-x)))))))])))
|
|
|
|
(define-for-syntax (select/h stx err-name ctxt-stx)
|
|
(syntax-case stx (-> ->* ->d ->d* ->r ->pp ->pp-rest)
|
|
[(-> . args) ->/h]
|
|
[(->* . args) ->*/h]
|
|
[(->d . args) ->d/h]
|
|
[(->d* . args) ->d*/h]
|
|
[(->r . args) ->r/h]
|
|
[(->pp . args) ->pp/h]
|
|
[(->pp-rest . args) ->pp-rest/h]
|
|
[(xxx . args) (raise-syntax-error err-name "unknown arrow constructor" ctxt-stx (syntax xxx))]
|
|
[_ (raise-syntax-error err-name "malformed arrow clause" ctxt-stx stx)]))
|
|
|
|
(define-syntax (->d stx) (make-/proc #f ->d/h stx))
|
|
(define-syntax (->d* stx) (make-/proc #f ->d*/h stx))
|
|
(define-syntax (->r stx) (make-/proc #f ->r/h stx))
|
|
(define-syntax (->pp stx) (make-/proc #f ->pp/h stx))
|
|
(define-syntax (->pp-rest stx) (make-/proc #f ->pp-rest/h stx))
|
|
(define-syntax (case-> stx) (make-case->/proc #f stx stx select/h))
|
|
(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-> #'->))
|
|
|
|
;;
|
|
;; 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)
|
|
(let loop ([vars dom-vars]
|
|
[doms doms]
|
|
[next-doms null]
|
|
[lifts-doms null]
|
|
[superlifts-doms null]
|
|
[partials-doms null]
|
|
[stronger-ribs null])
|
|
(cond
|
|
[(null? doms) (values (reverse next-doms)
|
|
lifts-doms
|
|
superlifts-doms
|
|
partials-doms
|
|
stronger-ribs)]
|
|
[else
|
|
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
|
|
(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)))]))]
|
|
[(next-rngs lifts-rngs superlifts-rngs partials-rngs stronger-ribs-rng)
|
|
(let loop ([vars rng-vars]
|
|
[rngs rngs]
|
|
[next-rngs null]
|
|
[lifts-rngs null]
|
|
[superlifts-rngs null]
|
|
[partials-rngs null]
|
|
[stronger-ribs null])
|
|
(cond
|
|
[(null? rngs) (values (reverse next-rngs)
|
|
lifts-rngs
|
|
superlifts-rngs
|
|
partials-rngs
|
|
stronger-ribs)]
|
|
[else
|
|
(let-values ([(next lift superlift partial _ __ this-stronger-ribs)
|
|
(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)))]))])
|
|
(values
|
|
(with-syntax ((pos (opt/info-pos opt/info))
|
|
(src-info (opt/info-src-info opt/info))
|
|
(orig-str (opt/info-orig-str 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 src-info pos orig-str)
|
|
(λ (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))))
|
|
|
|
(define (opt/arrow-any-ctc doms)
|
|
(let*-values ([(dom-vars) (generate-temporaries doms)]
|
|
[(next-doms lifts-doms superlifts-doms partials-doms stronger-ribs-dom)
|
|
(let loop ([vars dom-vars]
|
|
[doms doms]
|
|
[next-doms null]
|
|
[lifts-doms null]
|
|
[superlifts-doms null]
|
|
[partials-doms null]
|
|
[stronger-ribs null])
|
|
(cond
|
|
[(null? doms) (values (reverse next-doms)
|
|
lifts-doms
|
|
superlifts-doms
|
|
partials-doms
|
|
stronger-ribs)]
|
|
[else
|
|
(let-values ([(next lift superlift partial flat _ this-stronger-ribs)
|
|
(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)))]))])
|
|
(values
|
|
(with-syntax ((pos (opt/info-pos opt/info))
|
|
(src-info (opt/info-src-info opt/info))
|
|
(orig-str (opt/info-orig-str opt/info))
|
|
((dom-arg ...) dom-vars)
|
|
((next-dom ...) next-doms)
|
|
(dom-len (length dom-vars)))
|
|
(syntax (begin
|
|
(check-procedure val dom-len src-info pos orig-str)
|
|
(λ (dom-arg ...)
|
|
(val next-dom ...)))))
|
|
lifts-doms
|
|
superlifts-doms
|
|
partials-doms
|
|
#f
|
|
#f
|
|
stronger-ribs-dom)))
|
|
|
|
(syntax-case* stx (-> values any) module-or-top-identifier=?
|
|
[(-> dom ... (values rng ...))
|
|
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
|
(syntax->list (syntax (rng ...))))]
|
|
[(-> dom ... any)
|
|
(opt/arrow-any-ctc (syntax->list (syntax (dom ...))))]
|
|
[(-> dom ... rng)
|
|
(opt/arrow-ctc (syntax->list (syntax (dom ...)))
|
|
(list #'rng))])))
|