Fixed contracts in documentation

collects/plot/common/contract-doc.rkt

@@ -3,8 +3,8 @@
 ;; Definitions with contracts and contract documentation.
 
 (require racket/contract
-         (for-syntax racket/base racket/list syntax/parse racket/syntax syntax/strip-context
+         (for-syntax racket/base racket/list syntax/parse
-                     racket/vector)
+                     "serialize-syntax.rkt")
          (prefix-in s. scribble/manual)
          (prefix-in s. scribble/core)
          (prefix-in s. scribble/html-properties))
@@ -13,10 +13,7 @@
 
 (begin-for-syntax
   (struct proc+doc (proc-transformer doc-transformer)
-    #:transparent
+    #:property prop:procedure (λ (p stx) ((proc+doc-proc-transformer p) stx)))
-    #:property prop:procedure
-    (λ (t stx)
-      ((proc+doc-proc-transformer t) stx)))
   
   (define-syntax-class argument-spec
     #:description "argument specification"
@@ -26,6 +23,24 @@
     (pattern [kw:keyword name:id contract:expr default:expr]))
   )
 
+(define-for-syntax (make-proc+doc id-stx doc-transformer)
+  (proc+doc
+   (λ (stx)
+     (syntax-case stx ()
+       [(_ . args)  (quasisyntax/loc stx (#,id-stx . args))]
+       [_           (quasisyntax/loc stx #,id-stx)]))
+   doc-transformer))
+
+;; Applies the documentation transformer (use within a scribble/manual module)
+(define-syntax (doc-apply stx)
+  (define (error) (raise-syntax-error 'doc-apply "no associated doc transformer" stx))
+  (syntax-parse stx
+    [(_ name:id . pre-flows)
+     (define p (syntax-local-value #'name error))
+     (when (not (proc+doc? p)) (error))
+     ((proc+doc-doc-transformer p) (syntax/loc stx (name . pre-flows)))]))
+
+
 ;; A define-with-value form for scribble documentation
 (define (def/value def val . pre-flows)
   (apply s.nested (s.tabular #:style def/value-table-style
@@ -39,13 +54,6 @@
                   (list (s.style 'plain (list 'top (s.attributes '((width . "0%")))))
                         (s.style 'plain (list 'top 'left (s.attributes '((width . "100%"))))))))))
 
-;; Applies the documentation transformer (use within a scribble/manual module)
-(define-syntax (doc-apply stx)
-  (syntax-parse stx
-    [(_ name:id . pre-flows)
-     (let ([t  (syntax-local-value #'name)])
-       ((proc+doc-doc-transformer t) (syntax/loc stx (name . pre-flows))))]))
-
 ;; ===================================================================================================
 ;; Helpers
 
@@ -74,7 +82,13 @@
     (cond [(regexp-match #rx".*-(.*)$" name-str)  => (λ (m) (last m))]
           [(regexp-match #rx"^$" name-str)        => (λ (m) "value")]
           [else  (substring name-str 0 1)]))
-  (format-id name-stx "~a" arg-name-str))
+  (datum->syntax name-stx (string->symbol arg-name-str)))
+
+(define-for-syntax (make-value-name id-stx)
+  (datum->syntax #f (syntax->datum id-stx)))
+
+(define-for-syntax (make-doc-name ctx id-stx)
+  (datum->syntax ctx (syntax->datum id-stx)))
 
 ;; ===================================================================================================
 ;; define-with-contract+doc forms
@@ -82,112 +96,104 @@
 ;; Define a procedure
 (define-syntax (defproc stx)
   (syntax-parse stx
-    [(_ (name:id arg:argument-spec ...) result-contract:expr body ...+)
+    [(_ (name:id arg:argument-spec ...) result:expr body ...+)
      (define arg-list (syntax->list #'(arg ...)))
-     (define/with-syntax proc-name (strip-context #'name))
+     (with-syntax ([value-name          (make-value-name #'name)]
-     (define/with-syntax (new-arg ...) (append* (map remove-contract arg-list)))
+                   [(new-arg ...)       (append* (map remove-contract arg-list))]
-     (define/with-syntax (req-contract ...) (append* (map get-required-contract arg-list)))
+                   [(req-contract ...)  (append* (map get-required-contract arg-list))]
-     (define/with-syntax (opt-contract ...) (append* (map get-optional-contract arg-list)))
+                   [(opt-contract ...)  (append* (map get-optional-contract arg-list))]
+                   [serialized-args     (serialize-syntax #'(arg ...))]
+                   [serialized-result   (serialize-syntax #'result)])
        (syntax/loc stx
          (begin
-         (define/contract (proc-name new-arg ...) (->* (req-contract ...) (opt-contract ...)
+           (define/contract (value-name new-arg ...) (->* (req-contract ...) (opt-contract ...)
-                                                       result-contract)
+                                                             result)
              body ...)
            (define-syntax name
-           (proc+doc
+             (make-proc+doc
-            (λ (app-stx)
+              #'value-name
-              (syntax-case app-stx ()
-                [(_ . args) (syntax/loc app-stx (proc-name . args))]
-                [_          (syntax/loc app-stx proc-name)]))
               (λ (doc-stx)
                 (syntax-case doc-stx ()
-                [(the-name . pre-flows)
+                  [(ctx . pre-flows)
-                 (with-syntax ([doc-name             (replace-context #'the-name #'name)]
+                   (with-syntax ([doc-name    (make-doc-name #'ctx #'name)]
-                               [doc-args             (replace-context #'the-name #'(arg ...))]
+                                 [doc-args    (unserialize-syntax #'ctx 'serialized-args)]
-                               [doc-result-contract  (replace-context #'the-name #'result-contract)])
+                                 [doc-result  (unserialize-syntax #'ctx 'serialized-result)])
-                   #'(s.defproc (doc-name . doc-args) doc-result-contract . pre-flows))]))))))]))
+                     #'(s.defproc (doc-name . doc-args) doc-result . pre-flows))])))))))]))
 
 ;; Define a parameter
 (define-syntax (defparam stx)
   (syntax-parse stx
     [(_ name:id arg:id contract:expr default:expr)
-     (define/with-syntax proc-name (strip-context #'name))
+     (with-syntax ([value-name           (make-value-name #'name)]
+                   [serialized-contract  (serialize-syntax #'contract)]
+                   [serialized-default   (serialize-syntax #'default)])
        (syntax/loc stx
          (begin
-         (define/contract proc-name (parameter/c contract) (make-parameter default))
+           (define/contract value-name (parameter/c contract) (make-parameter default))
            (define-syntax name
-           (proc+doc
+             (make-proc+doc
-            (λ (app-stx)
+              #'value-name
-              (syntax-case app-stx ()
-                [(_ . args)  (syntax/loc app-stx (proc-name . args))]
-                [_           (syntax/loc app-stx proc-name)]))
               (λ (doc-stx)
                 (syntax-case doc-stx ()
-                [(the-name . pre-flows)
+                  [(ctx . pre-flows)
-                 (with-syntax ([doc-name      (replace-context #'the-name #'name)]
+                   (with-syntax ([doc-name      (make-doc-name #'ctx #'name)]
-                               [doc-arg       (replace-context #'the-name #'arg)]
+                                 [doc-arg       (make-doc-name #'ctx #'arg)]
-                               [doc-contract  (replace-context #'the-name #'contract)]
+                                 [doc-contract  (unserialize-syntax #'ctx 'serialized-contract)]
-                               [doc-default   (replace-context #'the-name #'default)])
+                                 [doc-default   (unserialize-syntax #'ctx 'serialized-default)])
-                   (syntax/loc doc-stx
+                     #'(def/value
-                     (def/value
                          (s.defparam doc-name doc-arg doc-contract)
                          (s.racketblock doc-default)
-                       . pre-flows)))]))))))]
+                         . pre-flows))])))))))]
     [(_ name:id contract:expr default:expr)
-     (define/with-syntax arg-name (parameter-name->arg-name #'name))
+     (quasisyntax/loc stx
-     (syntax/loc stx (defparam name arg-name contract default))]))
+       (defparam name #,(parameter-name->arg-name #'name) contract default))]))
 
 ;; Define a contract or a procedure that returns a contract
 (define-syntax (defcontract stx)
   (syntax-parse stx
     [(_ name:id value:expr)
-     (define/with-syntax contract-name (strip-context #'name))
+     (with-syntax ([value-name        (make-value-name #'name)]
+                   [serialized-value  (serialize-syntax #'value)])
        (syntax/loc stx
          (begin
-         (define contract-name value)
+           (define value-name value)
            (define-syntax name
-           (proc+doc
+             (make-proc+doc
-            (λ (app-stx)
+              #'value-name
-              (syntax-case app-stx ()
-                [(_ . args)  (syntax/loc app-stx (contract-name . args))]
-                [_           (syntax/loc app-stx contract-name)]))
               (λ (doc-stx)
                 (syntax-case doc-stx ()
-                [(the-name . pre-flows)
+                  [(ctx . pre-flows)
-                 (with-syntax ([doc-name       (replace-context #'the-name #'name)]
+                   (with-syntax ([doc-name       (make-doc-name #'ctx #'name)]
-                               [doc-contract?  (replace-context #'the-name #'contract?)]
+                                 [doc-contract?  (make-doc-name #'ctx #'contract?)]
-                               [doc-value      (replace-context #'the-name #'value)])
+                                 [doc-value      (unserialize-syntax #'ctx 'serialized-value)])
-                   (syntax/loc doc-stx
+                     #'(def/value
-                     (def/value
                          (s.defthing doc-name doc-contract?)
                          (s.racketblock doc-value)
-                       . pre-flows)))]))))))]
+                         . pre-flows))])))))))]
     [(_ (name:id arg:argument-spec ...) body)
      (define arg-list (syntax->list #'(arg ...)))
-     (define/with-syntax proc-name (strip-context #'name))
+     (with-syntax ([value-name          (make-value-name #'name)]
-     (define/with-syntax (new-arg ...) (append* (map remove-contract arg-list)))
+                   [(new-arg ...)       (append* (map remove-contract arg-list))]
-     (define/with-syntax (req-contract ...) (append* (map get-required-contract arg-list)))
+                   [(req-contract ...)  (append* (map get-required-contract arg-list))]
-     (define/with-syntax (opt-contract ...) (append* (map get-optional-contract arg-list)))
+                   [(opt-contract ...)  (append* (map get-optional-contract arg-list))]
+                   [serialized-args     (serialize-syntax #'(arg ...))]
+                   [serialized-body     (serialize-syntax #'body)])
        (syntax/loc stx
          (begin
-         (define/contract (proc-name new-arg ...) (->* (req-contract ...) (opt-contract ...)
+           (define/contract (value-name new-arg ...) (->* (req-contract ...) (opt-contract ...)
                                                              contract?)
              body)
            (define-syntax name
-           (proc+doc
+             (make-proc+doc
-            (λ (app-stx)
+              #'value-name
-              (syntax-case app-stx ()
-                [(_ . args) (syntax/loc app-stx (proc-name . args))]
-                [_          (syntax/loc app-stx proc-name)]))
               (λ (doc-stx)
-              (syntax-case doc-stx ()
+                (syntax-case doc-stx (doc)
-                [(the-name . pre-flows)
+                  [(ctx . pre-flows)
-                 (with-syntax ([doc-name       (replace-context #'the-name #'name)]
+                   (with-syntax ([doc-name       (make-doc-name #'ctx #'name)]
-                               [doc-args       (replace-context #'the-name #'(arg ...))]
+                                 [doc-contract?  (make-doc-name #'ctx #'contract?)]
-                               [doc-contract?  (replace-context #'the-name #'contract?)]
+                                 [doc-args       (unserialize-syntax #'ctx 'serialized-args)]
-                               [doc-body       (replace-context #'the-name #'body)])
+                                 [doc-body       (unserialize-syntax #'ctx 'serialized-body)])
-                   (syntax/loc doc-stx
+                     #'(def/value
-                     (def/value
                          (s.defproc (doc-name . doc-args) doc-contract?)
                          (s.racketblock doc-body)
-                      . pre-flows)))]))))))]))
+                         . pre-flows))])))))))]))

collects/plot/common/serialize-syntax.rkt

@@ -0,0 +1,62 @@
+#lang racket/base
+
+;; Serialize and unserialize syntax objects
+
+;; Serializing doesn't store lexical information, so unserializing requires an extra piece of
+;; information: the new lexical context. Therefore, 'unserialize' acts a lot like 'replace-context'.
+
+;; Serializing also doesn't store ALL the syntax properties - just the ones with symbol keys.
+
+(require racket/match)
+
+(provide serialize-syntax unserialize-syntax)
+
+;; serialize-props : syntax -> (listof (cons symbol value))
+;; Serializes the properties of a syntax object.
+(define (serialize-props stx)
+  (map (λ (key) (cons key (syntax-property stx key)))
+       (syntax-property-symbol-keys stx)))
+
+;; unserialize-props : syntax (listof (cons symbol value)) -> syntax
+;; Unserializes properties; returns a new syntax object that is like the old but with the properties.
+(define (unserialize-props stx props)
+  (for/fold ([stx stx]) ([kv  (in-list props)])
+    (match-define (cons key v) kv)
+    (syntax-property stx key v)))
+
+;; serialize-loc : syntax -> list
+;; Serializes the source location of a syntax object, as a list. This is one of the formats that
+;; datum->syntax accepts as a source location, so there is no need for unserialize-loc.
+(define (serialize-loc stx)
+  (list (syntax-source stx)
+        (syntax-line stx)
+        (syntax-column stx)
+        (syntax-position stx)
+        (syntax-span stx)))
+
+;; serialize-syntax : syntax -> list
+;; Serializes a syntax object.
+(define (serialize-syntax e)
+  (cond
+    [(syntax? e)  (list 'syntax
+                        (serialize-syntax (syntax-e e))
+                        (serialize-loc e)
+                        (serialize-props e))]
+    [(pair? e)    (list 'pair (serialize-syntax (car e)) (serialize-syntax (cdr e)))]
+    [(vector? e)  (list 'vector (serialize-syntax (vector->list e)))]
+    [(box? e)     (list 'box (serialize-syntax (unbox e)))]
+    [(prefab-struct-key e) => (λ (k) (list 'struct k (serialize-syntax (struct->vector e))))]
+    [else         (list 'datum e)]))
+
+;; unserialize-syntax : syntax list -> syntax
+;; Unserializes a syntax object, and associates with each part of it the given context.
+(define (unserialize-syntax ctx lst)
+  (let loop ([lst lst])
+    ;(printf "lst = ~v~n" lst)
+    (match lst
+      [(list 'syntax lst loc props)  (unserialize-props (datum->syntax ctx (loop lst) loc) props)]
+      [(list 'pair lst1 lst2)        (cons (loop lst1) (loop lst2))]
+      [(list 'vector lst)            (list->vector (loop lst))]
+      [(list 'box lst)               (box (loop lst))]
+      [(list 'struct k lst)          (apply make-prefab-struct k (loop lst))]
+      [(list 'datum e)               e])))

collects/plot/scribblings/params.scrbl

@@ -6,22 +6,18 @@
 
 @title[#:tag "params"]{Plot and Renderer Parameters}
 
-@section{Shared 2D/3D Parameters}
+@section{Compatibility}
-
-@subsection{Compatibility}
 
 @doc-apply[plot-deprecation-warnings?]{
 When @(racket #t), prints a deprecation warning to @(racket current-error-port) on the first use of @(racket mix), @(racket line), @(racket contour), @(racket shade), @(racket surface), or a keyword argument of @(racket plot) or @(racket plot3d) that exists solely for backward compatibility.
 }
 
-@subsection{Output}
+@section{Output}
 
 @doc-apply[plot-new-window?]{When @(racket #t), @(racket plot) and @(racket plot3d) open a new window for each plot instead of returning an @(racket image-snip%).
 
 Users of command-line Racket, which cannot display image snips, should enter
-
 @racketblock[(plot-new-window? #t)]
-
 before using @(racket plot) or @(racket plot3d).}
 
 @doc-apply[plot-width]
@@ -31,11 +27,13 @@ before using @(racket plot) or @(racket plot3d).}
 @doc-apply[plot-ps-interactive?]
 @doc-apply[plot-pdf-interactive?]
 
-@subsection{Axis Transforms}
+@section{Axis Transforms}
 
 @doc-apply[plot-x-transform]
 @doc-apply[plot-y-transform]
-@doc-apply[plot-z-transform]
+@doc-apply[plot-z-transform]{
+Per-axis, nonlinear transforms. Set these, for example, to plot with log-scale axes.
+}
 
 @doc-apply[id-transform]{
 The default transform for all axes.
@@ -44,7 +42,7 @@ The default transform for all axes.
 @doc-apply[log-transform]{
 A log transform. Use this to generate plots with log-scale axes. Any log-scaled axis must be on a positive interval.
 
-@interaction[#:eval plot-eval
+@examples[#:eval plot-eval
                  (parameterize ([plot-y-transform  log-transform])
                    (plot (function (λ (x) x) 1 2)))
                  (parameterize ([plot-x-transform  log-transform])
@@ -65,7 +63,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
                                 (plot (function sqr -1 1)))]
 }
 
-@subsection{General Appearance}
+@section{General Appearance}
 
 @doc-apply[plot-foreground]
 @doc-apply[plot-background]{The plot foreground and background color. That both are @(racket 0) by default is not a mistake: for foreground colors, @(racket 0) is interpreted as black; for background colors, @(racket 0) is interpreted as white. See @(racket plot-color/c) for details on integer-indexed colors.}
@@ -87,7 +85,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
 @doc-apply[plot-z-label]{The title and axis labels. A @(racket #f) value means the label is not drawn and takes no space. A @(racket "") value effectively means the label is not drawn, but it takes space.
 }
 
-@subsection{Lines}
+@section{Lines}
 
 @doc-apply[line-samples]
 @doc-apply[line-color]
@@ -95,7 +93,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
 @doc-apply[line-style]
 @doc-apply[line-alpha]
 
-@subsection{Intervals}
+@section{Intervals}
 
 @doc-apply[interval-color]
 @doc-apply[interval-style]
@@ -107,7 +105,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
 @doc-apply[interval-line2-style]
 @doc-apply[interval-alpha]
 
-@subsection{Points}
+@section{Points}
 
 @doc-apply[point-sym]
 @doc-apply[point-color]
@@ -115,7 +113,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
 @doc-apply[point-line-width]
 @doc-apply[point-alpha]
 
-@subsection{Vector Fields}
+@section{Vector Fields}
 
 @doc-apply[vector-field-samples]
 @doc-apply[vector-field-color]
@@ -124,7 +122,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
 @doc-apply[vector-field-scale]
 @doc-apply[vector-field-alpha]
 
-@subsection{Error Bars}
+@section{Error Bars}
 
 @doc-apply[error-bar-width]
 @doc-apply[error-bar-color]
@@ -132,7 +130,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
 @doc-apply[error-bar-line-style]
 @doc-apply[error-bar-alpha]
 
-@subsection{Contours and Contour Intervals}
+@section{Contours and Contour Intervals}
 
 @doc-apply[default-contour-colors]
 @doc-apply[default-contour-fill-colors]
@@ -148,7 +146,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
 @doc-apply[contour-interval-styles]
 @doc-apply[contour-interval-alphas]
 
-@subsection{Rectangles}
+@section{Rectangles}
 
 @doc-apply[rectangle-color]
 @doc-apply[rectangle-style]
@@ -161,7 +159,7 @@ The @(racket freq) parameter controls the ``shakiness'' of the transform. At hig
 
 @doc-apply[discrete-histogram-gap]
 
-@subsection{Decorations}
+@section{Decorations}
 
 These parameters do not control the @italic{typical} appearance of plots. Instead, they control the look of renderers that add specific decorations, such as labeled points.
 
@@ -177,9 +175,7 @@ These parameters do not control the @italic{typical} appearance of plots. Instea
 @doc-apply[label-alpha]
 @doc-apply[label-point-size]
 
-@section{3D-Specific Parameters}
+@section{3D General Appearance}
-
-@subsection{3D General Appearance}
 
 @doc-apply[plot3d-samples]
 @doc-apply[plot3d-animating?]
@@ -189,7 +185,7 @@ These parameters do not control the @italic{typical} appearance of plots. Instea
 @doc-apply[plot3d-diffuse-light?]
 @doc-apply[plot3d-specular-light?]
 
-@subsection{Surfaces}
+@section{Surfaces}
 
 @doc-apply[surface-color]
 @doc-apply[surface-style]
@@ -198,7 +194,7 @@ These parameters do not control the @italic{typical} appearance of plots. Instea
 @doc-apply[surface-line-style]
 @doc-apply[surface-alpha]
 
-@subsection{Contour Surfaces}
+@section{Contour Surfaces}
 
 Contour surface renderers use shared contour parameters except for the following three.
 
@@ -206,7 +202,7 @@ Contour surface renderers use shared contour parameters except for the following
 @doc-apply[contour-interval-line-widths]
 @doc-apply[contour-interval-line-styles]
 
-@subsection{Isosurfaces}
+@section{Isosurfaces}
 
 Single isosurfaces (@(racket isosurface3d)) use surface parameters. Nested isosurfaces (@(racket isosurfaces3d)) use the following.