From 482481fff5f0ddc42e0fa926f047305d36dc2284 Mon Sep 17 00:00:00 2001 From: Robby Findler Date: Tue, 13 Jul 2010 05:27:09 -0500 Subject: [PATCH] made a bunch of the contract combinators also propogate blame information for use in check syntax --- collects/racket/contract/private/guts.rkt | 70 ++++++++++++++++++++++- collects/racket/contract/private/misc.rkt | 38 ++++++------ 2 files changed, 88 insertions(+), 20 deletions(-) diff --git a/collects/racket/contract/private/guts.rkt b/collects/racket/contract/private/guts.rkt index 7fa3a02f8d..bbdb128f4e 100644 --- a/collects/racket/contract/private/guts.rkt +++ b/collects/racket/contract/private/guts.rkt @@ -46,7 +46,11 @@ ;; for opters check-flat-contract check-flat-named-contract - any) + any + + ;; helpers for adding properties that check syntax uses + define/final-prop + define/subexpression-pos-prop) (define-values (prop:contracted has-contract? value-contract) (let-values ([(prop pred get) @@ -375,3 +379,67 @@ #:first-order (λ (ctc) (predicate-contract-pred ctc)))) (define (build-flat-contract name pred) (make-predicate-contract name pred)) + +(define-syntax (define/final-prop stx) + (syntax-case stx () + [(_ header bodies ...) + (with-syntax ([ctc (if (identifier? #'header) + #'header + (car (syntax-e #'header)))]) + (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) + #'(begin + (define ctc/proc + (let () + (define header bodies ...) + ctc)) + (define-syntax (ctc stx) + (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + #'x + 'racket/contract:contract + (vector (gensym 'ctc) + (list stx) + '()))] + [(_ margs (... ...)) + (syntax-property + #'(ctc/proc margs (... ...)) + 'racket/contract:contract + (vector (gensym 'ctc) + (list (car (syntax-e stx))) + '()))])))))])) + +(define-syntax (define/subexpression-pos-prop stx) + (syntax-case stx () + [(_ header bodies ...) + (with-syntax ([ctc (if (identifier? #'header) + #'header + (car (syntax-e #'header)))]) + (with-syntax ([ctc/proc (string->symbol (format "~a/proc" (syntax-e #'ctc)))]) + #'(begin + (define ctc/proc + (let () + (define header bodies ...) + ctc)) + (define-syntax (ctc stx) + (syntax-case stx () + [x + (identifier? #'x) + (syntax-property + #'x + 'racket/contract:contract + (vector (gensym 'ctc) + (list stx) + '()))] + [(_ margs (... ...)) + (let ([this-one (gensym 'ctc)]) + (with-syntax ([(margs (... ...)) + (map (λ (x) (syntax-property x 'racket/contract:rng-of this-one)) + (syntax->list #'(margs (... ...))))]) + (syntax-property + #'(ctc/proc margs (... ...)) + 'racket/contract:contract + (vector this-one + (list (car (syntax-e stx))) + '()))))])))))])) diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 2590c3a9cd..9b7803a723 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -86,7 +86,7 @@ [(_ ([name ctc ...] ...)) (raise-syntax-error 'flat-rec-contract "expected at least one body expression" stx)])) -(define or/c +(define/subexpression-pos-prop or/c (case-lambda [() (make-none/c '(or/c))] [raw-args @@ -385,7 +385,7 @@ (define false/c #f) -(define (string-len/c n) +(define/final-prop (string-len/c n) (unless (number? n) (error 'string-len/c "expected a number as argument, got ~e" n)) (flat-named-contract @@ -394,7 +394,7 @@ (and (string? x) ((string-length x) . < . n))))) -(define (symbols . ss) +(define/final-prop (symbols . ss) (unless ((length ss) . >= . 1) (error 'symbols "expected at least one argument")) (unless (andmap symbol? ss) @@ -409,7 +409,7 @@ (null? x) (keyword? x) (number? x) (void? x) (eq? x undefined))))) -(define (one-of/c . elems) +(define/final-prop (one-of/c . elems) (unless (andmap atomic-value? elems) (error 'one-of/c "expected chars, symbols, booleans, null, keywords, numbers, void, or undefined, got ~e" elems)) @@ -519,13 +519,13 @@ (unless (real? x) (error 'sym "expected a real number, got ~e" x)))])) -(define (=/c x) +(define/final-prop (=/c x) (check-unary-between/c '=/c x) (make-between/c x x)) -(define (<=/c x) +(define/final-prop (<=/c x) (check-unary-between/c '<=/c x) (make-between/c -inf.0 x)) -(define (>=/c x) +(define/final-prop (>=/c x) (check-unary-between/c '>=/c x) (make-between/c x +inf.0)) (define (check-between/c x y) @@ -533,7 +533,7 @@ (error 'between/c "expected a real number as first argument, got ~e, other arg ~e" x y)) (unless (real? y) (error 'between/c "expected a real number as second argument, got ~e, other arg ~e" y x))) -(define (between/c x y) +(define/final-prop (between/c x y) (check-between/c x y) (make-between/c x y)) @@ -682,7 +682,7 @@ (exact? x) (x . >= . 0))))) -(define (integer-in start end) +(define/final-prop (integer-in start end) (unless (and (integer? start) (exact? start) (integer? end) @@ -695,7 +695,7 @@ (exact? x) (<= start x end))))) -(define (real-in start end) +(define/final-prop (real-in start end) (unless (and (real? start) (real? end)) (error 'real-in "expected two real numbers as arguments, got ~e and ~e" start end)) @@ -705,7 +705,7 @@ (and (real? x) (<= start x end))))) -(define (not/c f) +(define/final-prop (not/c f) (let* ([ctc (coerce-flat-contract 'not/c f)] [pred (flat-contract-predicate ctc)]) (build-flat-contract @@ -760,7 +760,7 @@ (define non-empty-listof (*-immutableof non-empty-list? for-each map andmap non-empty-list non-empty-listof)) -(define (immutable-vector? val) (and (immutable? val) (vector? val))) +(define/final-prop (immutable-vector? val) (and (immutable? val) (vector? val))) (define vector-immutableof (*-immutableof immutable-vector? @@ -770,7 +770,7 @@ immutable-vector vector-immutableof)) -(define (vectorof p) +(define/subexpression-pos-prop (vectorof p) (let* ([ctc (coerce-flat-contract 'vectorof p)] [pred (flat-contract-predicate ctc)]) (build-flat-contract @@ -779,7 +779,7 @@ (and (vector? v) (andmap pred (vector->list v))))))) -(define (vector/c . args) +(define/subexpression-pos-prop (vector/c . args) (let* ([ctcs (coerce-flat-contracts 'vector/c args)] [largs (length args)] [procs (map flat-contract-predicate ctcs)]) @@ -792,7 +792,7 @@ procs (vector->list v))))))) -(define (box/c pred) +(define/final-prop (box/c pred) (let* ([ctc (coerce-flat-contract 'box/c pred)] [p? (flat-contract-predicate ctc)]) (build-flat-contract @@ -1030,7 +1030,7 @@ (syntax-case stx (cons/c) [(_ hdp tlp) (opt/cons-ctc #'hdp #'tlp)])) -(define (list/c . args) +(define/subexpression-pos-prop (list/c . args) (let* ([args (coerce-contracts 'list/c args)]) (if (andmap flat-contract? args) (flat-list/c args) @@ -1101,7 +1101,7 @@ (for/list ([arg/c (in-list args)] [v (in-list x)]) (((contract-projection arg/c) b) v)))))))) -(define (syntax/c ctc-in) +(define/subexpression-pos-prop (syntax/c ctc-in) (let ([ctc (coerce-contract 'syntax/c ctc-in)]) (build-flat-contract (build-compound-type-name 'syntax/c ctc) @@ -1110,7 +1110,7 @@ (and (syntax? val) (pred (syntax-e val)))))))) -(define promise/c +(define/subexpression-pos-prop promise/c (λ (ctc-in) (let* ([ctc (coerce-contract 'promise/c ctc-in)] [ctc-proc (contract-projection ctc)]) @@ -1197,7 +1197,7 @@ (raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))])) -(define (parameter/c x) +(define/subexpression-pos-prop (parameter/c x) (make-parameter/c (coerce-contract 'parameter/c x))) (define-struct parameter/c (ctc)