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

extend proc-doc to support optional arguments in an ->i contract

Browse Source 
also refactor to be able to add some unit tests

original commit: 8ce213bf1c17d38cab651634b2892d15916ca301
This commit is contained in:
Robby Findler 2013-04-06 18:50:13 -05:00
parent 0808c21415
commit 4ab5a49c99
2 changed files with 209 additions and 107 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

284
collects/scribble/srcdoc.rkt
View File

@ -148,14 +148,7 @@
(define-syntax-rule (provide/doc form ...) (define-syntax-rule (provide/doc form ...)
(provide 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 (provide define-provide/doc-transformer
(for-syntax (for-syntax
@ -174,96 +167,153 @@
(define-syntax id (define-syntax id
(make-provide/doc-transformer rhs))) (make-provide/doc-transformer rhs)))
(module transformers racket/base
(define-provide/doc-transformer proc-doc (require (for-template racket/base racket/contract)
(lambda (stx) 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 () (syntax-case stx ()
[(_ id contract desc) [(_ id contract . desc+stuff)
(with-syntax ([(header result (body-stuff ...)) (let ()
(syntax-case #'contract (->d ->i -> values) (define (one-desc desc+stuff)
[(->d (req ...) () (values [name res] ...)) (syntax-case desc+stuff ()
#'((id req ...) (values res ...) ())] [(desc) #'desc]
[(->d (req ...) () #:pre-cond condition (values [name res] ...)) [() (raise-syntax-error 'proc-doc "expected a description expression" stx)]
#'((id req ...) (values res ...) ((bold "Pre-condition: ") (racket condition) "\n" "\n"))] [(a b . c) (raise-syntax-error 'proc-doc "expected just a single description expression" stx #'a)]))
[(->d (req ...) () [name res]) (define (parse-opts opts desc+stuff)
#'((id req ...) res ())] (syntax-case opts ()
[(->d (req ...) () #:pre-cond condition [name res]) [() #`(() #,(one-desc desc+stuff))]
#'((id req ...) res ((bold "Pre-condition: ") (racket condition) "\n" "\n" ))] [(opt ...)
[(->d (req ...) () #:rest rest rest-ctc [name res]) (with-syntax ([(opt ...) (remove->i-deps (syntax->list #'(opt ...)) #t)])
#'((id req ... [rest rest-ctc] (... ...)) res ())] (syntax-case desc+stuff ()
[(->d (req ...) (one more ...) whatever) [((defaults ...) . desc+stuff)
(raise-syntax-error (let ()
#f (define def-list (syntax->list #'(defaults ...)))
(format "unsupported ->d contract form for ~a, optional arguments non-empty, must use proc-doc/names" (define opt-list (syntax->list #'(opt ...)))
(syntax->datum #'id)) (unless (= (length def-list) (length opt-list))
stx (raise-syntax-error 'proc-doc
#'contract)] (format "expected ~a default values, but got ~a"
[(->d whatever ...) (length opt-list) (length def-list))
(raise-syntax-error stx
#f opts))
(format "unsupported ->d contract form for ~a" (syntax->datum #'id)) #`(#,(for/list ([opt (in-list opt-list)]
stx [def (in-list def-list)])
#'contract)] (syntax-case opt ()
[(id ctc)
[(->i (req ...) () (values ress ...)) #`(id ctc #,def)]
(with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))] [(kwd id ctc)
[([name res] ...) (map remove->i-deps (syntax->list #'(req ...)))]) #`(kwd id ctc #,def)]))
#'((id req ...) (values res ...) ()))] #,(one-desc #'desc+stuff)))]))]))
[(->i (req ...) () #:pre (pre-id ...) condition (values ress ...)) (define-values (header result body-extras desc)
(with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))] (syntax-case #'contract (->d ->i -> values)
[([name res] ...) (map remove->i-deps (syntax->list #'(req ...)))]) [(->d (req ...) () (values [name res] ...))
#'((id req ...) (values res ...) ((bold "Pre-condition: ") (racket condition) "\n" "\n")))] (values #'(id req ...) #'(values res ...) #'() (one-desc #'desc+stuff))]
[(->i (req ...) () res) [(->d (req ...) () #:pre-cond condition (values [name res] ...))
(with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))] (values #'(id req ...) #'(values res ...) #'((bold "Pre-condition: ") (racket condition) "\n" "\n") (one-desc #'desc+stuff))]
[[name res] (remove->i-deps #'res)]) [(->d (req ...) () [name res])
#'((id req ...) res ()))] (values #'(id req ...) #'res #'() (one-desc #'desc+stuff))]
[(->i (req ...) () #:pre (pre-id ...) condition [name res]) [(->d (req ...) () #:pre-cond condition [name res])
(with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))] (values #'(id req ...) #'res #'((bold "Pre-condition: ") (racket condition) "\n" "\n" ) (one-desc #'desc+stuff))]
[[name res] (remove->i-deps #'res)]) [(->d (req ...) () #:rest rest rest-ctc [name res])
#'((id req ...) res ((bold "Pre-condition: ") (racket condition) "\n" "\n" )))] (values #'(id req ... [rest rest-ctc] (... ...)) #'res #'() (one-desc #'desc+stuff))]
[(->i (req ...) () #:rest rest res) [(->d (req ...) (one more ...) whatever)
(with-syntax ([(req ...) (map remove->i-deps (syntax->list #'(req ...)))] (raise-syntax-error
[[name res] (remove->i-deps #'res)] #f
[[name-t rest-ctc] (remove->i-deps #'rest)]) (format "unsupported ->d contract form for ~a, optional arguments non-empty, must use proc-doc/names"
#'((id req ... [name-t rest-ctc] (... ...)) res ()))] (syntax->datum #'id))
[(->i (req ...) (one more ...) whatever) stx
(raise-syntax-error #'contract)]
#f [(->d whatever ...)
(format "unsupported ->i contract form for ~a, optional arguments non-empty, must use proc-doc/names" (raise-syntax-error
(syntax->datum #'id)) #f
stx (format "unsupported ->d contract form for ~a" (syntax->datum #'id))
#'contract)] stx
[(->i whatever ...) #'contract)]
(raise-syntax-error
#f [(->i (req ...) (opt ...) (values ress ...))
(format "unsupported ->i contract form for ~a" (syntax->datum #'id)) (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
stx [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
#'contract)] [([name res] ...) (remove->i-deps (syntax->list #'(req ...)) #f)])
(values #'(id req ... opt ...) #'(values res ...) #'() #'desc))]
[(-> result) [(->i (req ...) (opt ...) #:pre (pre-id ...) condition (values ress ...))
#'((id) result ())] (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
[(-> whatever ...) [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
(raise-syntax-error [([name res] ...) (remove->i-deps (syntax->list #'(req ...)) #f)])
#f (values #'(id req ... opt ...) #'(values res ...) #'((bold "Pre-condition: ") (racket condition) "\n" "\n") #'desc))]
(format "unsupported -> contract form for ~a, must use proc-doc/names if there are arguments" [(->i (req ...) (opt ...) res)
(syntax->datum #'id)) (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
stx [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
#'contract)] [([name res]) (remove->i-deps (list #'res) #f)])
[(id whatever ...) (values #'(id req ... opt ...) #'res #'() #'desc))]
(raise-syntax-error [(->i (req ...) (opt ...) #:pre (pre-id ...) condition [name res])
#f (with-syntax ([(req ...) (remove->i-deps (syntax->list #'(req ...)) #t)]
(format "unsupported ~a contract form (unable to synthesize argument names)" (syntax->datum #'id)) [((opt ...) desc) (parse-opts #'(opt ...) #'desc+stuff)]
stx [([name res]) (remove->i-deps (list #'res) #f)])
#'contract)])]) (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 (values
#'[id contract] #'[id contract]
#'(defproc header result body-stuff ... . desc) #`(defproc #,header #,result #,@body-extras #,@desc)
#'(scribble/manual #'(scribble/manual
racket/base) ; for `...' racket/base) ; for `...'
#'id))]))) #'id))]))
(define-provide/doc-transformer proc-doc/names (define (proc-doc/names-transformer stx)
(lambda (stx)
(syntax-case stx () (syntax-case stx ()
[(_ id contract names desc) [(_ id contract names desc)
(with-syntax ([header (with-syntax ([header
@ -373,7 +423,9 @@
(λ (doms args) (λ (doms args)
(unless (= (length (syntax->list doms)) (unless (= (length (syntax->list doms))
(length (syntax->list args))) (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 #'((doms ...) ...))
(syntax->list #'((args ...) ...))) (syntax->list #'((args ...) ...)))
#'([(id (args doms) ...) rng] ...))] #'([(id (args doms) ...) rng] ...))]
@ -389,6 +441,10 @@
#'((only-in scribble/manual defproc*)) #'((only-in scribble/manual defproc*))
#'id))]))) #'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 (define-provide/doc-transformer parameter-doc
(lambda (stx) (lambda (stx)
(syntax-case stx (parameter/c) (syntax-case stx (parameter/c)
@ -432,3 +488,43 @@
(begin (begin
(set! delayed? #t) (set! delayed? #t)
#'(begin))])) #'(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?)))))

32
collects/scribblings/scribble/srcdoc.scrbl
View File

@ -101,23 +101,29 @@ can be referenced in documentation prose using the @racket[racket]
form.} form.}
@defform/subs[#:literals (-> ->i ->d values) @defform/subs[#:literals (-> ->i ->d values)
(proc-doc id contract (desc-expr ...)) (proc-doc id contract maybe-defs (desc-expr ...))
([contract (-> result) ([contract (-> result)
(->i (arg ...) () (values ress ...)) (->i (arg ...) (opt ...) maybe-pre [id res])
(->i (arg ...) () #:pre (pre-id ...) condition (values ress ...)) (->i (arg ...) (opt ...) maybe-pre (values [id res] ...))
(->i (arg ...) () res) (->i (arg ...) (opt ...) #:rest rest [id result-expr])
(->i (arg ...) () #:pre (pre-id ...) condition [name res])
(->i (arg ...) () #:rest rest res)
(->d (arg ...) () (values [id result] ...)) (->d (arg ...) () maybe-precond (values [id result] ...))
(->d (arg ...) () #:pre-cond expr (values [id result] ...)) (->d (arg ...) () maybe-precond [id result])
(->d (arg ...) () [id result]) (->d (arg ...) () #:rest id rest [id result])]
(->d (arg ...) () #:pre-cond expr [id result]) [maybe-pre (code:line)
(->d (arg ...) () #:rest id rest [id result])])]{ (code:line #:pre (pre-id ...) condition)]
[maybe-defs (code:line)
(default-expr default-expr ...)])]{
Like @racket[proc-doc], but supporting contract forms that embed Like @racket[proc-doc], but supporting contract forms that embed
argument names. Only a subset of @racket[->i] and @racket[->d] forms are argument identifiers. Only a subset of @racket[->i] and @racket[->d] forms are
currently supported.} 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)]{ @defform[(thing-doc id contract-expr dec-expr)]{