suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

improve ->i's printing so it saves some of the source text of the dependent contracts

Browse Source
This commit is contained in:
Robby Findler 2014-05-16 17:02:18 -05:00
parent f7b754dd0b
commit 541582cbc6
3 changed files with 127 additions and 45 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

40
pkgs/racket-pkgs/racket-test/tests/racket/contract/name.rkt
View File

@ -84,29 +84,47 @@
(test-name '(->i () any) (->i () () any)) (test-name '(->i () any) (->i () () any))
(test-name '(->i () any) (->i () any)) (test-name '(->i () any) (->i () any))
(test-name '(->i () [x () ...]) (test-name '(->i () [x () number?])
(->i () () [x () number?])) (->i () () [x () number?]))
(test-name '(->i () [q number?]) (test-name '(->i () [q number?])
(->i () () [q number?])) (->i () () [q number?]))
(test-name '(->i () (values [x number?] [y number?])) (test-name '(->i () (values [x number?] [y number?]))
(->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?]))) (->i () (values [x (y) number?] [y number?])))
(test-name '(->i ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any) (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)) (->i ([x integer?] #:y [y integer?]) ([z integer?] #:w [w integer?]) any))
(test-name '(->i () #:pre () ... [q number?]) (test-name '(->i () #:pre () #t [q number?])
(->i () #:pre () #t [q number?])) (->i () #:pre () #t [q number?]))
(test-name '(->i () #:pre () ... [q () ...] #:post () ...) (test-name '(->i () #:pre () #t [q () number?] #:post () #t)
(->i () #:pre () #t [q () number?] #:post () #t)) (->i () #:pre () #t [q () number?] #:post () #t))
(test-name '(->i ([x integer?]) #:pre (x) ... [q (x) ...] #:post (x) ...) (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)) (->i ([x integer?]) #:pre (x) #t [q (x) number?] #:post (x) #t))
(test-name '(->i ([x real?]) [_ (x) ...]) (test-name '(->i ([x real?]) [_ (x) (>/c x)])
(->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)) (->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) (->i ([x any/c]) [y () any/c] #:post/name (y) "pair" (pair? y)
#:post/name (y) "car" (car 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->) (case->))
(test-name '(case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any)) (test-name '(case-> (-> integer? any) (-> boolean? boolean? any) (-> char? char? char? any))

88
racket/collects/racket/contract/private/arr-i-parse.rkt
View File

@ -32,7 +32,8 @@ code does the parsing and validation of the syntax.
;; var : identifier? ;; var : identifier?
;; vars : (or/c #f (listof identifier?)) -- #f if non-dep ;; vars : (or/c #f (listof identifier?)) -- #f if non-dep
;; ctc : syntax[expr] ;; 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]) ;; kwd : (or/c #f syntax[kwd])
;; optional? : boolean? ;; optional? : boolean?
@ -49,7 +50,7 @@ code does the parsing and validation of the syntax.
;; vars : (listof identifier?) ;; vars : (listof identifier?)
;; exp : syntax[expr] ;; exp : syntax[expr]
;; str : (or/c #f 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) (define (parse-->i stx)
(if (identifier? stx) (if (identifier? stx)
@ -238,6 +239,39 @@ code does the parsing and validation of the syntax.
(list fst) (list fst)
(cons fst (loop (cdr vars)))))]))) (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) (define (parse-doms stx optional? doms)
(let loop ([doms doms]) (let loop ([doms doms])
(syntax-case doms () (syntax-case doms ()
@ -245,25 +279,29 @@ code does the parsing and validation of the syntax.
(keyword? (syntax-e #'kwd)) (keyword? (syntax-e #'kwd))
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(cons (arg #'id #f #'ctc-expr #'kwd optional?) (cons (arg #'id #f #'ctc-expr #f #'kwd optional?)
(loop #'rest)))] (loop #'rest)))]
[(kwd [id (id2 ...) ctc-expr] . rest) [(kwd [id (id2 ...) ctc-expr] . rest)
(keyword? (syntax-e #'kwd)) (keyword? (syntax-e #'kwd))
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) (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)))] (loop #'rest)))]
[([id ctc-expr] . rest) [([id ctc-expr] . rest)
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(cons (arg #'id #f #'ctc-expr #f optional?) (cons (arg #'id #f #'ctc-expr #f #f optional?)
(loop #'rest)))] (loop #'rest)))]
[([id (id2 ...) ctc-expr] . rest) [([id (id2 ...) ctc-expr] . rest)
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) (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)))] (loop #'rest)))]
[() '()] [() '()]
[(a . rest) [(a . rest)
@ -277,16 +315,18 @@ code does the parsing and validation of the syntax.
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(if (free-identifier=? #'_ #'id) (if (free-identifier=? #'_ #'id)
(eres #'id #f #'ctc (car (generate-temporaries '(eres)))) (eres #'id #f #'ctc (car (generate-temporaries '(eres))) #f)
(lres #'id #f #'ctc)))] (lres #'id #f #'ctc #f)))]
[[id (id2 ...) ctc] [[id (id2 ...) ctc]
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) (for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...)))
(if (free-identifier=? #'_ #'id) (if (free-identifier=? #'_ #'id)
(eres #'id (syntax->list #'(id2 ...)) #'ctc (eres #'id (syntax->list #'(id2 ...)) #'ctc
(compute-quoted-src-expression #'ctc)
(car (generate-temporaries '(eres)))) (car (generate-temporaries '(eres))))
(lres #'id (syntax->list #'(id2 ...)) #'ctc)))] (lres #'id (syntax->list #'(id2 ...)) #'ctc
(compute-quoted-src-expression #'ctc))))]
[(a ...) [(a ...)
(let ([len (length (syntax->list #'(a ...)))]) (let ([len (length (syntax->list #'(a ...)))])
(unless (or (= 2 len) (= 3 len)) (unless (or (= 2 len) (= 3 len))
@ -300,20 +340,23 @@ code does the parsing and validation of the syntax.
(syntax->list #'(ctc-pr ...)))] (syntax->list #'(ctc-pr ...)))]
[any #f] [any #f]
[[_ ctc] [[_ ctc]
(list (eres #'_ #f #'ctc (car (generate-temporaries '(eres)))))] (list (eres #'_ #f #'ctc #f (car (generate-temporaries '(eres)))))]
[[id ctc] [[id ctc]
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(list (lres #'id #f #'ctc)))] (list (lres #'id #f #'ctc #f)))]
[[_ (id2 ...) ctc] [[_ (id2 ...) ctc]
(begin (begin
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) (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] [[id (id2 ...) ctc]
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id2 ...))) (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)])) [x (raise-syntax-error #f "expected the range portion" stx #'x)]))
(define (check-id stx id) (define (check-id stx id)
@ -353,7 +396,7 @@ code does the parsing and validation of the syntax.
[(#:rest [id rest-expr] . leftover) [(#:rest [id rest-expr] . leftover)
(begin (begin
(check-id stx #'id) (check-id stx #'id)
(values (arg/res #'id #f #'rest-expr) (values (arg/res #'id #f #'rest-expr #f)
#'leftover))] #'leftover))]
[(#:rest [id (id2 ...) rest-expr] . leftover) [(#:rest [id (id2 ...) rest-expr] . leftover)
(begin (begin
@ -362,7 +405,8 @@ code does the parsing and validation of the syntax.
(syntax->list #'(id2 ...))) (syntax->list #'(id2 ...)))
(values (arg/res #'id (values (arg/res #'id
(syntax->list #'(id2 ...)) (syntax->list #'(id2 ...))
#'rest-expr) #'rest-expr
(compute-quoted-src-expression #'rest-expr))
#'leftover))] #'leftover))]
[(#:rest other . leftover) [(#:rest other . leftover)
(raise-syntax-error #f "expected an id+ctc" (raise-syntax-error #f "expected an id+ctc"
@ -393,7 +437,9 @@ code does the parsing and validation of the syntax.
[x (void)]) [x (void)])
(for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...))) (for-each (λ (x) (check-id stx x)) (syntax->list #'(id ...)))
(loop #'pre-leftover (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) [(#:pre . rest)
(raise-syntax-error (raise-syntax-error
#f #f
@ -420,7 +466,8 @@ code does the parsing and validation of the syntax.
stx stx
#'str)) #'str))
(loop #'pre-leftover (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)))] conditions)))]
[(#:pre/name . rest) [(#:pre/name . rest)
(raise-syntax-error (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)] #f "cannot have a #:post with any as the range" stx #'post-cond)]
[_ (void)]) [_ (void)])
(loop #'leftover (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) [(#:post a b . stuff)
(begin (begin
(raise-syntax-error (raise-syntax-error
@ -479,7 +528,8 @@ code does the parsing and validation of the syntax.
stx stx
#'str)) #'str))
(loop #'leftover (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-conds)))]
[(#:post/name . stuff) [(#:post/name . stuff)
(begin (begin

40
racket/collects/racket/contract/private/arr-i.rkt
View File

@ -125,6 +125,7 @@
pre/post-procs pre/post-procs
mandatory-args opt-args mandatory-kwds opt-kwds rest mandatory-args opt-args mandatory-kwds opt-kwds rest
mtd? here mk-wrapper mk-val-first-wrapper name-info) mtd? here mk-wrapper mk-val-first-wrapper name-info)
#:property prop:custom-write custom-write-property-proc
#:property prop:contract #:property prop:contract
(build-contract-property (build-contract-property
#:val-first-projection #:val-first-projection
@ -161,12 +162,13 @@
. .
,(loop (cdr infos) (cdr ctcs) dep-ctcs)))] ,(loop (cdr infos) (cdr ctcs) dep-ctcs)))]
[(dep) [(dep)
(define body-src (list-ref info 5))
(if (skip? info) (if (skip? info)
(loop (cdr infos) ctcs (cdr dep-ctcs)) (loop (cdr infos) ctcs (cdr dep-ctcs))
`(,@(if kwd `(,@(if kwd
(list kwd) (list kwd)
(list)) (list))
[,var ,vars ...] [,var ,vars ,body-src]
. .
,(loop (cdr infos) ctcs (cdr dep-ctcs))))]))]))) ,(loop (cdr infos) ctcs (cdr dep-ctcs))))]))])))
(let* ([name-info (->i-name-info ctc)] (let* ([name-info (->i-name-info ctc)]
@ -193,14 +195,18 @@
,(contract-name ,(contract-name
(car (reverse (map cdr (->i-arg-ctcs ctc)))))])] (car (reverse (map cdr (->i-arg-ctcs ctc)))))])]
[(dep) `(#:rest [,(list-ref rest-info 1) [(dep) `(#:rest [,(list-ref rest-info 1)
,(list-ref rest-info 2) ...])]) ,(list-ref rest-info 2)
,(list-ref rest-info 3)])])
'()) '())
,@(apply ,@(apply
append append
(for/list ([pre-info pre-infos]) (for/list ([pre-info pre-infos])
(if (cadr pre-info) (define ids (list-ref pre-info 0))
`(#:pre/name ,@pre-info ...) (define name (list-ref pre-info 1))
`(#:pre ,(car pre-info) ...)))) (define code (list-ref pre-info 2))
(if name
`(#:pre/name ,ids ,name ,code)
`(#:pre ,ids ,code))))
,(cond ,(cond
[(not rng-info) [(not rng-info)
'any] 'any]
@ -217,9 +223,12 @@
,@(apply ,@(apply
append append
(for/list ([post-info post-infos]) (for/list ([post-info post-infos])
(if (cadr post-info) (define ids (list-ref post-info 0))
`(#:post/name ,@post-info ...) (define name (list-ref post-info 1))
`(#:post ,(car post-info) ...))))))) (define code (list-ref post-info 2))
(if name
`(#:post/name ,ids ,name ,code)
`(#:post ,ids ,code)))))))
#:first-order #:first-order
(λ (ctc) (λ (ctc)
(let ([has-rest (->i-rest ctc)] (let ([has-rest (->i-rest ctc)]
@ -1164,16 +1173,19 @@
'()) '())
,(and (arg-kwd an-arg) ,(and (arg-kwd an-arg)
(syntax-e (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 (istx-rst an-istx)
(if (arg/res-vars (istx-rst an-istx)) (if (arg/res-vars (istx-rst an-istx))
`(dep ,(syntax-e (arg/res-var (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))))) `(nodep ,(syntax-e (arg/res-var (istx-rst an-istx)))))
#f) #f)
#,(for/list ([pre (in-list (istx-pre an-istx))]) #,(for/list ([pre (in-list (istx-pre an-istx))])
(list (map syntax-e (pre/post-vars pre)) (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) #,(and (istx-ress an-istx)
(for/list ([a-res (in-list (istx-ress an-istx))]) (for/list ([a-res (in-list (istx-ress an-istx))])
`(,(if (arg/res-vars a-res) 'dep 'nodep) `(,(if (arg/res-vars a-res) 'dep 'nodep)
@ -1184,10 +1196,12 @@
(map syntax-e (arg/res-vars a-res)) (map syntax-e (arg/res-vars a-res))
'()) '())
#f #f
#f))) #f
,(arg/res-quoted-dep-src-code a-res))))
#,(for/list ([post (in-list (istx-post an-istx))]) #,(for/list ([post (in-list (istx-post an-istx))])
(list (map syntax-e (pre/post-vars post)) (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 'racket/contract:contract
(let () (let ()
(define (find-kwd kwd) (define (find-kwd kwd)