made a copy of the ->d contract implementation as a starting point for an implementation of ->i (sometimes, paper deadlines can be a Bad Thing...)
This commit is contained in:
Robby Findler
parent
4eb3df7094
commit
f5a190bf80
|
|
@ -4,6 +4,7 @@
|
||||||
;; the PLT code base where appropriate.
|
;; the PLT code base where appropriate.
|
||||||
|
|
||||||
(require "private/arrow.rkt"
|
(require "private/arrow.rkt"
|
||||||
|
"private/arr-i.rkt"
|
||||||
"private/base.rkt"
|
"private/base.rkt"
|
||||||
"private/misc.rkt"
|
"private/misc.rkt"
|
||||||
"private/provide.rkt"
|
"private/provide.rkt"
|
||||||
|
|
@ -21,7 +22,9 @@
|
||||||
making-a-method
|
making-a-method
|
||||||
procedure-accepts-and-more?
|
procedure-accepts-and-more?
|
||||||
check-procedure
|
check-procedure
|
||||||
check-procedure/more)
|
check-procedure/more
|
||||||
|
make-contracted-function)
|
||||||
|
(all-from-out "private/arr-i.rkt")
|
||||||
(except-out (all-from-out "private/misc.rkt")
|
(except-out (all-from-out "private/misc.rkt")
|
||||||
check-between/c
|
check-between/c
|
||||||
check-unary-between/c)
|
check-unary-between/c)
|
||||||
|
|
|
||||||
528
collects/racket/contract/private/arr-i.rkt
Normal file
528
collects/racket/contract/private/arr-i.rkt
Normal file
|
|
@ -0,0 +1,528 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(require "guts.rkt"
|
||||||
|
"arrow.rkt"
|
||||||
|
"opt.rkt"
|
||||||
|
racket/stxparam)
|
||||||
|
(require (for-syntax racket/base)
|
||||||
|
(for-syntax "opt-guts.rkt")
|
||||||
|
(for-syntax "helpers.rkt")
|
||||||
|
(for-syntax syntax/stx)
|
||||||
|
(for-syntax syntax/name)
|
||||||
|
(for-syntax "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 rest-expr . leftover)
|
||||||
|
(begin
|
||||||
|
(unless (identifier? #'id)
|
||||||
|
(raise-syntax-error #f "expected an identifier" stx #'id))
|
||||||
|
(when (keyword? (syntax-e #'rest-expr))
|
||||||
|
(raise-syntax-error #f "expected an expression, not a keyword" stx #'rest-expr)))]
|
||||||
|
[_ (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-->d-structure : syntax syntax -> syntax
|
||||||
|
;; returns the second argument when it has the proper shape for the first two arguments to ->d*
|
||||||
|
;; otherwise, raises a syntax error.
|
||||||
|
(define-for-syntax (verify-->d-structure stx doms)
|
||||||
|
(syntax-case doms ()
|
||||||
|
[((regular ...) (kwd ...))
|
||||||
|
(let ([check-pair-shape
|
||||||
|
(λ (reg)
|
||||||
|
(syntax-case reg ()
|
||||||
|
[(id dom)
|
||||||
|
(identifier? #'id)
|
||||||
|
(void)]
|
||||||
|
[(a b)
|
||||||
|
(raise-syntax-error #f "expected an identifier" stx #'a)]
|
||||||
|
[_
|
||||||
|
(raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
|
||||||
|
(for-each check-pair-shape (syntax->list #'(regular ...)))
|
||||||
|
(for-each
|
||||||
|
(λ (kwd)
|
||||||
|
(syntax-case kwd ()
|
||||||
|
[(kwd ps)
|
||||||
|
(check-pair-shape #'ps)]))
|
||||||
|
(syntax->list #'(kwd ...))))])
|
||||||
|
doms)
|
||||||
|
|
||||||
|
(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-syntax (->i stx)
|
||||||
|
(syntax-case stx ()
|
||||||
|
[(_ (raw-mandatory-doms ...)
|
||||||
|
.
|
||||||
|
leftover)
|
||||||
|
(let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)])
|
||||||
|
(with-syntax ([(([mandatory-regular-id mandatory-doms] ... ) ([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom)] ...))
|
||||||
|
(verify-->d-structure stx (split-doms stx '->d #'(raw-mandatory-doms ...)))]
|
||||||
|
[(([optional-regular-id optional-doms] ... ) ([optional-kwd (optional-kwd-id optional-kwd-dom)] ...))
|
||||||
|
(verify-->d-structure stx (split-doms stx '->d raw-optional-doms))])
|
||||||
|
(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 [id ctc] ...) #'((id ...) (ctc ...))]
|
||||||
|
[(values [id ctc] ... x . y) (raise-syntax-error #f "expected binding pair" stx #'x)]
|
||||||
|
[any #'(() #f)]
|
||||||
|
[[id ctc] #'((id) (ctc))]
|
||||||
|
[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 '->d
|
||||||
|
"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))
|
||||||
|
(build-->d mtd?
|
||||||
|
(list (λ (dom-params ...)
|
||||||
|
(parameterize-this this-parameter ... mandatory-doms)) ...)
|
||||||
|
(list (λ (dom-params ...)
|
||||||
|
(parameterize-this this-parameter ... optional-doms)) ...)
|
||||||
|
(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)))))))))))))]))
|
||||||
|
|
||||||
|
(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)))]))])
|
||||||
|
`(->d (,@(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))))
|
||||||
|
|
||||||
61
collects/racket/contract/private/arr-util.rkt
Normal file
61
collects/racket/contract/private/arr-util.rkt
Normal file
|
|
@ -0,0 +1,61 @@
|
||||||
|
#lang racket/base
|
||||||
|
|
||||||
|
(provide split-doms
|
||||||
|
sort-keywords)
|
||||||
|
|
||||||
|
;; split-doms : syntax identifier syntax -> syntax
|
||||||
|
;; given a sequence of keywords interpersed with other
|
||||||
|
;; stuff, splits out the keywords and sorts them,
|
||||||
|
;; and leaves the rest of the stuff in a row.
|
||||||
|
(define (split-doms stx name raw-doms)
|
||||||
|
(let loop ([raw-doms raw-doms]
|
||||||
|
[doms '()]
|
||||||
|
[kwd-doms '()])
|
||||||
|
(syntax-case raw-doms ()
|
||||||
|
[() (list (reverse doms)
|
||||||
|
(sort-keywords stx kwd-doms))]
|
||||||
|
[(kwd arg . rest)
|
||||||
|
(and (keyword? (syntax-e #'kwd))
|
||||||
|
(not (keyword? (syntax-e #'arg))))
|
||||||
|
(loop #'rest
|
||||||
|
doms
|
||||||
|
(cons #'(kwd arg) kwd-doms))]
|
||||||
|
[(kwd arg . rest)
|
||||||
|
(and (keyword? (syntax-e #'kwd))
|
||||||
|
(keyword? (syntax-e #'arg)))
|
||||||
|
(raise-syntax-error name
|
||||||
|
"cannot have two keywords in a row"
|
||||||
|
stx
|
||||||
|
#'kwd)]
|
||||||
|
[(kwd)
|
||||||
|
(keyword? (syntax-e #'kwd))
|
||||||
|
(raise-syntax-error name
|
||||||
|
"cannot have a keyword at the end"
|
||||||
|
stx
|
||||||
|
#'kwd)]
|
||||||
|
[(x . rest)
|
||||||
|
(loop #'rest (cons #'x doms) kwd-doms)])))
|
||||||
|
|
||||||
|
;; sort-keywords : syntax (listof syntax[(kwd . whatever)] -> (listof syntax[(kwd . whatever)])
|
||||||
|
;; sorts a list of syntax according to the keywords in the list
|
||||||
|
(define (sort-keywords stx kwd/ctc-pairs)
|
||||||
|
(define (insert x lst)
|
||||||
|
(cond
|
||||||
|
[(null? lst) (list x)]
|
||||||
|
[else
|
||||||
|
(let ([fst-kwd (syntax-e (car (syntax-e (car lst))))]
|
||||||
|
[x-kwd (syntax-e (car (syntax-e x)))])
|
||||||
|
(cond
|
||||||
|
[(equal? x-kwd fst-kwd)
|
||||||
|
(raise-syntax-error #f
|
||||||
|
"duplicate keyword"
|
||||||
|
stx
|
||||||
|
(car x))]
|
||||||
|
[(keyword<? x-kwd fst-kwd)
|
||||||
|
(cons x lst)]
|
||||||
|
[else (cons (car lst) (insert x (cdr lst)))]))]))
|
||||||
|
|
||||||
|
(let loop ([pairs kwd/ctc-pairs])
|
||||||
|
(cond
|
||||||
|
[(null? pairs) null]
|
||||||
|
[else (insert (car pairs) (loop (cdr pairs)))])))
|
||||||
|
|
@ -25,7 +25,8 @@ v4 todo:
|
||||||
(for-syntax "opt-guts.rkt")
|
(for-syntax "opt-guts.rkt")
|
||||||
(for-syntax "helpers.rkt")
|
(for-syntax "helpers.rkt")
|
||||||
(for-syntax syntax/stx)
|
(for-syntax syntax/stx)
|
||||||
(for-syntax syntax/name))
|
(for-syntax syntax/name)
|
||||||
|
(for-syntax "arr-util.rkt"))
|
||||||
|
|
||||||
(provide ->
|
(provide ->
|
||||||
->*
|
->*
|
||||||
|
|
@ -36,13 +37,14 @@ v4 todo:
|
||||||
making-a-method
|
making-a-method
|
||||||
procedure-accepts-and-more?
|
procedure-accepts-and-more?
|
||||||
check-procedure
|
check-procedure
|
||||||
check-procedure/more)
|
check-procedure/more
|
||||||
|
make-contracted-function)
|
||||||
|
|
||||||
(define-syntax-parameter making-a-method #f)
|
(define-syntax-parameter making-a-method #f)
|
||||||
(define-for-syntax (make-this-parameters id)
|
(define-for-syntax (make-this-parameters id)
|
||||||
(if (syntax-parameter-value #'making-a-method)
|
(if (syntax-parameter-value #'making-a-method)
|
||||||
(list id)
|
(list id)
|
||||||
null))
|
null))
|
||||||
|
|
||||||
(define-struct contracted-function (proc ctc)
|
(define-struct contracted-function (proc ctc)
|
||||||
#:property prop:procedure 0
|
#:property prop:procedure 0
|
||||||
|
|
@ -234,63 +236,6 @@ v4 todo:
|
||||||
(apply append (map list kwds kwds/c))
|
(apply append (map list kwds kwds/c))
|
||||||
(list rng-name))))]))
|
(list rng-name))))]))
|
||||||
|
|
||||||
;; sort-keywords : syntax (listof syntax[(kwd . whatever)] -> (listof syntax[(kwd . whatever)])
|
|
||||||
;; sorts a list of syntax according to the keywords in the list
|
|
||||||
(define-for-syntax (sort-keywords stx kwd/ctc-pairs)
|
|
||||||
(define (insert x lst)
|
|
||||||
(cond
|
|
||||||
[(null? lst) (list x)]
|
|
||||||
[else
|
|
||||||
(let ([fst-kwd (syntax-e (car (syntax-e (car lst))))]
|
|
||||||
[x-kwd (syntax-e (car (syntax-e x)))])
|
|
||||||
(cond
|
|
||||||
[(equal? x-kwd fst-kwd)
|
|
||||||
(raise-syntax-error #f
|
|
||||||
"duplicate keyword"
|
|
||||||
stx
|
|
||||||
(car x))]
|
|
||||||
[(keyword<? x-kwd fst-kwd)
|
|
||||||
(cons x lst)]
|
|
||||||
[else (cons (car lst) (insert x (cdr lst)))]))]))
|
|
||||||
|
|
||||||
(let loop ([pairs kwd/ctc-pairs])
|
|
||||||
(cond
|
|
||||||
[(null? pairs) null]
|
|
||||||
[else (insert (car pairs) (loop (cdr pairs)))])))
|
|
||||||
|
|
||||||
;; split-doms : syntax identifier syntax -> syntax
|
|
||||||
;; given a sequence of keywords interpersed with other
|
|
||||||
;; stuff, splits out the keywords and sorts them,
|
|
||||||
;; and leaves the rest of the stuff in a row.
|
|
||||||
(define-for-syntax (split-doms stx name raw-doms)
|
|
||||||
(let loop ([raw-doms raw-doms]
|
|
||||||
[doms '()]
|
|
||||||
[kwd-doms '()])
|
|
||||||
(syntax-case raw-doms ()
|
|
||||||
[() (list (reverse doms)
|
|
||||||
(sort-keywords stx kwd-doms))]
|
|
||||||
[(kwd arg . rest)
|
|
||||||
(and (keyword? (syntax-e #'kwd))
|
|
||||||
(not (keyword? (syntax-e #'arg))))
|
|
||||||
(loop #'rest
|
|
||||||
doms
|
|
||||||
(cons #'(kwd arg) kwd-doms))]
|
|
||||||
[(kwd arg . rest)
|
|
||||||
(and (keyword? (syntax-e #'kwd))
|
|
||||||
(keyword? (syntax-e #'arg)))
|
|
||||||
(raise-syntax-error name
|
|
||||||
"cannot have two keywords in a row"
|
|
||||||
stx
|
|
||||||
#'kwd)]
|
|
||||||
[(kwd)
|
|
||||||
(keyword? (syntax-e #'kwd))
|
|
||||||
(raise-syntax-error name
|
|
||||||
"cannot have a keyword at the end"
|
|
||||||
stx
|
|
||||||
#'kwd)]
|
|
||||||
[(x . rest)
|
|
||||||
(loop #'rest (cons #'x doms) kwd-doms)])))
|
|
||||||
|
|
||||||
(define-for-syntax (->-helper stx)
|
(define-for-syntax (->-helper stx)
|
||||||
(syntax-case stx ()
|
(syntax-case stx ()
|
||||||
[(-> raw-doms ... last-one)
|
[(-> raw-doms ... last-one)
|
||||||
|
|
|
||||||
Loading…
Reference in New Issue
Block a user