adjust the way framework and tools docs extract documentation

svn: r10727

collects/file/gif.ss

@@ -573,7 +573,7 @@
 
              Given a set of pixels expressed in ARGB format (i.e., each four
              bytes is a set of values for one pixel: alpha, red, blue, and
-             green),@scheme[quantize] produces produces
+             green), @scheme[quantize] produces produces
 
              @(itemize @item{bytes for the image (i.e., a array of colors,
                              expressed as a byte string)}

collects/scribble/extract.ss

@@ -5,9 +5,12 @@
          scribble/srcdoc
          (for-syntax scheme/base
                      scheme/path
-                     syntax/path-spec))
+                     syntax/path-spec
+                     (for-syntax scheme/base)))
 
-(provide include-extracted)
+(provide include-extracted
+         provide-extracted
+         include-previously-extracted)
 
 (define-for-syntax (strip-context c)
   (cond
@@ -19,72 +22,124 @@
                     (strip-context (cdr c)))]
    [else c]))
 
+(define-for-syntax (extract orig-path stx)
+  (let ([path (resolve-path-spec orig-path orig-path stx)])
+    (let ([s-exp 
+           (parameterize ([current-namespace (make-base-namespace)]
+                          [read-accept-reader #t]
+                          [current-load-relative-directory
+                           (path-only path)])
+             (expand
+              (with-input-from-file path
+                (lambda ()
+                  (port-count-lines! (current-input-port))
+                  (read-syntax path)))))])
+      (syntax-case s-exp ()
+        [(mod name lang
+              (mod-beg
+               content ...))
+         (with-syntax ([((content id) ...)
+                        (apply
+                         append
+                         (map (lambda (c)
+                                (syntax-case c (#%plain-app void quote-syntax provide/doc)
+                                  [(#%plain-app void (quote-syntax (provide/doc spec ...)))
+                                   (syntax->list #'(spec ...))]
+                                  [_ null]))
+                              (syntax->list #'(content ...))))]
+                       [(req ...)
+                        (map
+                         strip-context
+                         (apply
+                          append
+                          (map (lambda (c)
+                                 (syntax-case c (#%require #%plain-app void quote-syntax require/doc)
+                                   [(#%require spec ...)
+                                    (let loop ([specs (syntax->list #'(spec ...))])
+                                      (cond
+                                       [(null? specs) '()]
+                                       [else (let ([spec (car specs)])
+                                               (syntax-case spec (for-syntax for-meta)
+                                                 [(for-syntax . spec) (loop (cdr specs))]
+                                                 [(for-meta . spec) (loop (cdr specs))]
+                                                 [(for-template . spec) (loop (cdr specs))]
+                                                 [(for-label . spec) (loop (cdr specs))]
+                                                 [(just-meta . spec) (loop (cdr specs))]
+                                                 [_ (cons #`(for-label #,spec) (loop (cdr specs)))]))]))]
+                                   [(#%plain-app void (quote-syntax (require/doc spec ...)))
+                                    (syntax->list #'(spec ...))]
+                                   [_ null]))
+                               (syntax->list #'(content ...)))))]
+                       [orig-tag (datum->syntax #f 'orig)])
+           ;; This template is matched in `filter-info', below
+           #`(begin
+               (#%require (for-label #,(strip-context #'lang))
+                          (for-label #,(strip-context orig-path)) 
+                          req ...)
+               (drop-first (quote-syntax id) (def-it orig-tag content)) ...))]))))
+
 (define-syntax (include-extracted stx)
   (syntax-case stx ()
-    [(_ orig-path) #'(include-extracted orig-path #rx"")] ;; this regexp matches everything
+    [(_ orig-path)
+     (extract #'orig-path stx)]))
+
+(define-syntax (provide-extracted stx)
+  (syntax-case stx ()
+    [(_ orig-path)
+     (with-syntax ([(_begin reqs (_drop-first (_quote-syntax id) def) ...)
+                    (extract #'orig-path stx)])
+       #'(begin
+           (require (for-label (only-in orig-path))) ;; creates build dependency
+           (define-syntax (extracted stx)
+             (syntax-case stx ()
+               [(_ rx)
+                (let-syntax ([quote-syntax/loc 
+                              (lambda (stx)
+                                (syntax-case stx ()
+                                  [(_ s)
+                                   (let loop ([stx #'s])
+                                     (cond
+                                      [(syntax? stx)
+                                       (let ([ctx (datum->syntax stx 'ctx #f #f stx)])
+                                         (let ([s 
+                                                #`(datum->syntax (quote-syntax #,ctx)
+                                                                 #,(loop (syntax-e stx))
+                                                                 #,(and (syntax-position stx)
+                                                                        (vector (let ([s (syntax-source stx)])
+                                                                                  (if (path-string? s)
+                                                                                      s
+                                                                                      (format "~s" s)))
+                                                                                (syntax-line stx)
+                                                                                (syntax-column stx)
+                                                                                (syntax-position stx)
+                                                                                (syntax-span stx))))])
+                                           (let ([p (syntax-property stx 'paren-shape)])
+                                             (if p
+                                                 #`(syntax-property #,s 'paren-shape '#,p)
+                                                 s))))]
+                                      [(pair? stx) #`(cons #,(loop (car stx)) #,(loop (cdr stx)))]
+                                      [(vector? stx) #`(vector #,@(map loop (vector->list stx)))]
+                                      [(box? stx) #`(box #,(loop (unbox stx)))]
+                                      [else #`(quote #,stx)]))]))])
+                  #`(begin #,(quote-syntax/loc reqs)
+                           #,@(filter
+                               values
+                               (map (lambda (i d)
+                                      (if (regexp-match (syntax-e #'rx) (symbol->string i))
+                                          (d)
+                                          #f))
+                                    (list 'id ...)
+                                    (list (lambda () (quote-syntax/loc def)) ...)))))]))
+           (provide extracted)))]))
+
+(define-syntax (include-previously-extracted stx)
+  (syntax-case stx ()
     [(_ orig-path regexp-s)
-     (let ([path (resolve-path-spec #'orig-path #'orig-path stx)]
-           [reg (syntax-e #'regexp-s)])
-       (unless (regexp? reg)
-         (raise-syntax-error #f "expected a literal regular expression as the second argument" stx #'regexp-s))
-       (let ([s-exp 
-              (parameterize ([current-namespace (make-base-namespace)]
-                             [read-accept-reader #t]
-                             [current-load-relative-directory
-                              (path-only path)])
-                (expand
-                 (with-input-from-file path
-                   (lambda ()
-                     (port-count-lines! (current-input-port))
-                     (read-syntax path)))))])
-         (syntax-case s-exp ()
-           [(mod name lang
-                 (mod-beg
-                  content ...))
-            (with-syntax ([(content ...)
-                           (apply
-                            append
-                            (map (lambda (c)
-                                   (syntax-case c (#%plain-app void quote-syntax provide/doc)
-                                     [(#%plain-app void (quote-syntax (provide/doc spec ...)))
-                                      (map
-                                       (λ (x) (syntax-case x () [(docs id) #'docs])) 
-                                       (filter (λ (x)
-                                                 (syntax-case x ()
-                                                   [(stuff id)
-                                                    (regexp-match reg (symbol->string (syntax-e #'id)))]))
-                                               (syntax->list #'(spec ...))))]
-                                     [_ null]))
-                                 (syntax->list #'(content ...))))]
-                          [(req ...)
-                           (map
-                            strip-context
-                            (apply
-                             append
-                             (map (lambda (c)
-                                    (syntax-case c (#%require #%plain-app void quote-syntax require/doc)
-                                      [(#%require spec ...)
-                                       (let loop ([specs (syntax->list #'(spec ...))])
-                                         (cond
-                                           [(null? specs) '()]
-                                           [else (let ([spec (car specs)])
-                                                   (syntax-case spec (for-syntax for-meta)
-                                                     [(for-syntax . spec) (loop (cdr specs))]
-                                                     [(for-meta . spec) (loop (cdr specs))]
-                                                     [(for-template . spec) (loop (cdr specs))]
-                                                     [(for-label . spec) (loop (cdr specs))]
-                                                     [(just-meta . spec) (loop (cdr specs))]
-                                                     [_ (cons #`(for-label #,spec) (loop (cdr specs)))]))]))]
-                                      [(#%plain-app void (quote-syntax (require/doc spec ...)))
-                                       (syntax->list #'(spec ...))]
-                                      [_ null]))
-                                  (syntax->list #'(content ...)))))]
-                          [orig-tag (datum->syntax #f 'orig)])
-              #`(begin
-                  (#%require (for-label #,(strip-context #'lang))
-                             (for-label #,(strip-context #'orig-path)) 
-                             req ...)
-                  (def-it orig-tag content) ...))])))]))
+     (unless (regexp? (syntax-e #'regexp-s))
+       (raise-syntax-error #f "expected a literal regular expression as the second argument" stx #'regexp-s))
+     #`(begin
+         (require (only-in orig-path [#,(datum->syntax #'orig-path 'extracted) extracted]))
+         (extracted regexp-s))]))
 
 (define-for-syntax (revise-context c orig-tag new-tag tag)
   (cond
@@ -94,6 +149,7 @@
          new-tag
          orig-tag)
      (revise-context (syntax-e c) orig-tag new-tag tag)
+     c
      c)]
    [(pair? c) (cons (revise-context (car c) orig-tag new-tag tag)
                     (revise-context (cdr c) orig-tag new-tag tag))]
@@ -109,3 +165,5 @@
         #`(begin
             (require . #,(revise-context #'reqs orig-tag new-tag #'tag))
             #,(revise-context #'doc orig-tag new-tag #'tag)))])))
+
+(define-syntax-rule (drop-first a b) b)

collects/scribble/srcdoc.ss

@@ -183,7 +183,7 @@
          (values
           #'[id contract]
           #'(defproc* header . desc)
-          #'(scribble/manual)
+          #'((only-in scribble/manual defproc*))
           #'id))])))
 
 (define-provide/doc-transformer parameter-doc
@@ -204,7 +204,7 @@
          (values
           #'[id (parameter/c contract)]
           #'(defparam id arg-id contract . desc)
-          #'(scribble/manual)
+          #'((only-in scribble/manual defparam))
           #'id))])))
 
 (define-provide/doc-transformer thing-doc
@@ -220,5 +220,5 @@
          (values
           #'[id contract]
           #'(defthing id contract . desc)
-          #'(scribble/manual)
+          #'((only-in scribble/manual defthing))
           #'id))])))

collects/scribblings/framework/application.scrbl

@@ -5,4 +5,4 @@
 @title{Application}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^application:")
+@(include-previously-extracted "main-extracts.ss" #rx"^application:")

collects/scribblings/framework/autosave.scrbl

@@ -15,4 +15,4 @@
   }
 }
 
-@(include-extracted (lib "main.ss" "framework") #rx"^autosave:")
+@(include-previously-extracted "main-extracts.ss" #rx"^autosave:")

collects/scribblings/framework/canvas.scrbl

@@ -99,4 +99,4 @@
 @defclass[canvas:delegate% (canvas:delegate-mixin canvas:basic%) ()]{}
 @defclass[canvas:wide-snip% (canvas:wide-snip-mixin canvas:basic%) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^canvas:")
+@(include-previously-extracted "main-extracts.ss" #rx"^canvas:")

collects/scribblings/framework/color-model.scrbl

@@ -5,4 +5,4 @@
 @title{Color Model}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^color-model:")
+@(include-previously-extracted "main-extracts.ss" #rx"^color-model:")

collects/scribblings/framework/color-prefs.scrbl

@@ -5,4 +5,4 @@
 @title{Color Prefs}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^color-prefs:")
+@(include-previously-extracted "main-extracts.ss" #rx"^color-prefs:")

collects/scribblings/framework/color.scrbl

@@ -230,4 +230,4 @@
 }
 @defclass[color:text-mode% (color:text-mode-mixin mode:surrogate-text%) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^color:")
+@(include-previously-extracted "main-extracts.ss" #rx"^color:")

collects/scribblings/framework/comment-box.scrbl

@@ -45,4 +45,4 @@
   }
 }
 
-@(include-extracted (lib "main.ss" "framework") #rx"^comment-box:")
+@(include-previously-extracted "main-extracts.ss" #rx"^comment-box:")

collects/scribblings/framework/editor.scrbl

@@ -455,4 +455,4 @@
   }
 }
 
-@(include-extracted (lib "main.ss" "framework") #rx"^editor:")
+@(include-previously-extracted "main-extracts.ss" #rx"^editor:")

collects/scribblings/framework/exit.scrbl

@@ -5,4 +5,4 @@
 @title{Exit}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^exit:")
+@(include-previously-extracted "main-extracts.ss" #rx"^exit:")

collects/scribblings/framework/finder.scrbl

@@ -5,4 +5,4 @@
 @title{Finder}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^finder:")
+@(include-previously-extracted "main-extracts.ss" #rx"^finder:")

collects/scribblings/framework/frame.scrbl

@@ -1060,4 +1060,4 @@
 @defclass[frame:delegate% (frame:delegate-mixin frame:searchable%) ()]{}
 @defclass[frame:pasteboard% (frame:pasteboard-mixin frame:open-here%) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^frame:")
+@(include-previously-extracted "main-extracts.ss" #rx"^frame:")

collects/scribblings/framework/group.scrbl

@@ -121,4 +121,4 @@
   }
 }
 
-@(include-extracted (lib "main.ss" "framework") #rx"^group:")
+@(include-previously-extracted "main-extracts.ss" #rx"^group:")

collects/scribblings/framework/handler.scrbl

@@ -5,4 +5,4 @@
 @title{Handler}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^handler:")
+@(include-previously-extracted "main-extracts.ss" #rx"^handler:")

collects/scribblings/framework/icon.scrbl

@@ -5,4 +5,4 @@
 @title{Icon}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^icon:")
+@(include-previously-extracted "main-extracts.ss" #rx"^icon:")

collects/scribblings/framework/keymap.scrbl

@@ -42,4 +42,4 @@
 }
 @defclass[keymap:aug-keymap% (keymap:aug-keymap-mixin keymap%) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^keymap:")
+@(include-previously-extracted "main-extracts.ss" #rx"^keymap:")

collects/scribblings/framework/main-extracts.ss

@@ -0,0 +1,4 @@
+#lang scheme/base
+(require scribble/extract)
+
+(provide-extracted (lib "main.ss" "framework"))

collects/scribblings/framework/main.scrbl

@@ -5,4 +5,4 @@
 @title{Main}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^main:")
+@(include-previously-extracted "main-extracts.ss" #rx"^main:")

collects/scribblings/framework/menu.scrbl

@@ -45,4 +45,4 @@
 @defclass[menu:can-restore-checkable-menu-item% (menu:can-restore-mixin checkable-menu-item%) ()]{}
 @defclass[menu:can-restore-underscore-menu% (menu:can-restore-underscore-mixin menu%) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^menu:")
+@(include-previously-extracted "main-extracts.ss" #rx"^menu:")

collects/scribblings/framework/mode.scrbl

@@ -43,4 +43,4 @@
 (surrogate-methods docs)
 )
 
-@(include-extracted (lib "main.ss" "framework") #rx"^mode:")
+@(include-previously-extracted "main-extracts.ss" #rx"^mode:")

collects/scribblings/framework/number-snip.scrbl

@@ -12,4 +12,4 @@
   }
 }
 
-@(include-extracted (lib "main.ss" "framework") #rx"^number-snip:")
+@(include-previously-extracted "main-extracts.ss" #rx"^number-snip:")

collects/scribblings/framework/panel.scrbl

@@ -168,4 +168,4 @@
 @defclass[panel:vertical-dragable% (panel:vertical-dragable-mixin (panel:dragable-mixin vertical-panel%)) ()]{}
 @defclass[panel:horizontal-dragable% (panel:horizontal-dragable-mixin (panel:dragable-mixin horizontal-panel%)) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^panel:")
+@(include-previously-extracted "main-extracts.ss" #rx"^panel:")

collects/scribblings/framework/pasteboard.scrbl

@@ -11,4 +11,4 @@
 @defclass[pasteboard:backup-autosave% (editor:backup-autosave-mixin pasteboard:file%) ()]{}
 @defclass[pasteboard:info% (editor:info-mixin pasteboard:backup-autosave%) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^pasteboard:")
+@(include-previously-extracted "main-extracts.ss" #rx"^pasteboard:")

collects/scribblings/framework/path-utils.scrbl

@@ -5,4 +5,4 @@
 @title{Path Utils}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^path-utils:")
+@(include-previously-extracted "main-extracts.ss" #rx"^path-utils:")

collects/scribblings/framework/preferences.scrbl

@@ -5,4 +5,4 @@
 @title{Preferences}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^preferences:")
+@(include-previously-extracted "main-extracts.ss" #rx"^preferences:")

collects/scribblings/framework/scheme.scrbl

@@ -270,4 +270,4 @@
 @defclass[scheme:text% (scheme:set-mode-mixin (scheme:text-mixin (text:autocomplete-mixin (mode:host-text-mixin color:text%)))) ()]{}
 @defclass[scheme:text-mode% (scheme:text-mode-mixin color:text-mode%) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^scheme:")
+@(include-previously-extracted "main-extracts.ss" #rx"^scheme:")

collects/scribblings/framework/text.scrbl

@@ -944,4 +944,4 @@
 @defclass[text:searching% (text:searching-mixin text:backup-autosave%) ()]{}
 @defclass[text:info% (text:info-mixin (editor:info-mixin text:searching%)) ()]{}
 
-@(include-extracted (lib "main.ss" "framework") #rx"^text:")
+@(include-previously-extracted "main-extracts.ss" #rx"^text:")

collects/scribblings/framework/version.scrbl

@@ -5,4 +5,4 @@
 @title{Version}
 
 
-@(include-extracted (lib "main.ss" "framework") #rx"^version:")
+@(include-previously-extracted "main-extracts.ss" #rx"^version:")

collects/scribblings/tools/common.ss

@@ -37,7 +37,7 @@
      (string? (syntax-e #'name))
      (let ([name (syntax-e #'name)])
        (with-syntax ([rx (regexp (format "^drscheme:~a:" name))])
-         #'(include-extracted (lib "tool-lib.ss" "drscheme") rx)))]))
+         #'(include-previously-extracted "tool-lib-extracts.ss" rx)))]))
 
 (provide docs-get/extend)
 (define-syntax (docs-get/extend stx)

collects/scribblings/tools/tool-lib-extracts.ss

@@ -0,0 +1,5 @@
+#lang scheme/base
+
+(require scribble/extract)
+
+(provide-extracted (lib "tool-lib.ss" "drscheme"))