@history scraper

history-scraper.rkt.patch

diff --git a/scribble-lib/scribble/private/context.rkt b/scribble-lib/scribble/private/context.rkt
new file mode 100644
index 00000000..bd2fe49d
--- /dev/null
+++ b/scribble-lib/scribble/private/context.rkt
@@ -0,0 +1,5 @@
+#lang racket/base
+
+(provide current-id-name)
+
+(define current-id-name (make-parameter #f))
diff --git a/scribble-lib/scribble/private/manual-class.rkt b/scribble-lib/scribble/private/manual-class.rkt
index 5514d7a2..673431c6 100644
--- a/scribble-lib/scribble/private/manual-class.rkt
+++ b/scribble-lib/scribble/private/manual-class.rkt
@@ -5,6 +5,7 @@
          "../search.rkt"
          "../basic.rkt"
          "../manual-struct.rkt"
+         "context.rkt"
          "qsloc.rkt"
          scheme/serialize
          scheme/stxparam
@@ -294,7 +295,8 @@
                                       whole-page?
                                       make-class-index-desc
                                       link?)))
-                  (flatten-splices (list body ...))))
+                  (flatten-splices (parameterize ([current-id-name (quote-syntax/loc name)])
+                                     (list body ...)))))
      link?)))
 
 (define-syntax defclass
@@ -330,7 +332,7 @@
                                  whole-page?
                                  make-interface-index-desc
                                  link?)))
-                  (list body ...)))
+                  (parameterize ([current-id-name (quote-syntax/loc name)]) (list body ...))))
      link?)))
 
 (define-syntax-rule (definterface name (intf ...) body ...)
@@ -359,7 +361,7 @@
                                  whole-page?
                                  make-mixin-index-desc
                                  link?)))
