diff --git a/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt index e898a8ea6f..f516ed4dea 100644 --- a/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt +++ b/pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt @@ -84,29 +84,47 @@ (test-name '(->i () any) (->i () () any)) (test-name '(->i () any) (->i () any)) - (test-name '(->i () [x () ...]) + (test-name '(->i () [x () number?]) (->i () () [x () number?])) (test-name '(->i () [q number?]) (->i () () [q number?])) (test-name '(->i () (values [x number?] [y number?])) (->i () (values [x number?] [y number?]))) - (test-name '(->i () (values [x (y) ...] [y number?])) + (test-name '(->i () (values [x (y) number?] [y number?])) (->i () (values [x (y) number?] [y number?]))) (test-name '(->i ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any) (->i ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any)) - (test-name '(->i () #:pre () ... [q number?]) - (->i () #:pre () #t [q number?])) - (test-name '(->i () #:pre () ... [q () ...] #:post () ...) - (->i () #:pre () #t [q () number?] #:post () #t)) - (test-name '(->i ([x integer?]) #:pre (x) ... [q (x) ...] #:post (x) ...) - (->i ([x integer?]) #:pre (x) #t [q (x) number?] #:post (x) #t)) - (test-name '(->i ([x real?]) [_ (x) ...]) + (test-name '(->i () #:pre () #t [q number?]) + (->i () #:pre () #t [q number?])) + (test-name '(->i () #:pre () #t [q () number?] #:post () #t) + (->i () #:pre () #t [q () number?] #:post () #t)) + (test-name '(->i ([x integer?]) #:pre (x) #t [q (x) number?] #:post (x) #t) + (->i ([x integer?]) #:pre (x) #t [q (x) number?] #:post (x) #t)) + (test-name '(->i ([x real?]) [_ (x) (>/c x)]) (->i ([x real?]) [_ (x) (>/c x)])) - (test-name '(->i ([x any/c]) #:pre/name (x) "pair" ... #:pre/name (x) "car" ... any) + (test-name '(->i ([x any/c]) #:pre/name (x) "pair" (pair? x) #:pre/name (x) "car" (car x) any) (->i ([x any/c]) #:pre/name (x) "pair" (pair? x) #:pre/name (x) "car" (car x) any)) - (test-name '(->i ([x any/c]) [y () ...] #:post/name (y) "pair" ... #:post/name (y) "car" ...) + (test-name '(->i ([x any/c]) [y () any/c] #:post/name (y) "pair" (pair? y) + #:post/name (y) "car" (car y)) (->i ([x any/c]) [y () any/c] #:post/name (y) "pair" (pair? y) #:post/name (y) "car" (car y))) + (test-name '(->i ([p any/c] + [q (p) (if (equal? p 10) 'aha any/c)]) + #:rest [rest (p) (if (equal? p 11) 'aha any/c)] + #:pre (q) (if (equal? q 12) 'aha any/c) + [res (p) (if (equal? p 13) 'aha any/c)] + #:post (q) (if (equal? q 14) 'aha any/c)) + (->i ([p any/c] + [q (p) (if (equal? p 10) 'aha any/c)]) + #:rest [rest (p) (if (equal? p 11) 'aha any/c)] + #:pre (q) (if (equal? q 12) 'aha any/c) + [res (p) (if (equal? p 13) 'aha any/c)] + #:post (q) (if (equal? q 14) 'aha any/c))) + (test-name '(->i ((p any/c) (q (p) (void (((((...))))) 2 3 ...))) any) + (->i ([p any/c] + [q (p) (void (((((1))))) 2 3 4 5 6 7 8 9 10)]) + any)) + (test-name '(case->) (case->)) (test-name '(case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any)) diff --git a/racket/collects/racket/contract/private/arr-i-parse.rkt b/racket/collects/racket/contract/private/arr-i-parse.rkt index 4ea790fef2..d067ae05fc 100644 --- a/racket/collects/racket/contract/private/arr-i-parse.rkt +++ b/racket/collects/racket/contract/private/arr-i-parse.rkt @@ -32,7 +32,8 @@ code does the parsing and validation of the syntax. ;; var : identifier? ;; vars : (or/c #f (listof identifier?)) -- #f if non-dep ;; ctc : syntax[expr] -(struct arg/res (var vars ctc) #:transparent) +;; quoted-dep-src-code : sexp -- only useful if vars is not #f +(struct arg/res (var vars ctc quoted-dep-src-code) #:transparent) ;; kwd : (or/c #f syntax[kwd]) ;; optional? : boolean? @@ -49,7 +50,7 @@ code does the parsing and validation of the syntax. ;; vars : (listof identifier?) ;; exp : syntax[expr] ;; str : (or/c #f syntax[expr]) -(struct pre/post (vars str exp) #:transparent) +(struct pre/post (vars str exp quoted-dep-src-code) #:transparent) (define (parse-->i stx) (if (identifier? stx) @@ -238,6 +239,39 @@ code does the parsing and validation of the syntax. (list fst) (cons fst (loop (cdr vars)))))]))) +(define (compute-quoted-src-expression stx) + (define max-depth 4) + (define max-width 5) + (let loop ([stx stx] + [depth max-depth]) + (cond + [(zero? depth) '...] + [else + (define lst (syntax->list stx)) + (cond + [lst + (if (<= (length lst) max-width) + (for/list ([ele (in-list lst)]) + (loop ele (- depth 1))) + (append (for/list ([ele (in-list lst)] + [i (in-range (- max-width 1))]) + (loop ele (+ depth 1))) + '(...)))] + [else + (define ele (syntax-e stx)) + (cond + [(or (symbol? ele) + (boolean? ele) + (char? ele) + (number? ele)) + ele] + [(string? ele) + (if (< (string-length ele) max-width) + ele + '...)] + [else + '...])])]))) + (define (parse-doms stx optional? doms) (let loop ([doms doms]) (syntax-case doms () @@ -245,30 +279,34 @@ code does the parsing and validation of the syntax. (keyword? (syntax-e #'kwd)) (begin (check-id stx #'id) - (cons (arg #'id #f #'ctc-expr #'kwd optional?) + (cons (arg #'id #f #'ctc-expr #f #'kwd optional?) (loop #'rest)))] [(kwd [id (id2 ...) ctc-expr] . rest) (keyword? (syntax-e #'kwd)) (begin (check-id stx #'id) (for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) - (cons (arg #'id (syntax->list #'(id2 ...)) #'ctc-expr #'kwd optional?) + (cons (arg #'id (syntax->list #'(id2 ...)) #'ctc-expr + (compute-quoted-src-expression #'ctc-expr) + #'kwd optional?) (loop #'rest)))] [([id ctc-expr] . rest) (begin (check-id stx #'id) - (cons (arg #'id #f #'ctc-expr #f optional?) + (cons (arg #'id #f #'ctc-expr #f #f optional?) (loop #'rest)))] [([id (id2 ...) ctc-expr] . rest) (begin (check-id stx #'id) (for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) - (cons (arg #'id (syntax->list #'(id2 ...)) #'ctc-expr #f optional?) + (cons (arg #'id (syntax->list #'(id2 ...)) #'ctc-expr + (compute-quoted-src-expression #'ctc-expr) + #f optional?) (loop #'rest)))] [() '()] [(a . rest) (raise-syntax-error #f "expected an argument specification" stx #'a)]))) - + (define (parse-range stx range) (syntax-case range (any values _) [(values ctc-pr ...) @@ -277,20 +315,22 @@ code does the parsing and validation of the syntax. (begin (check-id stx #'id) (if (free-identifier=? #'_ #'id) - (eres #'id #f #'ctc (car (generate-temporaries '(eres)))) - (lres #'id #f #'ctc)))] + (eres #'id #f #'ctc (car (generate-temporaries '(eres))) #f) + (lres #'id #f #'ctc #f)))] [[id (id2 ...) ctc] (begin (check-id stx #'id) (for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) (if (free-identifier=? #'_ #'id) (eres #'id (syntax->list #'(id2 ...)) #'ctc + (compute-quoted-src-expression #'ctc) (car (generate-temporaries '(eres)))) - (lres #'id (syntax->list #'(id2 ...)) #'ctc)))] + (lres #'id (syntax->list #'(id2 ...)) #'ctc + (compute-quoted-src-expression #'ctc))))] [(a ...) (let ([len (length (syntax->list #'(a ...)))]) (unless (or (= 2 len) (= 3 len)) - (raise-syntax-error + (raise-syntax-error #f "wrong number of pieces in range portion of the contract, expected id+ctc" stx #'x)) @@ -300,20 +340,23 @@ code does the parsing and validation of the syntax. (syntax->list #'(ctc-pr ...)))] [any #f] [[_ ctc] - (list (eres #'_ #f #'ctc (car (generate-temporaries '(eres)))))] + (list (eres #'_ #f #'ctc #f (car (generate-temporaries '(eres)))))] [[id ctc] (begin (check-id stx #'id) - (list (lres #'id #f #'ctc)))] + (list (lres #'id #f #'ctc #f)))] [[_ (id2 ...) ctc] (begin (for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) - (list (eres #'_ (syntax->list #'(id2 ...)) #'ctc (car (generate-temporaries '(eres))))))] + (list (eres #'_ (syntax->list #'(id2 ...)) #'ctc + (compute-quoted-src-expression #'ctc) + (car (generate-temporaries '(eres))))))] [[id (id2 ...) ctc] (begin (check-id stx #'id) (for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) - (list (lres #'id (syntax->list #'(id2 ...)) #'ctc)))] + (list (lres #'id (syntax->list #'(id2 ...)) #'ctc + (compute-quoted-src-expression #'ctc))))] [x (raise-syntax-error #f "expected the range portion" stx #'x)])) (define (check-id stx id) @@ -353,7 +396,7 @@ code does the parsing and validation of the syntax. [(#:rest [id rest-expr] . leftover) (begin (check-id stx #'id) - (values (arg/res #'id #f #'rest-expr) + (values (arg/res #'id #f #'rest-expr #f) #'leftover))] [(#:rest [id (id2 ...) rest-expr] . leftover) (begin @@ -362,7 +405,8 @@ code does the parsing and validation of the syntax. (syntax->list #'(id2 ...))) (values (arg/res #'id (syntax->list #'(id2 ...)) - #'rest-expr) + #'rest-expr + (compute-quoted-src-expression #'rest-expr)) #'leftover))] [(#:rest other . leftover) (raise-syntax-error #f "expected an id+ctc" @@ -393,7 +437,9 @@ code does the parsing and validation of the syntax. [x (void)]) (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) (loop #'pre-leftover - (cons (pre/post (syntax->list #'(id ...)) #f #'pre-cond) conditions)))] + (cons (pre/post (syntax->list #'(id ...)) #f #'pre-cond + (compute-quoted-src-expression #'pre-cond)) + conditions)))] [(#:pre . rest) (raise-syntax-error #f @@ -420,7 +466,8 @@ code does the parsing and validation of the syntax. stx #'str)) (loop #'pre-leftover - (cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'pre-cond) + (cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'pre-cond + (compute-quoted-src-expression #'pre-cond)) conditions)))] [(#:pre/name . rest) (raise-syntax-error @@ -453,7 +500,9 @@ code does the parsing and validation of the syntax. #f "cannot have a #:post with any as the range" stx #'post-cond)] [_ (void)]) (loop #'leftover - (cons (pre/post (syntax->list #'(id ...)) #f #'post-cond) post-conds)))] + (cons (pre/post (syntax->list #'(id ...)) #f #'post-cond + (compute-quoted-src-expression #'post-cond)) + post-conds)))] [(#:post a b . stuff) (begin (raise-syntax-error @@ -479,7 +528,8 @@ code does the parsing and validation of the syntax. stx #'str)) (loop #'leftover - (cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'post-cond) + (cons (pre/post (syntax->list #'(id ...)) (syntax-e #'str) #'post-cond + (compute-quoted-src-expression #'post-cond)) post-conds)))] [(#:post/name . stuff) (begin diff --git a/racket/collects/racket/contract/private/arr-i.rkt b/racket/collects/racket/contract/private/arr-i.rkt index 3e54e2c539..20731ce97c 100644 --- a/racket/collects/racket/contract/private/arr-i.rkt +++ b/racket/collects/racket/contract/private/arr-i.rkt @@ -125,6 +125,7 @@ pre/post-procs mandatory-args opt-args mandatory-kwds opt-kwds rest mtd? here mk-wrapper mk-val-first-wrapper name-info) + #:property prop:custom-write custom-write-property-proc #:property prop:contract (build-contract-property #:val-first-projection @@ -161,12 +162,13 @@ . ,(loop (cdr infos) (cdr ctcs) dep-ctcs)))] [(dep) + (define body-src (list-ref info 5)) (if (skip? info) (loop (cdr infos) ctcs (cdr dep-ctcs)) `(,@(if kwd (list kwd) (list)) - [,var ,vars ...] + [,var ,vars ,body-src] . ,(loop (cdr infos) ctcs (cdr dep-ctcs))))]))]))) (let* ([name-info (->i-name-info ctc)] @@ -193,14 +195,18 @@ ,(contract-name (car (reverse (map cdr (->i-arg-ctcs ctc)))))])] [(dep) `(#:rest [,(list-ref rest-info 1) - ,(list-ref rest-info 2) ...])]) + ,(list-ref rest-info 2) + ,(list-ref rest-info 3)])]) '()) ,@(apply append (for/list ([pre-info pre-infos]) - (if (cadr pre-info) - `(#:pre/name ,@pre-info ...) - `(#:pre ,(car pre-info) ...)))) + (define ids (list-ref pre-info 0)) + (define name (list-ref pre-info 1)) + (define code (list-ref pre-info 2)) + (if name + `(#:pre/name ,ids ,name ,code) + `(#:pre ,ids ,code)))) ,(cond [(not rng-info) 'any] @@ -217,9 +223,12 @@ ,@(apply append (for/list ([post-info post-infos]) - (if (cadr post-info) - `(#:post/name ,@post-info ...) - `(#:post ,(car post-info) ...))))))) + (define ids (list-ref post-info 0)) + (define name (list-ref post-info 1)) + (define code (list-ref post-info 2)) + (if name + `(#:post/name ,ids ,name ,code) + `(#:post ,ids ,code))))))) #:first-order (λ (ctc) (let ([has-rest (->i-rest ctc)] @@ -1164,16 +1173,19 @@ '()) ,(and (arg-kwd an-arg) (syntax-e (arg-kwd an-arg))) - ,(arg-optional? an-arg))) + ,(arg-optional? an-arg) + ,(arg/res-quoted-dep-src-code an-arg))) #,(if (istx-rst an-istx) (if (arg/res-vars (istx-rst an-istx)) `(dep ,(syntax-e (arg/res-var (istx-rst an-istx))) - ,(map syntax-e (arg/res-vars (istx-rst an-istx)))) + ,(map syntax-e (arg/res-vars (istx-rst an-istx))) + ,(arg/res-quoted-dep-src-code (istx-rst an-istx))) `(nodep ,(syntax-e (arg/res-var (istx-rst an-istx))))) #f) #,(for/list ([pre (in-list (istx-pre an-istx))]) (list (map syntax-e (pre/post-vars pre)) - (pre/post-str pre))) + (pre/post-str pre) + (pre/post-quoted-dep-src-code pre))) #,(and (istx-ress an-istx) (for/list ([a-res (in-list (istx-ress an-istx))]) `(,(if (arg/res-vars a-res) 'dep 'nodep) @@ -1184,10 +1196,12 @@ (map syntax-e (arg/res-vars a-res)) '()) #f - #f))) + #f + ,(arg/res-quoted-dep-src-code a-res)))) #,(for/list ([post (in-list (istx-post an-istx))]) (list (map syntax-e (pre/post-vars post)) - (pre/post-str post))))) + (pre/post-str post) + (pre/post-quoted-dep-src-code post))))) 'racket/contract:contract (let () (define (find-kwd kwd)