commit 05a6646111f4d85217659da81db8295e590fea77
parent 7f75c9a4c68319baf6a5991fb2eaf2d9558b7f3d
Author: Robby Findler <robby@racket-lang.org>
Date: Fri, 20 Sep 2013 14:36:22 -0500
added struct-doc and struct*-doc to scribble/srcdoc
original commit: 8f4dee5daf9d432ae370ec5e6aa19c674c5f5596
Diffstat:
2 files changed, 106 insertions(+), 2 deletions(-)
diff --git a/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/srcdoc.scrbl b/pkgs/scribble-pkgs/scribble-doc/scribblings/scribble/srcdoc.scrbl
@@ -136,6 +136,25 @@ Like @racket[proc-doc], but for an export of an arbitrary value.}
Like @racket[proc-doc], but for exporting a parameter.}
+@defform[(struct*-doc struct-name
+ ([field-name contract-expr-datum] ...)
+ maybe-omit-constructor
+ maybe-mutable maybe-non-opaque maybe-constructor
+ (desc-expr ...))
+ #:grammar ([maybe-omit-constructor (code:line) #:omit-constructor])]{
+ Like @racket[proc-doc], but for struct declarations that use @racket[struct].
+
+ The @racket[maybe-mutable], @racket[maybe-non-opaque], and @racket[maybe-constructor]
+ options are as in @racket[defstruct].
+}
+
+@defform[(struct-doc struct-name
+ ([field-name contract-expr-datum] ...)
+ maybe-omit-constructor
+ maybe-mutable maybe-non-opaque maybe-constructor
+ (desc-expr ...))]{
+ Like @racket[struct*-doc], but for struct declarations that use @racket[define-struct].
+}
@defform[(begin-for-doc form ...)]{
diff --git a/pkgs/scribble-pkgs/scribble-lib/scribble/srcdoc.rkt b/pkgs/scribble-pkgs/scribble-lib/scribble/srcdoc.rkt
@@ -3,6 +3,7 @@
(for-syntax racket/base
racket/require-transform
racket/provide-transform
+ syntax/stx
syntax/private/modcollapse-noctc))
(provide for-doc require/doc
@@ -11,6 +12,8 @@
parameter-doc
proc-doc
proc-doc/names
+ struct-doc
+ struct*-doc
generate-delayed-documents
begin-for-doc)
@@ -451,12 +454,12 @@
[(_ id (parameter/c contract) arg-id desc)
(begin
(unless (identifier? #'arg-id)
- (raise-syntax-error 'parameter/doc
+ (raise-syntax-error 'parameter-doc
"expected an identifier"
stx
#'arg-id))
(unless (identifier? #'id)
- (raise-syntax-error 'parameter/doc
+ (raise-syntax-error 'parameter-doc
"expected an identifier"
stx
#'id))
@@ -466,6 +469,88 @@
#'((only-in scribble/manual defparam))
#'id))])))
+(define-for-syntax (struct-doc-transformer stx result-form)
+ (syntax-case stx ()
+ [(_ struct-name ([field-name contract-expr-datum] ...) . stuff)
+ (let ()
+ (define the-name #f)
+ (syntax-case #'struct-name ()
+ [x (identifier? #'x) (set! the-name #'x)]
+ [(x y) (and (identifier? #'x) (identifier? #'y))
+ (set! the-name #'x)]
+ [_
+ (raise-syntax-error #f
+ "expected an identifier or sequence of two identifiers"
+ stx
+ #'struct-name)])
+ (for ([f (in-list (syntax->list #'(field-name ...)))])
+ (unless (identifier? f)
+ (raise-syntax-error #f
+ "expected an identifier"
+ stx
+ f)))
+ (define omit-constructor? #f)
+ (define-values (ds-args desc)
+ (let loop ([ds-args '()]
+ [stuff #'stuff])
+ (syntax-case stuff ()
+ [(#:mutable . more-stuff)
+ (loop (cons (stx-car stuff) ds-args)
+ #'more-stuff)]
+ [(#:inspector #f . more-stuff)
+ (loop (list* (stx-car (stx-cdr stuff))
+ (stx-car stuff)
+ ds-args)
+ #'more-stuff)]
+ [(#:prefab . more-stuff)
+ (loop (cons (stx-car stuff) ds-args)
+ #'more-stuff)]
+ [(#:transparent . more-stuff)
+ (loop (cons (stx-car stuff) ds-args)
+ #'more-stuff)]
+ [(#:constructor-name id . more-stuff)
+ (loop (list* (stx-car (stx-cdr stuff))
+ (stx-car stuff)
+ ds-args)
+ #'more-stuff)]
+ [(#:extra-constructor-name id . more-stuff)
+ (loop (list* (stx-car (stx-cdr stuff))
+ (stx-car stuff)
+ ds-args)
+ #'more-stuff)]
+ [(#:omit-constructor . more-stuff)
+ (begin
+ (set! omit-constructor? #t)
+ (loop (cons (stx-car stuff) ds-args)
+ #'more-stuff))]
+ [(x . more-stuff)
+ (keyword? (syntax-e #'x))
+ (raise-syntax-error #f
+ "unknown keyword"
+ stx
+ (stx-car stuff))]
+ [(desc)
+ (values (reverse ds-args) #'desc)]
+ [_
+ (raise-syntax-error #f "bad syntax" stx)])))
+ (values
+ #`(struct struct-name ((field-name contract-expr-datum) ...)
+ #,@(if omit-constructor?
+ '(#:omit-constructor)
+ '()))
+ #`(#,result-form struct-name ([field-name contract-expr-datum] ...)
+ #,@(reverse ds-args)
+ #,@desc)
+ #`((only-in scribble/manual #,result-form))
+ the-name))]))
+
+(define-provide/doc-transformer struct-doc
+ (λ (stx)
+ (struct-doc-transformer stx #'defstruct)))
+(define-provide/doc-transformer struct*-doc
+ (λ (stx)
+ (struct-doc-transformer stx #'defstruct*)))
+
(define-provide/doc-transformer thing-doc
(lambda (stx)
(syntax-case stx ()