-                  (list body ...)))
+                  (parameterize ([current-id-name (quote-syntax/loc name)]) (list body ...))))
      link?)))
 
 (define-syntax-rule (defmixin name (domain ...) (range ...) body ...)
diff --git a/scribble-lib/scribble/private/manual-form.rkt b/scribble-lib/scribble/private/manual-form.rkt
index e4c45ae0..4029e111 100644
--- a/scribble-lib/scribble/private/manual-form.rkt
+++ b/scribble-lib/scribble/private/manual-form.rkt
@@ -4,6 +4,7 @@
          "../scheme.rkt"
          "../basic.rkt"
          "../manual-struct.rkt"
+         "context.rkt"
          "qsloc.rkt"
          "manual-utils.rkt"
          "manual-vars.rkt"
@@ -106,6 +107,7 @@
             (l.lit ...)
             ([form [defined-id spec]] [form [defined-id spec1]] ...
              [non-term (g.non-term-id g.non-term-form ...)] ...)
+            #:id defined-id-expr
             (*defforms k.kind lt.expr defined-id-expr
                        '(spec spec1 ...)
                        (list (lambda (x) (racketblock0/form new-spec)) ...)
@@ -159,6 +161,7 @@
         (l.lit ...)
         ([form/none spec]
          [non-term (subs.g.non-term-id subs.g.non-term-form ...)] ...)
+        #:id #f
         (*defforms k.kind lt.expr #f
                    '(spec)
                    (list (lambda (ignored) (racketblock0/form spec)))
@@ -186,6 +189,7 @@
      #'(with-togetherable-racket-variables
         ()
         ()
+        #:id (quote-syntax/loc spec-id)
         (*defforms k.kind lt.expr (quote-syntax/loc spec-id)
                    '(spec-id)
                    (list (lambda (x) (make-omitable-paragraph (list x))))
@@ -218,6 +222,7 @@
         (l.lit ...)
         ([form/maybe (has-kw? spec)]
          [non-term (g.non-term-id g.non-term-form ...)] ...)
+        #:id #f
         (*specsubform 'spec '(l.lit ...) (lambda () (racketblock0/form spec))
                       '((g.non-term-id g.non-term-form ...) ...)
                       (list (list (lambda () (racket g.non-term-id))
@@ -281,6 +286,7 @@
      (with-racket-variables
       (lit ...)
       ([non-term (id clause ...)] ...)
+      #:id #f
       (*racketgrammar '(lit ...)
                       '(id ... clause ... ...)
                       (lambda ()
@@ -323,7 +329,8 @@
         content)))
 
 (define (*defforms kind link? kw-id forms form-procs subs sub-procs contract-procs content-thunk)
-  (parameterize ([current-meta-list '(... ...+)])
+  (parameterize ([current-meta-list '(... ...+)]
+                 [current-id-name kw-id])
     (make-box-splice
      (cons
       (make-blockquote
diff --git a/scribble-lib/scribble/private/manual-history.rkt b/scribble-lib/scribble/private/manual-history.rkt
index 08dbb23a..2a44ff14 100644
--- a/scribble-lib/scribble/private/manual-history.rkt
+++ b/scribble-lib/scribble/private/manual-history.rkt
@@ -2,8 +2,13 @@
 (require (for-syntax racket/base
                      syntax/parse)
          version/utils
+         racket/list
+         racket/match
+         racket/format
+         racket/pretty
          scribble/base
          scribble/core
+         "context.rkt"
          "manual-sprop.rkt"
          "manual-ex.rkt"
          "manual-style.rkt")
@@ -34,13 +39,39 @@
                           (format "not a valid version: ~e"
                                   vers)
                           (history-entry-vers-stx e))))
+  (define the-name (current-id-name))
   (delayed-block
    (lambda (renderer p ri)
+     (define (clense x)
+       (cond
+         [(list? x) (map clense x)]
+         [(element? x) (clense (element-content x))]
+         [(delayed-element? x) (clense ((delayed-element-resolve x) renderer p ri))]
+         [else x]))
      (define pkg
        (let ([from (resolve-get/tentative p ri '(exporting-packages #f))])
          (and from
               (pair? from)
               (car from))))
+     (define log-path (getenv "PLT_SCRIBBLE_HISTORY_LOG"))
+     (when log-path
+       (define e0 (history-entry-vers-stx (first es)))
+       (with-output-to-file log-path
+         #:exists 'append
+         (λ ()
+           (pretty-write
+            `([what ,(cond
+                       [(identifier? the-name) (syntax-e the-name)]
+                       [else the-name])]
+              [package ,pkg]
+              [source ,(~a (syntax-source e0))]
+              [line ,(syntax-line e0)]
+              [column ,(syntax-column e0)]
+              [history ,(for/list ([e (in-list es)])
+                          (match-define (history-entry what vers _ expl) e)
+                          `([method ,what]
+                            [version ,vers]
+                            [expl ,(concat (flatten (clense expl)))]))])))))
      (para
       #:style (style "SHistory" (list scheme-properties))
       (for/list ([e (in-list (sort es (lambda (a b) (version<? a b))
@@ -57,3 +88,11 @@
                   (list " of package " (tt pkg))
                   null)
               (history-entry-expl e)))))))
+
+(define (concat xs)
+  (match xs
+    [(list (? string? a) (? string? b) xs ...)
+     (concat (cons (string-append a b) xs))]
+    [(list x xs ...)
+     (cons x (concat xs))]
+    [_ xs]))
diff --git a/scribble-lib/scribble/private/manual-mod.rkt b/scribble-lib/scribble/private/manual-mod.rkt
index 10c4a1c6..043c258d 100644
--- a/scribble-lib/scribble/private/manual-mod.rkt
+++ b/scribble-lib/scribble/private/manual-mod.rkt
@@ -8,6 +8,7 @@
          "manual-style.rkt"
          "manual-scheme.rkt"
          "manual-utils.rkt"
+         "context.rkt"
          setup/main-collects
          pkg/path
          racket/list
@@ -114,7 +115,7 @@
                          packages
                          link-target-expr
                          kind
-                         (list . content)
+                         (parameterize ([current-id-name (ormap values (list show-name ...))]) (list . content))
                          req))))]))
 
 ;; ----------------------------------------
diff --git a/scribble-lib/scribble/private/manual-proc.rkt b/scribble-lib/scribble/private/manual-proc.rkt
index a5de2a45..2dab20b4 100644
--- a/scribble-lib/scribble/private/manual-proc.rkt
+++ b/scribble-lib/scribble/private/manual-proc.rkt
@@ -8,6 +8,7 @@
                   make-table-columns
                   content?)
          "../html-properties.rkt"
+         "context.rkt"
          "qsloc.rkt"
          "manual-utils.rkt"
          "manual-vars.rkt"
@@ -198,6 +199,7 @@
        (with-togetherable-racket-variables
         ()
         ([proc proto] ...)
+         #:id (ormap values (list (extract-proc-id d.key alt-id proto) ...))
         (let ([alt-id d.expr])
           (*defproc kind.kind
                     lt.expr
@@ -646,7 +648,8 @@
         (for/list ([p (in-list prototypes)]
                    [i (in-naturals)])
           (= i 0))))))
-    (content-thunk))))
+    (parameterize ([current-id-name (first stx-ids)])
+      (content-thunk)))))
 
 (define-syntax (defparam stx)
   (syntax-parse stx
@@ -749,6 +752,7 @@
   (with-togetherable-racket-variables
    ()
    ()
+   #:id (quote-syntax/loc name)
    (*defstruct link? (quote-syntax/loc name) 'name 
                (quote-syntax/loc cname) cname-given? extra-cname? default-extra? omit-constructor?
                '([field field-contract] ...)
@@ -1043,7 +1047,8 @@
     (make-blockquote
      vertical-inset-style
      (list main-table))
-    (content-thunk))))
+    (parameterize ([current-id-name stx-id])
+      (content-thunk)))))
 
 ;; ----------------------------------------
 
