commit 4ab5a49c9990e667b405348cd0073231f44d2c24
parent 0808c21415b743cd9668c3561d205bb72c7880a6
Author: Robby Findler <robby@racket-lang.org>
Date: Sat, 6 Apr 2013 18:50:13 -0500
extend proc-doc to support optional arguments in an ->i contract
also refactor to be able to add some unit tests
original commit: 8ce213bf1c17d38cab651634b2892d15916ca301
Diffstat:
2 files changed, 210 insertions(+), 108 deletions(-)
diff --git a/collects/scribble/srcdoc.rkt b/collects/scribble/srcdoc.rkt
@@ -148,14 +148,7 @@
(define-syntax-rule (provide/doc form ...)
(provide form ...))
-(define-for-syntax (remove->i-deps stx)
- (syntax-case stx ()
- [(id (id2 ...) ctc)
- #'(id ctc)]
- [(id ctc)
- #'(id ctc)]
- [else
- (error 'remove->i-deps "unknown thing ~s" stx)]))
+
(provide define-provide/doc-transformer
(for-syntax
@@ -174,96 +167,153 @@
(define-syntax id
(make-provide/doc-transformer rhs)))
-
-(define-provide/doc-transformer proc-doc
- (lambda (stx)
+(module transformers racket/base
+ (require (for-template racket/base racket/contract)
+ racket/contract)
+ (provide proc-doc-transformer proc-doc/names-transformer)
+
+ (define (remove->i-deps stx-lst arg?)
+ (let loop ([stx-lst stx-lst])
+ (cond
+ [(null? stx-lst) '()]
+ [else
+ (define fst (car stx-lst))
+ (syntax-case fst ()
+ [kwd
+ (and arg? (keyword? (syntax-e #'kwd)))
+ (let ()
+ (when (null? (cdr stx-lst))
+ (raise-syntax-error 'proc-doc "expected something to follow keyword" stx-lst))
+ (define snd (cadr stx-lst))
+ (syntax-case snd ()
+ [(id (id2 ...) ctc)
+ (cons #'(kwd id ctc) (loop (cddr stx-lst)))]
+ [(id ctc)
+ (cons #'(kwd id ctc) (loop (cddr stx-lst)))]
+ [else
+ (raise-syntax-error 'proc-doc "unknown argument spec in ->i" snd)]))]
+ [(id (id2 ...) ctc)
+ (cons #'(id ctc) (loop (cdr stx-lst)))]
+ [(id ctc)
+ (cons #'(id ctc) (loop (cdr stx-lst)))]
+ [else
+ (raise-syntax-error 'proc-doc (if arg? "unknown argument spec in ->i" "unknown result spec in ->i") fst)])])))
+
+ (define (proc-doc-transformer stx)
(syntax-case stx ()
- [(_ id contract desc)
- (with-syntax ([(header result (body-stuff ...))
- (syntax-case #'contract (->d ->i -> values)
- [(->d (req ...) () (values [name res] ...))
- #'((id req ...) (values res ...) ())]
- [(->d (req ...) () #:pre-cond condition (values [name res] ...))
- #'((id req ...) (values res ...) ((bold "Pre-condition: ") (racket condition) "\n" "\n"))]
- [(->d (req ...) () [name res])
- #'((id req ...) res ())]
- [(->d (req ...) () #:pre-cond condition [name res])
- #'((id req ...) res ((bold "Pre-condition: ") (racket condition) "\n" "\n" ))]
- [(->d (req ...) () #:rest rest rest-ctc [name res])
- #'((id req ... [rest rest-ctc] (... ...)) res ())]
- [(->d (req ...) (one more ...) whatever)
- (raise-syntax-error
- #f
- (format "unsupported ->d contract form for ~a, optional arguments non-empty, must use proc-doc/names"
- (syntax->datum #'id))
- stx
- #'contract)]
- [(->d whatever ...)
- (raise-syntax-error
- #f
- (format "unsupported ->d contract form for ~a" (syntax->datum #'id))
- stx
- #'contract)]
-
- [(->i (req ...) () (values ress ...))
- (with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))]
- [([name res] ...) (map remove->i-deps (syntax->list #'(req ...)))])
- #'((id req ...) (values res ...) ()))]
- [(->i (req ...) () #:pre (pre-id ...) condition (values ress ...))
- (with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))]
- [([name res] ...) (map remove->i-deps (syntax->list #'(req ...)))])
- #'((id req ...) (values res ...) ((bold "Pre-condition: ") (racket condition) "\n" "\n")))]
- [(->i (req ...) () res)
- (with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))]
- [[name res] (remove->i-deps #'res)])
- #'((id req ...) res ()))]
- [(->i (req ...) () #:pre (pre-id ...) condition [name res])
- (with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))]
- [[name res] (remove->i-deps #'res)])
- #'((id req ...) res ((bold "Pre-condition: ") (racket condition) "\n" "\n" )))]
- [(->i (req ...) () #:rest rest res)
- (with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))]
- [[name res] (remove->i-deps #'res)]
- [[name-t rest-ctc] (remove->i-deps #'rest)])
- #'((id req ... [name-t rest-ctc] (... ...)) res ()))]
- [(->i (req ...) (one more ...) whatever)
- (raise-syntax-error
- #f
- (format "unsupported ->i contract form for ~a, optional arguments non-empty, must use proc-doc/names"
- (syntax->datum #'id))
- stx
- #'contract)]
- [(->i whatever ...)
- (raise-syntax-error
- #f
- (format "unsupported ->i contract form for ~a" (syntax->datum #'id))
- stx
- #'contract)]
-
- [(-> result)
- #'((id) result ())]
- [(-> whatever ...)
- (raise-syntax-error
- #f
- (format "unsupported -> contract form for ~a, must use proc-doc/names if there are arguments"
- (syntax->datum #'id))
- stx
- #'contract)]
- [(id whatever ...)
- (raise-syntax-error
- #f
- (format "unsupported ~a contract form (unable to synthesize argument names)" (syntax->datum #'id))
- stx
- #'contract)])])
+ [(_ id contract . desc+stuff)
+ (let ()
+ (define (one-desc desc+stuff)
+ (syntax-case desc+stuff ()
+ [(desc) #'desc]
+ [() (raise-syntax-error 'proc-doc "expected a description expression" stx)]
+ [(a b . c) (raise-syntax-error 'proc-doc "expected just a single description expression" stx #'a)]))
+ (define (parse-opts opts desc+stuff)
+ (syntax-case opts ()
+ [() #`(() #,(one-desc desc+stuff))]
+ [(opt ...)
+ (with-syntax ([(opt ...) (remove->i-deps (syntax->list #'(opt ...)) #t)])
+ (syntax-case desc+stuff ()
+ [((defaults ...) . desc+stuff)
+ (let ()
+ (define def-list (syntax->list #'(defaults ...)))
+ (define opt-list (syntax->list #'(opt ...)))
+ (unless (= (length def-list) (length opt-list))
+ (raise-syntax-error 'proc-doc
+ (format "expected ~a default values, but got ~a"
+ (length opt-list) (length def-list))
+ stx
+ opts))
+ #`(#,(for/list ([opt (in-list opt-list)]
+ [def (in-list def-list)])
+ (syntax-case opt ()
+ [(id ctc)
+ #`(id ctc #,def)]
+ [(kwd id ctc)
+ #`(kwd id ctc #,def)]))
+ #,(one-desc #'desc+stuff)))]))]))
+ (define-values (header result body-extras desc)
+ (syntax-case #'contract (->d ->i -> values)
+ [(->d (req ...) () (values [name res] ...))
+ (values #'(id req ...) #'(values res ...) #'() (one-desc #'desc+stuff))]
+ [(->d (req ...) () #:pre-cond condition (values [name res] ...))
+ (values #'(id req ...) #'(values res ...) #'((bold "Pre-condition: ") (racket condition) "\n" "\n") (one-desc #'desc+stuff))]
+ [(->d (req ...) () [name res])
+ (values #'(id req ...) #'res #'() (one-desc #'desc+stuff))]
+ [(->d (req ...) () #:pre-cond condition [name res])
+ (values #'(id req ...) #'res #'((bold "Pre-condition: ") (racket condition) "\n" "\n" ) (one-desc #'desc+stuff))]
+ [(->d (req ...) () #:rest rest rest-ctc [name res])
+ (values #'(id req ... [rest rest-ctc] (... ...)) #'res #'() (one-desc #'desc+stuff))]
+ [(->d (req ...) (one more ...) whatever)
+ (raise-syntax-error
+ #f
+ (format "unsupported ->d contract form for ~a, optional arguments non-empty, must use proc-doc/names"
+ (syntax->datum #'id))
+ stx
+ #'contract)]
+ [(->d whatever ...)
+ (raise-syntax-error
+ #f
+ (format "unsupported ->d contract form for ~a" (syntax->datum #'id))
+ stx
+ #'contract)]
+
+ [(->i (req ...) (opt ...) (values ress ...))
+ (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
+ [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
+ [([name res] ...) (remove->i-deps (syntax->list #'(req ...)) #f)])
+ (values #'(id req ... opt ...) #'(values res ...) #'() #'desc))]
+ [(->i (req ...) (opt ...) #:pre (pre-id ...) condition (values ress ...))
+ (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
+ [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
+ [([name res] ...) (remove->i-deps (syntax->list #'(req ...)) #f)])
+ (values #'(id req ... opt ...) #'(values res ...) #'((bold "Pre-condition: ") (racket condition) "\n" "\n") #'desc))]
+ [(->i (req ...) (opt ...) res)
+ (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
+ [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
+ [([name res]) (remove->i-deps (list #'res) #f)])
+ (values #'(id req ... opt ...) #'res #'() #'desc))]
+ [(->i (req ...) (opt ...) #:pre (pre-id ...) condition [name res])
+ (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
+ [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
+ [([name res]) (remove->i-deps (list #'res) #f)])
+ (values #'(id req ... opt ...) #'res #'((bold "Pre-condition: ") (racket condition) "\n" "\n" ) #'desc))]
+ [(->i (req ...) (opt ...) #:rest rest res)
+ (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
+ [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
+ [([name-t rest-ctc]) (remove->i-deps (list #'rest) #t)]
+ [([name res]) (remove->i-deps (list #'res) #f)])
+ (values #'(id req ... opt ... [name-t rest-ctc] (... ...)) #'res #'() #'desc))]
+ [(->i whatever ...)
+ (raise-syntax-error
+ #f
+ (format "unsupported ->i contract form for ~a" (syntax->datum #'id))
+ stx
+ #'contract)]
+
+ [(-> result)
+ (values #'(id) #'result #'() (one-desc #'desc+stuff))]
+ [(-> whatever ...)
+ (raise-syntax-error
+ #f
+ (format "unsupported -> contract form for ~a, must use proc-doc/names if there are arguments"
+ (syntax->datum #'id))
+ stx
+ #'contract)]
+ [(id whatever ...)
+ (raise-syntax-error
+ #f
+ (format "unsupported ~a contract form (unable to synthesize argument names)" (syntax->datum #'id))
+ stx
+ #'contract)]))
(values
#'[id contract]
- #'(defproc header result body-stuff ... . desc)
+ #`(defproc #,header #,result #,@body-extras #,@desc)
#'(scribble/manual
racket/base) ; for `...'
- #'id))])))
-
-(define-provide/doc-transformer proc-doc/names
- (lambda (stx)
+ #'id))]))
+
+ (define (proc-doc/names-transformer stx)
(syntax-case stx ()
[(_ id contract names desc)
(with-syntax ([header
@@ -373,7 +423,9 @@
(λ (doms args)
(unless (= (length (syntax->list doms))
(length (syntax->list args)))
- (raise-syntax-error #f "mismatched case argument list and domain contract" stx)))
+ (raise-syntax-error #f "mismatched case argument list and domain contract" stx
+ #f
+ (list doms args))))
(syntax->list #'((doms ...) ...))
(syntax->list #'((args ...) ...)))
#'([(id (args doms) ...) rng] ...))]
@@ -389,6 +441,10 @@
#'((only-in scribble/manual defproc*))
#'id))])))
+(require (for-syntax (submod "." transformers)))
+(define-provide/doc-transformer proc-doc proc-doc-transformer)
+(define-provide/doc-transformer proc-doc/names proc-doc/names-transformer)
+
(define-provide/doc-transformer parameter-doc
(lambda (stx)
(syntax-case stx (parameter/c)
@@ -432,3 +488,43 @@
(begin
(set! delayed? #t)
#'(begin))]))
+
+
+(module+ test
+ (require (submod ".." transformers)
+ rackunit
+ racket/contract)
+
+ (define (try-docs transformer input)
+ (define-values (_0 docs _1 _2) (transformer input))
+ (syntax->datum docs))
+
+ (check-equal? (try-docs proc-doc-transformer #'(_ f (-> void?) ()))
+ '(defproc (f) void?))
+ (check-equal? (try-docs proc-doc-transformer #'(_ f (->i ([x integer?]) () [result void?]) ()))
+ '(defproc (f [x integer?]) void?))
+ (check-equal? (try-docs proc-doc-transformer #'(_ f (->i ([x integer?] #:y [y boolean?]) () [res void?]) ()))
+ '(defproc (f [x integer?] [#:y y boolean?]) void?))
+ (check-equal? (try-docs proc-doc-transformer #'(_ f (->i ([x integer?]) ([y boolean?] [z char?]) [result void?]) (#t #\x) ()))
+ '(defproc (f [x integer?] [y boolean? #t] [z char? #\x]) void?))
+ (check-equal? (try-docs proc-doc-transformer #'(_ f (->i ([x integer?] #:y [y boolean?]) ([z char?] #:w [w string?]) [res void?]) (#\a "b") ()))
+ '(defproc (f [x integer?] [#:y y boolean?] [z char? #\a] [#:w w string? "b"]) void?))
+
+ (check-equal? (try-docs proc-doc-transformer
+ #'(_ g
+ (->i ([str string?])
+ ()
+ #:rest [rest (listof any/c)]
+ [res (str) integer?])
+ ()))
+ '(defproc (g (str string?) (rest (listof any/c)) ...) integer?))
+
+ (check-equal? (try-docs proc-doc/names-transformer #'(_ f (-> integer? char? boolean?) (a b) ()))
+ '(defproc* (((f [a integer?] [b char?]) boolean?))))
+ (check-equal? (try-docs proc-doc/names-transformer #'(_ f (->* (integer? char?) () boolean?) ((a b) ()) ()))
+ '(defproc* (((f [a integer?] [b char?]) boolean?))))
+ (check-equal? (try-docs proc-doc/names-transformer #'(_ f (->* (integer? char?) (string? number?) boolean?) ((a b) ((c "a") (d 11))) ()))
+ '(defproc* (((f [a integer?] [b char?] [c string? "a"] [d number? 11]) boolean?))))
+ (check-equal? (try-docs proc-doc/names-transformer #'(_ f (case-> (-> integer? char?) (-> string? number? boolean? void?)) ((a) (b c d)) ()))
+ '(defproc* (((f [a integer?]) char?)
+ ((f [b string?] [c number?] [d boolean?]) void?)))))
diff --git a/collects/scribblings/scribble/srcdoc.scrbl b/collects/scribblings/scribble/srcdoc.scrbl
@@ -101,23 +101,29 @@ can be referenced in documentation prose using the @racket[racket]
form.}
@defform/subs[#:literals (-> ->i ->d values)
- (proc-doc id contract (desc-expr ...))
+ (proc-doc id contract maybe-defs (desc-expr ...))
([contract (-> result)
- (->i (arg ...) () (values ress ...))
- (->i (arg ...) () #:pre (pre-id ...) condition (values ress ...))
- (->i (arg ...) () res)
- (->i (arg ...) () #:pre (pre-id ...) condition [name res])
- (->i (arg ...) () #:rest rest res)
-
- (->d (arg ...) () (values [id result] ...))
- (->d (arg ...) () #:pre-cond expr (values [id result] ...))
- (->d (arg ...) () [id result])
- (->d (arg ...) () #:pre-cond expr [id result])
- (->d (arg ...) () #:rest id rest [id result])])]{
+ (->i (arg ...) (opt ...) maybe-pre [id res])
+ (->i (arg ...) (opt ...) maybe-pre (values [id res] ...))
+ (->i (arg ...) (opt ...) #:rest rest [id result-expr])
+
+ (->d (arg ...) () maybe-precond (values [id result] ...))
+ (->d (arg ...) () maybe-precond [id result])
+ (->d (arg ...) () #:rest id rest [id result])]
+ [maybe-pre (code:line)
+ (code:line #:pre (pre-id ...) condition)]
+ [maybe-defs (code:line)
+ (default-expr default-expr ...)])]{
Like @racket[proc-doc], but supporting contract forms that embed
-argument names. Only a subset of @racket[->i] and @racket[->d] forms are
-currently supported.}
+argument identifiers. Only a subset of @racket[->i] and @racket[->d] forms are
+currently supported.
+
+If the sequence of optional arguments, @racket[(opt ...)] is empty then
+the @racket[maybe-arg-desc] must be not be present. If it is non-empty,
+then it must have as many default expressions are there are optional
+arguments.
+}
@defform[(thing-doc id contract-expr dec-expr)]{
