From 05a6646111f4d85217659da81db8295e590fea77 Mon Sep 17 00:00:00 2001
From: Robby Findler <robby@racket-lang.org>
Date: Fri, 20 Sep 2013 14:36:22 -0500
Subject: [PATCH] added struct-doc and struct*-doc to scribble/srcdoc

original commit: 8f4dee5daf9d432ae370ec5e6aa19c674c5f5596
---
 .../scribblings/scribble/srcdoc.scrbl         | 19 ++++
 .../scribble-lib/scribble/srcdoc.rkt          | 89 ++++++++++++++++++-
 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
index 47de8937..23d3eef2 100644
--- 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
index 4fdc5d5a..ce30844c 100644
--- 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 ()