@@ -1060,6 +1065,8 @@
      #'(with-togetherable-racket-variables
         ()
         ()
+        ;; TODO: can we use id-expr without reevaluating it somehow?
+        #:id (quote-syntax/loc id)
         (let ([id-val id-expr])
           (*defthing kind.kind
                      lt.expr
@@ -1074,6 +1081,7 @@
      #'(with-togetherable-racket-variables
         ()
         ()
+        #:id (first (list (quote-syntax/loc id) ...))
         (*defthing kind.kind
                    lt.expr
                    (list (quote-syntax/loc id) ...) (list 'id ...) #f
@@ -1182,7 +1190,8 @@
                               (list (list
                                      (to-flow (list spacer "=" spacer))
                                      (list result-block))))))))))))))
-     (content-thunk))))
+    (parameterize ([current-id-name (first stx-ids)])
+      (content-thunk)))))
 
 (define (defthing/proc kind id contract descs)
   (*defthing kind #t (list id) (list (syntax-e id)) #f (list contract)
diff --git a/scribble-lib/scribble/private/manual-unit.rkt b/scribble-lib/scribble/private/manual-unit.rkt
index 29d88933..cce23db9 100644
--- a/scribble-lib/scribble/private/manual-unit.rkt
+++ b/scribble-lib/scribble/private/manual-unit.rkt
@@ -17,6 +17,7 @@
   (with-togetherable-racket-variables
    ()
    ()
+   #:id (quote-syntax name)
    (*defsignature (quote-syntax name)
                   (list (quote-syntax super) ...)
                   (lambda () (list body ...))
@@ -26,6 +27,7 @@
   (with-togetherable-racket-variables
    ()
    ()
+   #:id (quote-syntax name)
    (*defsignature (quote-syntax name)
                   (list (quote-syntax super) ...)
                   (lambda () (list body ...))
diff --git a/scribble-lib/scribble/private/manual-vars.rkt b/scribble-lib/scribble/private/manual-vars.rkt
index dd2158d4..79665f0f 100644
--- a/scribble-lib/scribble/private/manual-vars.rkt
+++ b/scribble-lib/scribble/private/manual-vars.rkt
@@ -7,6 +7,7 @@
                   nested-flow? nested-flow-blocks nested-flow-style
                   make-nested-flow)
          "../html-properties.rkt"
+         "context.rkt"
          racket/contract/base
          (for-syntax scheme/base
                      syntax/kerncase
@@ -73,10 +74,10 @@
 
 (define-syntax (with-togetherable-racket-variables stx)
   (syntax-case stx ()
-    [(_ lits vars decl)
+    [(_ lits vars #:id name decl)
      (with-syntax ([vars (syntax-property #'vars 'taint-mode 'none)])
        (syntax-property
-        #'(with-togetherable-racket-variables* lits vars decl)
+        #'(with-togetherable-racket-variables* lits vars #:id name decl)
         'taint-mode
         'transparent))]))
 
@@ -85,7 +86,7 @@
 
 (define-syntax (with-racket-variables stx)
   (syntax-case stx ()
-    [(_ lits ([kind s-exp] ...) body)
+    [(_ lits ([kind s-exp] ...) #:id name body)
      (let ([ht (make-bound-identifier-mapping)]
            [lits (syntax->datum #'lits)])
        (for-each (lambda (kind s-exp)
@@ -164,7 +165,7 @@
              body)))]))
 
 
-(define (*deftogether boxes body-thunk)
+(define (*deftogether boxes name body-thunk)
   (make-box-splice
    (cons
     (make-blockquote 
@@ -189,12 +190,13 @@
                                   "together"
                                   (table-flowss (car (nested-flow-blocks (car (splice-run box))))))))))
         boxes))))
-    (body-thunk))))
+    (parameterize ([current-id-name name])
+      (body-thunk)))))
 
 (define-syntax (deftogether stx)
   (syntax-case stx ()
     [(_ (def ...) . body)
-     (with-syntax ([((_ (lit ...) (var ...) decl) ...)
+     (with-syntax ([((_ (lit ...) (var ...) #:id name decl) ...)
                     (map (lambda (def)
                            (let ([exp-def (local-expand 
                                            def
@@ -203,7 +205,7 @@
                                             #'with-togetherable-racket-variables*
                                             (kernel-form-identifier-list)))])
                              (syntax-case exp-def (with-togetherable-racket-variables*)
-                               [(with-togetherable-racket-variables* lits vars decl)
+                               [(with-togetherable-racket-variables* lits vars #:id name decl)
                                 exp-def]
                                [_
                                 (raise-syntax-error
@@ -215,4 +217,5 @@
        #'(with-togetherable-racket-variables
           (lit ... ...)
           (var ... ...)
-          (*deftogether (list decl ...) (lambda () (list . body)))))]))
+          #:id (ormap values (list name ...))
+           (*deftogether (list decl ...) (ormap values (list name ...)) (lambda () (list . body)))))]))