diff --git a/collects/racket/contract/private/arr-i-old.rkt b/collects/racket/contract/private/arr-i-old.rkt new file mode 100644 index 0000000000..2978bf34de --- /dev/null +++ b/collects/racket/contract/private/arr-i-old.rkt @@ -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) (keywordd 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)))) + diff --git a/collects/racket/contract/private/arr-i.rkt b/collects/racket/contract/private/arr-i.rkt index 2978bf34de..e69de29bb2 100644 --- a/collects/racket/contract/private/arr-i.rkt +++ b/collects/racket/contract/private/arr-i.rkt @@ -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) (keywordd 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)))) - diff --git a/collects/racket/contract/scratch.rkt b/collects/racket/contract/scratch.rkt index 8b16ee356d..5220a0b8a7 100644 --- a/collects/racket/contract/scratch.rkt +++ b/collects/racket/contract/scratch.rkt @@ -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: