improve ->i's printing so it saves some of the source text of the dependent contracts
This commit is contained in:
Robby Findler
parent
f7b754dd0b
commit
541582cbc6
|
|
@ -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))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user