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.
|
||||
|
||||
(require "private/arrow.rkt"
|
||||
"private/arr-i.rkt"
|
||||
"private/base.rkt"
|
||||
"private/misc.rkt"
|
||||
"private/provide.rkt"
|
||||
|
|
@ -21,7 +22,9 @@
|
|||
making-a-method
|
||||
procedure-accepts-and-more?
|
||||
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")
|
||||
check-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 "helpers.rkt")
|
||||
(for-syntax syntax/stx)
|
||||
(for-syntax syntax/name))
|
||||
(for-syntax syntax/name)
|
||||
(for-syntax "arr-util.rkt"))
|
||||
|
||||
(provide ->
|
||||
->*
|
||||
|
|
@ -36,13 +37,14 @@ v4 todo:
|
|||
making-a-method
|
||||
procedure-accepts-and-more?
|
||||
check-procedure
|
||||
check-procedure/more)
|
||||
check-procedure/more
|
||||
make-contracted-function)
|
||||
|
||||
(define-syntax-parameter making-a-method #f)
|
||||
(define-for-syntax (make-this-parameters id)
|
||||
(if (syntax-parameter-value #'making-a-method)
|
||||
(list id)
|
||||
null))
|
||||
(list id)
|
||||
null))
|
||||
|
||||
(define-struct contracted-function (proc ctc)
|
||||
#:property prop:procedure 0
|
||||
|
|
@ -234,63 +236,6 @@ v4 todo:
|
|||
(apply append (map list kwds kwds/c))
|
||||
(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)
|
||||
(syntax-case stx ()
|
||||
[(-> raw-doms ... last-one)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user