rename
This commit is contained in:
Robby Findler
parent
efd72af3d6
commit
5217744740
598
collects/racket/contract/private/arr-i-old.rkt
Normal file
598
collects/racket/contract/private/arr-i-old.rkt
Normal file
|
|
@ -0,0 +1,598 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "guts.rkt"
|
||||
"arrow.rkt"
|
||||
"opt.rkt"
|
||||
racket/stxparam
|
||||
|
||||
(for-syntax racket/base
|
||||
syntax/stx
|
||||
syntax/name
|
||||
"arr-i-parse.rkt"
|
||||
"opt-guts.rkt"
|
||||
"helpers.rkt"
|
||||
"arr-util.rkt"))
|
||||
|
||||
(provide ->i)
|
||||
|
||||
(define-for-syntax (make-this-parameters id)
|
||||
(if (syntax-parameter-value #'making-a-method)
|
||||
(list id)
|
||||
null))
|
||||
|
||||
;; parses everything after the mandatory and optional doms in a ->d contract
|
||||
(define-for-syntax (parse-leftover stx leftover)
|
||||
(let*-values ([(raw-optional-doms leftover)
|
||||
(syntax-case leftover ()
|
||||
[(kwd . leftover2)
|
||||
(keyword? (syntax-e #'kwd))
|
||||
(values '() leftover)]
|
||||
[(dep-range)
|
||||
(values '() leftover)]
|
||||
[(dep-range #:post-cond expr)
|
||||
(values '() leftover)]
|
||||
[((opts ...) . rest)
|
||||
(values #'(opts ...) #'rest)]
|
||||
[_ (values '() leftover)])]
|
||||
[(id/rest-id leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:rest [id rest-expr] . leftover)
|
||||
(and (identifier? #'id)
|
||||
(not (keyword? (syntax-e #'rest-expr))))
|
||||
(values #'(id rest-expr) #'leftover)]
|
||||
[(#:rest [id (id2 ...) rest-expr] . leftover)
|
||||
(and (identifier? #'id)
|
||||
(andmap identifier? (syntax->list #'(id2 ...)))
|
||||
(not (keyword? (syntax-e #'rest-expr))))
|
||||
(values #'(id rest-expr) #'leftover)]
|
||||
[(#:rest something . leftover)
|
||||
(raise-syntax-error #f "expected id+ctc" stx #'something)]
|
||||
[_ (values #f leftover)])]
|
||||
[(pre-cond leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:pre-cond pre-cond . leftover)
|
||||
(values #'pre-cond #'leftover)]
|
||||
[_ (values #f leftover)])]
|
||||
[(range leftover)
|
||||
(syntax-case leftover ()
|
||||
[(range . leftover) (values #'range #'leftover)]
|
||||
[_
|
||||
(raise-syntax-error #f "expected a range expression, but found nothing" stx)])]
|
||||
[(post-cond leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:post-cond post-cond . leftover)
|
||||
(begin
|
||||
(syntax-case range (any)
|
||||
[any (raise-syntax-error #f "cannot have a #:post-cond with any as the range" stx #'post-cond)]
|
||||
[_ (void)])
|
||||
(values #'post-cond #'leftover))]
|
||||
[_ (values #f leftover)])])
|
||||
(syntax-case leftover ()
|
||||
[()
|
||||
(values raw-optional-doms id/rest-id pre-cond range post-cond)]
|
||||
[_
|
||||
(raise-syntax-error #f "bad syntax" stx)])))
|
||||
|
||||
;; verify-->i-structure : syntax syntax -> syntax
|
||||
;; returns the second argument when it has the proper shape for the first two arguments to ->i
|
||||
;; otherwise, raises a syntax error.
|
||||
;; also: drops the extra identifiers in the ->i.
|
||||
(define-for-syntax (verify-->i-structure stx doms)
|
||||
(syntax-case doms ()
|
||||
[((regular ...) (kwd ...))
|
||||
(let ([check-pair-shape
|
||||
(λ (reg)
|
||||
(syntax-case reg ()
|
||||
[(id dom)
|
||||
(identifier? #'id)
|
||||
reg]
|
||||
[(a b)
|
||||
(raise-syntax-error #f "expected an identifier" stx #'a)]
|
||||
|
||||
[(id (id2 ...) dom)
|
||||
(and (identifier? #'id)
|
||||
(andmap identifier? (syntax->list #'(id2 ...))))
|
||||
#'(id dom)]
|
||||
[(id ids dom)
|
||||
(unless (identifier? #'id)
|
||||
(raise-syntax-error #f "expected an identifier" stx #'id))
|
||||
(raise-syntax-error #f "expected an sequence of identifiers" stx #'ids)]
|
||||
[_
|
||||
(raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
|
||||
(list (map check-pair-shape (syntax->list #'(regular ...)))
|
||||
(map
|
||||
(λ (kwd)
|
||||
(syntax-case kwd ()
|
||||
[(kwd ps)
|
||||
#`(kwd #,(check-pair-shape #'ps))]))
|
||||
(syntax->list #'(kwd ...)))))]))
|
||||
|
||||
(define-for-syntax (make-this-transformer this-arg)
|
||||
(with-syntax ([this-arg this-arg])
|
||||
(make-set!-transformer
|
||||
(λ (sstx)
|
||||
(syntax-case sstx (set!)
|
||||
[(set! id arg)
|
||||
(raise-syntax-error #f
|
||||
"can't mutate this"
|
||||
sstx)]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(syntax/loc sstx this-arg)]
|
||||
[(id . args)
|
||||
(datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
|
||||
|
||||
(define-for-syntax (find-pre/post-keywords stx)
|
||||
(let ([pre #f]
|
||||
[post #f])
|
||||
(let loop ([stx (syntax->list stx)])
|
||||
(cond
|
||||
[(syntax? stx)
|
||||
(loop (syntax-e stx))]
|
||||
[(pair? stx)
|
||||
(when (and (syntax? (car stx))
|
||||
(eq? (syntax-e (car stx))
|
||||
'#:pre-cond))
|
||||
(set! pre (car stx)))
|
||||
(when (and (syntax? (car stx))
|
||||
(eq? (syntax-e (car stx))
|
||||
'#:post-cond))
|
||||
(set! post (car stx)))
|
||||
(loop (cdr stx))]
|
||||
[else (void)]))
|
||||
(values pre post)))
|
||||
|
||||
(define-syntax (->i stx)
|
||||
(parse-->i stx)
|
||||
(printf "finished ->i parsing\n")
|
||||
(syntax-case stx ()
|
||||
[(_ (raw-mandatory-doms ...)
|
||||
.
|
||||
leftover)
|
||||
(let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]
|
||||
[(this->i) (gensym '->i)])
|
||||
(define (add-indy-prop stx)
|
||||
(syntax-property stx 'racket/contract:internal-contract (gensym '->i-boundary)))
|
||||
(with-syntax ([(([mandatory-regular-id mandatory-dom/no-prop] ... )
|
||||
([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom/no-prop)] ...))
|
||||
(verify-->i-structure stx (split-doms stx '->i #'(raw-mandatory-doms ...)))]
|
||||
[(([optional-regular-id optional-dom/no-prop] ...)
|
||||
([optional-kwd (optional-kwd-id optional-kwd-dom/no-prop)] ...))
|
||||
(verify-->i-structure stx (split-doms stx '->i raw-optional-doms))])
|
||||
(with-syntax ([(mandatory-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(mandatory-dom/no-prop ...)))]
|
||||
[(mandatory-kwd-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(mandatory-kwd-dom/no-prop ...)))]
|
||||
[(optional-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(optional-dom/no-prop ...)))]
|
||||
[(optional-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->i))
|
||||
(syntax->list #'(optional-kwd-dom/no-prop ...)))])
|
||||
(with-syntax ([((kwd kwd-id) ...)
|
||||
(sort-keywords
|
||||
stx
|
||||
(syntax->list
|
||||
#'((optional-kwd optional-kwd-id) ...
|
||||
(mandatory-kwd mandatory-kwd-id) ...)))]
|
||||
[(this-parameter ...)
|
||||
(make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
|
||||
(car (generate-temporaries '(this)))
|
||||
(datum->syntax stx 'this #f)))])
|
||||
(with-syntax ([(dom-params ...)
|
||||
#`(this-parameter ...
|
||||
mandatory-regular-id ...
|
||||
optional-regular-id ...
|
||||
#,@(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#'(id))
|
||||
#'())
|
||||
kwd-id ...)])
|
||||
(with-syntax ([((rng-params ...) rng-ctcs)
|
||||
(syntax-case range (any values)
|
||||
[(values ctc-pr ...)
|
||||
(with-syntax ([((id ctc/no-prop) ...)
|
||||
(map (lambda (x) (syntax-case x ()
|
||||
[[id ctc/no-prop] #'[id ctc/no-prop]]
|
||||
[[id (id2 ...) ctc/no-prop] #'[id ctc/no-prop]]
|
||||
[x (raise-syntax-error #f "expected binding pair" stx #'x)]))
|
||||
(syntax->list #'(ctc-pr ...)))])
|
||||
(with-syntax ([(ctc ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:positive-position this->i)))
|
||||
(syntax->list #'(ctc/no-prop ...)))])
|
||||
#'((id ...) (ctc ...))))]
|
||||
[any #'(() #f)]
|
||||
[[id ctc]
|
||||
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
|
||||
[[id (id2 ...) ctc]
|
||||
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
|
||||
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
|
||||
[mtd? (and (syntax-parameter-value #'making-a-method) #t)])
|
||||
(let ([rng-underscores?
|
||||
(let ([is-underscore?
|
||||
(λ (x)
|
||||
(syntax-case x (_)
|
||||
[_ #t]
|
||||
[else #f]))])
|
||||
(cond
|
||||
[(andmap is-underscore? (syntax->list #'(rng-params ...)))
|
||||
#t]
|
||||
[(ormap (λ (x) (and (is-underscore? x) x))
|
||||
(syntax->list #'(rng-params ...)))
|
||||
=>
|
||||
(λ (id)
|
||||
(raise-syntax-error '->i
|
||||
"expected all of the identifiers to be underscores, or none of them to be"
|
||||
stx
|
||||
id))]
|
||||
[else #f]))])
|
||||
(let ([dup (check-duplicate-identifier
|
||||
(append (if rng-underscores?
|
||||
'()
|
||||
(syntax->list #'(rng-params ...)))
|
||||
(syntax->list #'(dom-params ...))))])
|
||||
(when dup
|
||||
(raise-syntax-error #f "duplicate identifier" stx dup)))
|
||||
#`(let-syntax ([parameterize-this
|
||||
(let ([old-param (syntax-parameter-value #'making-a-method)])
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ body) #'body]
|
||||
[(_ id body)
|
||||
(if (syntax? old-param)
|
||||
(with-syntax ([param old-param])
|
||||
(syntax/loc stx
|
||||
(syntax-parameterize
|
||||
([param (make-this-transformer #'id)])
|
||||
body)))
|
||||
#'body)])))])
|
||||
(syntax-parameterize
|
||||
((making-a-method #f))
|
||||
#,(syntax-property
|
||||
#`(build-->d mtd?
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
|
||||
#,(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... rst-ctc)))
|
||||
#f)
|
||||
#,(if pre-cond
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... #,pre-cond))
|
||||
#f)
|
||||
#,(syntax-case #'rng-ctcs ()
|
||||
[#f #f]
|
||||
[(ctc ...)
|
||||
(if rng-underscores?
|
||||
#'(box (list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))
|
||||
#'(list (λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))])
|
||||
#,(if post-cond
|
||||
#`(λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... #,post-cond))
|
||||
#f)
|
||||
'(mandatory-kwd ...)
|
||||
'(optional-kwd ...)
|
||||
(λ (f)
|
||||
#,(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ args (apply f args)))))
|
||||
'racket/contract:contract
|
||||
(let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)])
|
||||
(vector this->i
|
||||
;; the -> in the original input to this guy
|
||||
(let ([kwd (list (car (syntax-e stx)))])
|
||||
(if post-kwd
|
||||
(cons post-kwd kwd)
|
||||
kwd))
|
||||
(if pre-kwd
|
||||
(list pre-kwd)
|
||||
'())))))))))))))]))
|
||||
|
||||
(define ->d-tail-key (gensym '->d-tail-key))
|
||||
|
||||
(define (->d-proj ->d-stct)
|
||||
(let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))]
|
||||
[mandatory-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
|
||||
(if (->d-mtd? ->d-stct) 1 0))]
|
||||
[non-kwd-ctc-count (+ mandatory-count opt-count)]
|
||||
[arity
|
||||
(cond
|
||||
[(->d-rest-ctc ->d-stct)
|
||||
(make-arity-at-least mandatory-count)]
|
||||
[else
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(= i opt-count)
|
||||
(list (+ mandatory-count i))]
|
||||
[else
|
||||
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
|
||||
(λ (blame)
|
||||
(let ([this->d-id (gensym '->d-tail-key)])
|
||||
(λ (val)
|
||||
(check-procedure val
|
||||
(->d-mtd? ->d-stct)
|
||||
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
|
||||
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
|
||||
(->d-mandatory-keywords ->d-stct)
|
||||
(->d-optional-keywords ->d-stct)
|
||||
blame)
|
||||
(let ([kwd-proc
|
||||
(λ (kwd-args kwd-arg-vals . raw-orig-args)
|
||||
(let* ([orig-args (if (->d-mtd? ->d-stct)
|
||||
(cdr raw-orig-args)
|
||||
raw-orig-args)]
|
||||
[this (and (->d-mtd? ->d-stct) (car raw-orig-args))]
|
||||
[dep-pre-args
|
||||
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
|
||||
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
|
||||
[thunk
|
||||
(λ ()
|
||||
(keyword-apply
|
||||
val
|
||||
kwd-args
|
||||
|
||||
;; contracted keyword arguments
|
||||
(let loop ([all-kwds (->d-keywords ->d-stct)]
|
||||
[kwd-ctcs (->d-keyword-ctcs ->d-stct)]
|
||||
[building-kwd-args kwd-args]
|
||||
[building-kwd-arg-vals kwd-arg-vals])
|
||||
(cond
|
||||
[(or (null? building-kwd-args) (null? all-kwds)) '()]
|
||||
[else (if (eq? (car all-kwds)
|
||||
(car building-kwd-args))
|
||||
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
|
||||
|
||||
(append
|
||||
;; this parameter (if necc.)
|
||||
(if (->d-mtd? ->d-stct)
|
||||
(list (car raw-orig-args))
|
||||
'())
|
||||
|
||||
;; contracted ordinary arguments
|
||||
(let loop ([args orig-args]
|
||||
[non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
|
||||
(->d-optional-dom-ctcs ->d-stct))])
|
||||
(cond
|
||||
[(null? args)
|
||||
(if (->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame))
|
||||
'())]
|
||||
[(null? non-kwd-ctcs)
|
||||
(if (->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame))
|
||||
|
||||
;; ran out of arguments, but don't have a rest parameter.
|
||||
;; procedure-reduce-arity (or whatever the new thing is
|
||||
;; going to be called) should ensure this doesn't happen.
|
||||
(error 'shouldnt\ happen))]
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame))
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))]
|
||||
[rng (let ([rng (->d-range ->d-stct)])
|
||||
(cond
|
||||
[(not rng) #f]
|
||||
[(box? rng)
|
||||
(map (λ (val) (apply val dep-pre-args))
|
||||
(unbox rng))]
|
||||
[else rng]))]
|
||||
[rng-underscore? (box? (->d-range ->d-stct))])
|
||||
(when (->d-pre-cond ->d-stct)
|
||||
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
|
||||
(raise-blame-error (blame-swap blame)
|
||||
val
|
||||
"#:pre-cond violation~a"
|
||||
(build-values-string ", argument" dep-pre-args))))
|
||||
(call-with-immediate-continuation-mark
|
||||
->d-tail-key
|
||||
(λ (first-mark)
|
||||
(cond
|
||||
[(and rng
|
||||
(not (and first-mark
|
||||
(eq? this->d-id (car first-mark))
|
||||
(andmap eq? raw-orig-args (cdr first-mark)))))
|
||||
(call-with-values
|
||||
(λ ()
|
||||
(with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args)
|
||||
(thunk)))
|
||||
(λ orig-results
|
||||
(let* ([range-count (length rng)]
|
||||
[post-args (append orig-results raw-orig-args)]
|
||||
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
|
||||
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
|
||||
post-args (->d-rest-ctc ->d-stct)
|
||||
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
|
||||
(when (->d-post-cond ->d-stct)
|
||||
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"#:post-cond violation~a~a"
|
||||
(build-values-string ", argument" dep-pre-args)
|
||||
(build-values-string (if (null? dep-pre-args)
|
||||
", result"
|
||||
"\n result")
|
||||
orig-results))))
|
||||
|
||||
(unless (= range-count (length orig-results))
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"expected ~a results, got ~a"
|
||||
range-count
|
||||
(length orig-results)))
|
||||
(apply
|
||||
values
|
||||
(let loop ([results orig-results]
|
||||
[result-contracts rng])
|
||||
(cond
|
||||
[(null? result-contracts) '()]
|
||||
[else
|
||||
(cons
|
||||
(invoke-dep-ctc (car result-contracts)
|
||||
(if rng-underscore? #f dep-post-args)
|
||||
(car results)
|
||||
blame)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))]
|
||||
[else
|
||||
(thunk)])))))])
|
||||
(make-contracted-function
|
||||
(procedure-reduce-keyword-arity
|
||||
(make-keyword-procedure kwd-proc
|
||||
((->d-name-wrapper ->d-stct)
|
||||
(λ args
|
||||
(apply kwd-proc '() '() args))))
|
||||
|
||||
arity
|
||||
(->d-mandatory-keywords ->d-stct)
|
||||
(->d-keywords ->d-stct))
|
||||
->d-stct)))))))
|
||||
|
||||
(define (build-values-string desc dep-pre-args)
|
||||
(cond
|
||||
[(null? dep-pre-args) ""]
|
||||
[(null? (cdr dep-pre-args)) (format "~a was: ~e" desc (car dep-pre-args))]
|
||||
[else
|
||||
(apply
|
||||
string-append
|
||||
(format "~as were:" desc)
|
||||
(let loop ([lst dep-pre-args])
|
||||
(cond
|
||||
[(null? lst) '()]
|
||||
[else (cons (format "\n ~e" (car lst))
|
||||
(loop (cdr lst)))])))]))
|
||||
|
||||
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
|
||||
(define (invoke-dep-ctc dep-ctc dep-args val blame)
|
||||
(let ([ctc (coerce-contract '->d (if dep-args
|
||||
(apply dep-ctc dep-args)
|
||||
dep-ctc))])
|
||||
(((contract-projection ctc) blame) val)))
|
||||
|
||||
;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
|
||||
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
|
||||
(append
|
||||
|
||||
;; ordinary args (possibly including `this' as the first element)
|
||||
(let loop ([count non-kwd-ctc-count]
|
||||
[args args])
|
||||
(cond
|
||||
[(zero? count)
|
||||
(if rest-arg?
|
||||
(list args)
|
||||
'())]
|
||||
[(null? args) (cons the-unsupplied-arg (loop (- count 1) null))]
|
||||
[else (cons (car args) (loop (- count 1) (cdr args)))]))
|
||||
|
||||
;; kwd args
|
||||
(let loop ([all-kwds all-kwds]
|
||||
[kwds supplied-kwds]
|
||||
[args supplied-args])
|
||||
(cond
|
||||
[(null? all-kwds) null]
|
||||
[else (let* ([kwd (car all-kwds)]
|
||||
[kwd-matches? (and (not (null? kwds)) (eq? (car kwds) kwd))])
|
||||
(if kwd-matches?
|
||||
(cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args)))
|
||||
(cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))]))))
|
||||
|
||||
(define (build-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
|
||||
rest-ctc pre-cond range post-cond
|
||||
mandatory-kwds optional-kwds
|
||||
name-wrapper)
|
||||
(let ([kwd/ctc-pairs (sort
|
||||
(map cons
|
||||
(append mandatory-kwds optional-kwds)
|
||||
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
|
||||
(λ (x y) (keyword<? (car x) (car y))))])
|
||||
(make-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
(map cdr kwd/ctc-pairs)
|
||||
rest-ctc pre-cond range post-cond
|
||||
(map car kwd/ctc-pairs)
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
name-wrapper)))
|
||||
|
||||
;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that
|
||||
;; is under the contract, and "dr???" refers to the arguments & the results of the function that
|
||||
;; is under the contract.
|
||||
;; the `box' in the range only serves to differentiate between range contracts that depend on
|
||||
;; both the domain and the range from those that depend only on the domain (and thus, those
|
||||
;; that can be applied early)
|
||||
(define-struct ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
|
||||
mandatory-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
optional-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
keyword-ctcs ;; (listof (-> d??? ctc))
|
||||
rest-ctc ;; (or/c false/c (-> d??? ctc))
|
||||
pre-cond ;; (-> d??? boolean)
|
||||
range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
|
||||
post-cond ;; (-> dr??? boolean)
|
||||
keywords ;; (listof keywords) -- sorted by keyword<
|
||||
mandatory-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
optional-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
name-wrapper) ;; (-> proc proc)
|
||||
|
||||
#:omit-define-syntaxes
|
||||
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection ->d-proj
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(let* ([counting-id 'x]
|
||||
[ids '(x y z w)]
|
||||
[next-id
|
||||
(λ ()
|
||||
(cond
|
||||
[(pair? ids)
|
||||
(begin0 (car ids)
|
||||
(set! ids (cdr ids)))]
|
||||
[(null? ids)
|
||||
(begin0
|
||||
(string->symbol (format "~a0" counting-id))
|
||||
(set! ids 1))]
|
||||
[else
|
||||
(begin0
|
||||
(string->symbol (format "~a~a" counting-id ids))
|
||||
(set! ids (+ ids 1)))]))])
|
||||
`(->i (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
|
||||
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
|
||||
,@(if (->d-rest-ctc ctc)
|
||||
(list '#:rest (next-id) '...)
|
||||
'())
|
||||
,@(if (->d-pre-cond ctc)
|
||||
(list '#:pre-cond '...)
|
||||
(list))
|
||||
,(let ([range (->d-range ctc)])
|
||||
(cond
|
||||
[(not range) 'any]
|
||||
[(box? range)
|
||||
(let ([range (unbox range)])
|
||||
(cond
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[_ ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(_ ...)) range))]))]
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[,(next-id) ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
|
||||
,@(if (->d-post-cond ctc)
|
||||
(list '#:post-cond '...)
|
||||
(list)))))
|
||||
|
||||
#:first-order (λ (ctc) (λ (x) #f))
|
||||
#:stronger (λ (this that) (eq? this that))))
|
||||
|
||||
|
|
@ -1,598 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "guts.rkt"
|
||||
"arrow.rkt"
|
||||
"opt.rkt"
|
||||
racket/stxparam
|
||||
|
||||
(for-syntax racket/base
|
||||
syntax/stx
|
||||
syntax/name
|
||||
"arr-i-parse.rkt"
|
||||
"opt-guts.rkt"
|
||||
"helpers.rkt"
|
||||
"arr-util.rkt"))
|
||||
|
||||
(provide ->i)
|
||||
|
||||
(define-for-syntax (make-this-parameters id)
|
||||
(if (syntax-parameter-value #'making-a-method)
|
||||
(list id)
|
||||
null))
|
||||
|
||||
;; parses everything after the mandatory and optional doms in a ->d contract
|
||||
(define-for-syntax (parse-leftover stx leftover)
|
||||
(let*-values ([(raw-optional-doms leftover)
|
||||
(syntax-case leftover ()
|
||||
[(kwd . leftover2)
|
||||
(keyword? (syntax-e #'kwd))
|
||||
(values '() leftover)]
|
||||
[(dep-range)
|
||||
(values '() leftover)]
|
||||
[(dep-range #:post-cond expr)
|
||||
(values '() leftover)]
|
||||
[((opts ...) . rest)
|
||||
(values #'(opts ...) #'rest)]
|
||||
[_ (values '() leftover)])]
|
||||
[(id/rest-id leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:rest [id rest-expr] . leftover)
|
||||
(and (identifier? #'id)
|
||||
(not (keyword? (syntax-e #'rest-expr))))
|
||||
(values #'(id rest-expr) #'leftover)]
|
||||
[(#:rest [id (id2 ...) rest-expr] . leftover)
|
||||
(and (identifier? #'id)
|
||||
(andmap identifier? (syntax->list #'(id2 ...)))
|
||||
(not (keyword? (syntax-e #'rest-expr))))
|
||||
(values #'(id rest-expr) #'leftover)]
|
||||
[(#:rest something . leftover)
|
||||
(raise-syntax-error #f "expected id+ctc" stx #'something)]
|
||||
[_ (values #f leftover)])]
|
||||
[(pre-cond leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:pre-cond pre-cond . leftover)
|
||||
(values #'pre-cond #'leftover)]
|
||||
[_ (values #f leftover)])]
|
||||
[(range leftover)
|
||||
(syntax-case leftover ()
|
||||
[(range . leftover) (values #'range #'leftover)]
|
||||
[_
|
||||
(raise-syntax-error #f "expected a range expression, but found nothing" stx)])]
|
||||
[(post-cond leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:post-cond post-cond . leftover)
|
||||
(begin
|
||||
(syntax-case range (any)
|
||||
[any (raise-syntax-error #f "cannot have a #:post-cond with any as the range" stx #'post-cond)]
|
||||
[_ (void)])
|
||||
(values #'post-cond #'leftover))]
|
||||
[_ (values #f leftover)])])
|
||||
(syntax-case leftover ()
|
||||
[()
|
||||
(values raw-optional-doms id/rest-id pre-cond range post-cond)]
|
||||
[_
|
||||
(raise-syntax-error #f "bad syntax" stx)])))
|
||||
|
||||
;; verify-->i-structure : syntax syntax -> syntax
|
||||
;; returns the second argument when it has the proper shape for the first two arguments to ->i
|
||||
;; otherwise, raises a syntax error.
|
||||
;; also: drops the extra identifiers in the ->i.
|
||||
(define-for-syntax (verify-->i-structure stx doms)
|
||||
(syntax-case doms ()
|
||||
[((regular ...) (kwd ...))
|
||||
(let ([check-pair-shape
|
||||
(λ (reg)
|
||||
(syntax-case reg ()
|
||||
[(id dom)
|
||||
(identifier? #'id)
|
||||
reg]
|
||||
[(a b)
|
||||
(raise-syntax-error #f "expected an identifier" stx #'a)]
|
||||
|
||||
[(id (id2 ...) dom)
|
||||
(and (identifier? #'id)
|
||||
(andmap identifier? (syntax->list #'(id2 ...))))
|
||||
#'(id dom)]
|
||||
[(id ids dom)
|
||||
(unless (identifier? #'id)
|
||||
(raise-syntax-error #f "expected an identifier" stx #'id))
|
||||
(raise-syntax-error #f "expected an sequence of identifiers" stx #'ids)]
|
||||
[_
|
||||
(raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
|
||||
(list (map check-pair-shape (syntax->list #'(regular ...)))
|
||||
(map
|
||||
(λ (kwd)
|
||||
(syntax-case kwd ()
|
||||
[(kwd ps)
|
||||
#`(kwd #,(check-pair-shape #'ps))]))
|
||||
(syntax->list #'(kwd ...)))))]))
|
||||
|
||||
(define-for-syntax (make-this-transformer this-arg)
|
||||
(with-syntax ([this-arg this-arg])
|
||||
(make-set!-transformer
|
||||
(λ (sstx)
|
||||
(syntax-case sstx (set!)
|
||||
[(set! id arg)
|
||||
(raise-syntax-error #f
|
||||
"can't mutate this"
|
||||
sstx)]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(syntax/loc sstx this-arg)]
|
||||
[(id . args)
|
||||
(datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
|
||||
|
||||
(define-for-syntax (find-pre/post-keywords stx)
|
||||
(let ([pre #f]
|
||||
[post #f])
|
||||
(let loop ([stx (syntax->list stx)])
|
||||
(cond
|
||||
[(syntax? stx)
|
||||
(loop (syntax-e stx))]
|
||||
[(pair? stx)
|
||||
(when (and (syntax? (car stx))
|
||||
(eq? (syntax-e (car stx))
|
||||
'#:pre-cond))
|
||||
(set! pre (car stx)))
|
||||
(when (and (syntax? (car stx))
|
||||
(eq? (syntax-e (car stx))
|
||||
'#:post-cond))
|
||||
(set! post (car stx)))
|
||||
(loop (cdr stx))]
|
||||
[else (void)]))
|
||||
(values pre post)))
|
||||
|
||||
(define-syntax (->i stx)
|
||||
(parse-->i stx)
|
||||
(printf "finished ->i parsing\n")
|
||||
(syntax-case stx ()
|
||||
[(_ (raw-mandatory-doms ...)
|
||||
.
|
||||
leftover)
|
||||
(let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]
|
||||
[(this->i) (gensym '->i)])
|
||||
(define (add-indy-prop stx)
|
||||
(syntax-property stx 'racket/contract:internal-contract (gensym '->i-boundary)))
|
||||
(with-syntax ([(([mandatory-regular-id mandatory-dom/no-prop] ... )
|
||||
([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom/no-prop)] ...))
|
||||
(verify-->i-structure stx (split-doms stx '->i #'(raw-mandatory-doms ...)))]
|
||||
[(([optional-regular-id optional-dom/no-prop] ...)
|
||||
([optional-kwd (optional-kwd-id optional-kwd-dom/no-prop)] ...))
|
||||
(verify-->i-structure stx (split-doms stx '->i raw-optional-doms))])
|
||||
(with-syntax ([(mandatory-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(mandatory-dom/no-prop ...)))]
|
||||
[(mandatory-kwd-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(mandatory-kwd-dom/no-prop ...)))]
|
||||
[(optional-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(optional-dom/no-prop ...)))]
|
||||
[(optional-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->i))
|
||||
(syntax->list #'(optional-kwd-dom/no-prop ...)))])
|
||||
(with-syntax ([((kwd kwd-id) ...)
|
||||
(sort-keywords
|
||||
stx
|
||||
(syntax->list
|
||||
#'((optional-kwd optional-kwd-id) ...
|
||||
(mandatory-kwd mandatory-kwd-id) ...)))]
|
||||
[(this-parameter ...)
|
||||
(make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
|
||||
(car (generate-temporaries '(this)))
|
||||
(datum->syntax stx 'this #f)))])
|
||||
(with-syntax ([(dom-params ...)
|
||||
#`(this-parameter ...
|
||||
mandatory-regular-id ...
|
||||
optional-regular-id ...
|
||||
#,@(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#'(id))
|
||||
#'())
|
||||
kwd-id ...)])
|
||||
(with-syntax ([((rng-params ...) rng-ctcs)
|
||||
(syntax-case range (any values)
|
||||
[(values ctc-pr ...)
|
||||
(with-syntax ([((id ctc/no-prop) ...)
|
||||
(map (lambda (x) (syntax-case x ()
|
||||
[[id ctc/no-prop] #'[id ctc/no-prop]]
|
||||
[[id (id2 ...) ctc/no-prop] #'[id ctc/no-prop]]
|
||||
[x (raise-syntax-error #f "expected binding pair" stx #'x)]))
|
||||
(syntax->list #'(ctc-pr ...)))])
|
||||
(with-syntax ([(ctc ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:positive-position this->i)))
|
||||
(syntax->list #'(ctc/no-prop ...)))])
|
||||
#'((id ...) (ctc ...))))]
|
||||
[any #'(() #f)]
|
||||
[[id ctc]
|
||||
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
|
||||
[[id (id2 ...) ctc]
|
||||
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
|
||||
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
|
||||
[mtd? (and (syntax-parameter-value #'making-a-method) #t)])
|
||||
(let ([rng-underscores?
|
||||
(let ([is-underscore?
|
||||
(λ (x)
|
||||
(syntax-case x (_)
|
||||
[_ #t]
|
||||
[else #f]))])
|
||||
(cond
|
||||
[(andmap is-underscore? (syntax->list #'(rng-params ...)))
|
||||
#t]
|
||||
[(ormap (λ (x) (and (is-underscore? x) x))
|
||||
(syntax->list #'(rng-params ...)))
|
||||
=>
|
||||
(λ (id)
|
||||
(raise-syntax-error '->i
|
||||
"expected all of the identifiers to be underscores, or none of them to be"
|
||||
stx
|
||||
id))]
|
||||
[else #f]))])
|
||||
(let ([dup (check-duplicate-identifier
|
||||
(append (if rng-underscores?
|
||||
'()
|
||||
(syntax->list #'(rng-params ...)))
|
||||
(syntax->list #'(dom-params ...))))])
|
||||
(when dup
|
||||
(raise-syntax-error #f "duplicate identifier" stx dup)))
|
||||
#`(let-syntax ([parameterize-this
|
||||
(let ([old-param (syntax-parameter-value #'making-a-method)])
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ body) #'body]
|
||||
[(_ id body)
|
||||
(if (syntax? old-param)
|
||||
(with-syntax ([param old-param])
|
||||
(syntax/loc stx
|
||||
(syntax-parameterize
|
||||
([param (make-this-transformer #'id)])
|
||||
body)))
|
||||
#'body)])))])
|
||||
(syntax-parameterize
|
||||
((making-a-method #f))
|
||||
#,(syntax-property
|
||||
#`(build-->d mtd?
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
|
||||
#,(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... rst-ctc)))
|
||||
#f)
|
||||
#,(if pre-cond
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... #,pre-cond))
|
||||
#f)
|
||||
#,(syntax-case #'rng-ctcs ()
|
||||
[#f #f]
|
||||
[(ctc ...)
|
||||
(if rng-underscores?
|
||||
#'(box (list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))
|
||||
#'(list (λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))])
|
||||
#,(if post-cond
|
||||
#`(λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... #,post-cond))
|
||||
#f)
|
||||
'(mandatory-kwd ...)
|
||||
'(optional-kwd ...)
|
||||
(λ (f)
|
||||
#,(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ args (apply f args)))))
|
||||
'racket/contract:contract
|
||||
(let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)])
|
||||
(vector this->i
|
||||
;; the -> in the original input to this guy
|
||||
(let ([kwd (list (car (syntax-e stx)))])
|
||||
(if post-kwd
|
||||
(cons post-kwd kwd)
|
||||
kwd))
|
||||
(if pre-kwd
|
||||
(list pre-kwd)
|
||||
'())))))))))))))]))
|
||||
|
||||
(define ->d-tail-key (gensym '->d-tail-key))
|
||||
|
||||
(define (->d-proj ->d-stct)
|
||||
(let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))]
|
||||
[mandatory-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
|
||||
(if (->d-mtd? ->d-stct) 1 0))]
|
||||
[non-kwd-ctc-count (+ mandatory-count opt-count)]
|
||||
[arity
|
||||
(cond
|
||||
[(->d-rest-ctc ->d-stct)
|
||||
(make-arity-at-least mandatory-count)]
|
||||
[else
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(= i opt-count)
|
||||
(list (+ mandatory-count i))]
|
||||
[else
|
||||
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
|
||||
(λ (blame)
|
||||
(let ([this->d-id (gensym '->d-tail-key)])
|
||||
(λ (val)
|
||||
(check-procedure val
|
||||
(->d-mtd? ->d-stct)
|
||||
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
|
||||
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
|
||||
(->d-mandatory-keywords ->d-stct)
|
||||
(->d-optional-keywords ->d-stct)
|
||||
blame)
|
||||
(let ([kwd-proc
|
||||
(λ (kwd-args kwd-arg-vals . raw-orig-args)
|
||||
(let* ([orig-args (if (->d-mtd? ->d-stct)
|
||||
(cdr raw-orig-args)
|
||||
raw-orig-args)]
|
||||
[this (and (->d-mtd? ->d-stct) (car raw-orig-args))]
|
||||
[dep-pre-args
|
||||
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
|
||||
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
|
||||
[thunk
|
||||
(λ ()
|
||||
(keyword-apply
|
||||
val
|
||||
kwd-args
|
||||
|
||||
;; contracted keyword arguments
|
||||
(let loop ([all-kwds (->d-keywords ->d-stct)]
|
||||
[kwd-ctcs (->d-keyword-ctcs ->d-stct)]
|
||||
[building-kwd-args kwd-args]
|
||||
[building-kwd-arg-vals kwd-arg-vals])
|
||||
(cond
|
||||
[(or (null? building-kwd-args) (null? all-kwds)) '()]
|
||||
[else (if (eq? (car all-kwds)
|
||||
(car building-kwd-args))
|
||||
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
|
||||
|
||||
(append
|
||||
;; this parameter (if necc.)
|
||||
(if (->d-mtd? ->d-stct)
|
||||
(list (car raw-orig-args))
|
||||
'())
|
||||
|
||||
;; contracted ordinary arguments
|
||||
(let loop ([args orig-args]
|
||||
[non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
|
||||
(->d-optional-dom-ctcs ->d-stct))])
|
||||
(cond
|
||||
[(null? args)
|
||||
(if (->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame))
|
||||
'())]
|
||||
[(null? non-kwd-ctcs)
|
||||
(if (->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame))
|
||||
|
||||
;; ran out of arguments, but don't have a rest parameter.
|
||||
;; procedure-reduce-arity (or whatever the new thing is
|
||||
;; going to be called) should ensure this doesn't happen.
|
||||
(error 'shouldnt\ happen))]
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame))
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))]
|
||||
[rng (let ([rng (->d-range ->d-stct)])
|
||||
(cond
|
||||
[(not rng) #f]
|
||||
[(box? rng)
|
||||
(map (λ (val) (apply val dep-pre-args))
|
||||
(unbox rng))]
|
||||
[else rng]))]
|
||||
[rng-underscore? (box? (->d-range ->d-stct))])
|
||||
(when (->d-pre-cond ->d-stct)
|
||||
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
|
||||
(raise-blame-error (blame-swap blame)
|
||||
val
|
||||
"#:pre-cond violation~a"
|
||||
(build-values-string ", argument" dep-pre-args))))
|
||||
(call-with-immediate-continuation-mark
|
||||
->d-tail-key
|
||||
(λ (first-mark)
|
||||
(cond
|
||||
[(and rng
|
||||
(not (and first-mark
|
||||
(eq? this->d-id (car first-mark))
|
||||
(andmap eq? raw-orig-args (cdr first-mark)))))
|
||||
(call-with-values
|
||||
(λ ()
|
||||
(with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args)
|
||||
(thunk)))
|
||||
(λ orig-results
|
||||
(let* ([range-count (length rng)]
|
||||
[post-args (append orig-results raw-orig-args)]
|
||||
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
|
||||
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
|
||||
post-args (->d-rest-ctc ->d-stct)
|
||||
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
|
||||
(when (->d-post-cond ->d-stct)
|
||||
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"#:post-cond violation~a~a"
|
||||
(build-values-string ", argument" dep-pre-args)
|
||||
(build-values-string (if (null? dep-pre-args)
|
||||
", result"
|
||||
"\n result")
|
||||
orig-results))))
|
||||
|
||||
(unless (= range-count (length orig-results))
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"expected ~a results, got ~a"
|
||||
range-count
|
||||
(length orig-results)))
|
||||
(apply
|
||||
values
|
||||
(let loop ([results orig-results]
|
||||
[result-contracts rng])
|
||||
(cond
|
||||
[(null? result-contracts) '()]
|
||||
[else
|
||||
(cons
|
||||
(invoke-dep-ctc (car result-contracts)
|
||||
(if rng-underscore? #f dep-post-args)
|
||||
(car results)
|
||||
blame)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))]
|
||||
[else
|
||||
(thunk)])))))])
|
||||
(make-contracted-function
|
||||
(procedure-reduce-keyword-arity
|
||||
(make-keyword-procedure kwd-proc
|
||||
((->d-name-wrapper ->d-stct)
|
||||
(λ args
|
||||
(apply kwd-proc '() '() args))))
|
||||
|
||||
arity
|
||||
(->d-mandatory-keywords ->d-stct)
|
||||
(->d-keywords ->d-stct))
|
||||
->d-stct)))))))
|
||||
|
||||
(define (build-values-string desc dep-pre-args)
|
||||
(cond
|
||||
[(null? dep-pre-args) ""]
|
||||
[(null? (cdr dep-pre-args)) (format "~a was: ~e" desc (car dep-pre-args))]
|
||||
[else
|
||||
(apply
|
||||
string-append
|
||||
(format "~as were:" desc)
|
||||
(let loop ([lst dep-pre-args])
|
||||
(cond
|
||||
[(null? lst) '()]
|
||||
[else (cons (format "\n ~e" (car lst))
|
||||
(loop (cdr lst)))])))]))
|
||||
|
||||
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
|
||||
(define (invoke-dep-ctc dep-ctc dep-args val blame)
|
||||
(let ([ctc (coerce-contract '->d (if dep-args
|
||||
(apply dep-ctc dep-args)
|
||||
dep-ctc))])
|
||||
(((contract-projection ctc) blame) val)))
|
||||
|
||||
;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
|
||||
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
|
||||
(append
|
||||
|
||||
;; ordinary args (possibly including `this' as the first element)
|
||||
(let loop ([count non-kwd-ctc-count]
|
||||
[args args])
|
||||
(cond
|
||||
[(zero? count)
|
||||
(if rest-arg?
|
||||
(list args)
|
||||
'())]
|
||||
[(null? args) (cons the-unsupplied-arg (loop (- count 1) null))]
|
||||
[else (cons (car args) (loop (- count 1) (cdr args)))]))
|
||||
|
||||
;; kwd args
|
||||
(let loop ([all-kwds all-kwds]
|
||||
[kwds supplied-kwds]
|
||||
[args supplied-args])
|
||||
(cond
|
||||
[(null? all-kwds) null]
|
||||
[else (let* ([kwd (car all-kwds)]
|
||||
[kwd-matches? (and (not (null? kwds)) (eq? (car kwds) kwd))])
|
||||
(if kwd-matches?
|
||||
(cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args)))
|
||||
(cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))]))))
|
||||
|
||||
(define (build-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
|
||||
rest-ctc pre-cond range post-cond
|
||||
mandatory-kwds optional-kwds
|
||||
name-wrapper)
|
||||
(let ([kwd/ctc-pairs (sort
|
||||
(map cons
|
||||
(append mandatory-kwds optional-kwds)
|
||||
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
|
||||
(λ (x y) (keyword<? (car x) (car y))))])
|
||||
(make-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
(map cdr kwd/ctc-pairs)
|
||||
rest-ctc pre-cond range post-cond
|
||||
(map car kwd/ctc-pairs)
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
name-wrapper)))
|
||||
|
||||
;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that
|
||||
;; is under the contract, and "dr???" refers to the arguments & the results of the function that
|
||||
;; is under the contract.
|
||||
;; the `box' in the range only serves to differentiate between range contracts that depend on
|
||||
;; both the domain and the range from those that depend only on the domain (and thus, those
|
||||
;; that can be applied early)
|
||||
(define-struct ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
|
||||
mandatory-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
optional-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
keyword-ctcs ;; (listof (-> d??? ctc))
|
||||
rest-ctc ;; (or/c false/c (-> d??? ctc))
|
||||
pre-cond ;; (-> d??? boolean)
|
||||
range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
|
||||
post-cond ;; (-> dr??? boolean)
|
||||
keywords ;; (listof keywords) -- sorted by keyword<
|
||||
mandatory-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
optional-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
name-wrapper) ;; (-> proc proc)
|
||||
|
||||
#:omit-define-syntaxes
|
||||
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection ->d-proj
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(let* ([counting-id 'x]
|
||||
[ids '(x y z w)]
|
||||
[next-id
|
||||
(λ ()
|
||||
(cond
|
||||
[(pair? ids)
|
||||
(begin0 (car ids)
|
||||
(set! ids (cdr ids)))]
|
||||
[(null? ids)
|
||||
(begin0
|
||||
(string->symbol (format "~a0" counting-id))
|
||||
(set! ids 1))]
|
||||
[else
|
||||
(begin0
|
||||
(string->symbol (format "~a~a" counting-id ids))
|
||||
(set! ids (+ ids 1)))]))])
|
||||
`(->i (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
|
||||
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
|
||||
,@(if (->d-rest-ctc ctc)
|
||||
(list '#:rest (next-id) '...)
|
||||
'())
|
||||
,@(if (->d-pre-cond ctc)
|
||||
(list '#:pre-cond '...)
|
||||
(list))
|
||||
,(let ([range (->d-range ctc)])
|
||||
(cond
|
||||
[(not range) 'any]
|
||||
[(box? range)
|
||||
(let ([range (unbox range)])
|
||||
(cond
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[_ ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(_ ...)) range))]))]
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[,(next-id) ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
|
||||
,@(if (->d-post-cond ctc)
|
||||
(list '#:post-cond '...)
|
||||
(list)))))
|
||||
|
||||
#:first-order (λ (ctc) (λ (x) #f))
|
||||
#:stronger (λ (this that) (eq? this that))))
|
||||
|
||||
|
|
@ -27,8 +27,25 @@
|
|||
[y (y/proc xi here pos blame info)])
|
||||
(f x y))))))))))
|
||||
|
||||
#;
|
||||
(build-->i
|
||||
(list number?)
|
||||
(list (λ (x) (coerce-proj (<=/c x))))
|
||||
(λ (proj-x proj-x/i y/proc here pos neg blame info)
|
||||
;; λ arguments are in strange order: first the non-dependent things,
|
||||
;; then the dependent things
|
||||
(λ (f)
|
||||
(λ (x y)
|
||||
(let ([x (x/proj x)]
|
||||
[xi (x/proj/i x)])
|
||||
(let ([y (y/proc xi neg pos blame info)]
|
||||
[yi (y/proc xi here pos blame info)])
|
||||
(f x y)))))))
|
||||
|
||||
(syntax->datum (expand #'(-> number? (<=/c 10) any)))
|
||||
|
||||
|
||||
|
||||
#|
|
||||
test cases:
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user