From 8a60e1816aaba559f2be5ac23e9f2e474c384b70 Mon Sep 17 00:00:00 2001 From: Neil Toronto Date: Fri, 7 Oct 2011 13:08:54 -0600 Subject: [PATCH] Fixed contracts in documentation --- collects/plot/common/contract-doc.rkt | 224 +++++++++++----------- collects/plot/common/serialize-syntax.rkt | 62 ++++++ collects/plot/scribblings/params.scrbl | 52 +++-- 3 files changed, 201 insertions(+), 137 deletions(-) create mode 100644 collects/plot/common/serialize-syntax.rkt diff --git a/collects/plot/common/contract-doc.rkt b/collects/plot/common/contract-doc.rkt index e964fbe00d..35267872dd 100644 --- a/collects/plot/common/contract-doc.rkt +++ b/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 - racket/vector) + (for-syntax racket/base racket/list syntax/parse + "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 - (λ (t stx) - ((proc+doc-proc-transformer t) stx))) + #:property prop:procedure (λ (p stx) ((proc+doc-proc-transformer p) 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)) - (define/with-syntax (new-arg ...) (append* (map remove-contract arg-list))) - (define/with-syntax (req-contract ...) (append* (map get-required-contract arg-list))) - (define/with-syntax (opt-contract ...) (append* (map get-optional-contract arg-list))) - (syntax/loc stx - (begin - (define/contract (proc-name new-arg ...) (->* (req-contract ...) (opt-contract ...) - result-contract) - body ...) - (define-syntax name - (proc+doc - (λ (app-stx) - (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) - (with-syntax ([doc-name (replace-context #'the-name #'name)] - [doc-args (replace-context #'the-name #'(arg ...))] - [doc-result-contract (replace-context #'the-name #'result-contract)]) - #'(s.defproc (doc-name . doc-args) doc-result-contract . pre-flows))]))))))])) + (with-syntax ([value-name (make-value-name #'name)] + [(new-arg ...) (append* (map remove-contract arg-list))] + [(req-contract ...) (append* (map get-required-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 (value-name new-arg ...) (->* (req-contract ...) (opt-contract ...) + result) + body ...) + (define-syntax name + (make-proc+doc + #'value-name + (λ (doc-stx) + (syntax-case doc-stx () + [(ctx . pre-flows) + (with-syntax ([doc-name (make-doc-name #'ctx #'name)] + [doc-args (unserialize-syntax #'ctx 'serialized-args)] + [doc-result (unserialize-syntax #'ctx 'serialized-result)]) + #'(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)) - (syntax/loc stx - (begin - (define/contract proc-name (parameter/c contract) (make-parameter default)) - (define-syntax name - (proc+doc - (λ (app-stx) - (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) - (with-syntax ([doc-name (replace-context #'the-name #'name)] - [doc-arg (replace-context #'the-name #'arg)] - [doc-contract (replace-context #'the-name #'contract)] - [doc-default (replace-context #'the-name #'default)]) - (syntax/loc doc-stx - (def/value - (s.defparam doc-name doc-arg doc-contract) - (s.racketblock doc-default) - . pre-flows)))]))))))] + (with-syntax ([value-name (make-value-name #'name)] + [serialized-contract (serialize-syntax #'contract)] + [serialized-default (serialize-syntax #'default)]) + (syntax/loc stx + (begin + (define/contract value-name (parameter/c contract) (make-parameter default)) + (define-syntax name + (make-proc+doc + #'value-name + (λ (doc-stx) + (syntax-case doc-stx () + [(ctx . pre-flows) + (with-syntax ([doc-name (make-doc-name #'ctx #'name)] + [doc-arg (make-doc-name #'ctx #'arg)] + [doc-contract (unserialize-syntax #'ctx 'serialized-contract)] + [doc-default (unserialize-syntax #'ctx 'serialized-default)]) + #'(def/value + (s.defparam doc-name doc-arg doc-contract) + (s.racketblock doc-default) + . pre-flows))])))))))] [(_ name:id contract:expr default:expr) - (define/with-syntax arg-name (parameter-name->arg-name #'name)) - (syntax/loc stx (defparam name arg-name contract default))])) + (quasisyntax/loc stx + (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)) - (syntax/loc stx - (begin - (define contract-name value) - (define-syntax name - (proc+doc - (λ (app-stx) - (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) - (with-syntax ([doc-name (replace-context #'the-name #'name)] - [doc-contract? (replace-context #'the-name #'contract?)] - [doc-value (replace-context #'the-name #'value)]) - (syntax/loc doc-stx - (def/value - (s.defthing doc-name doc-contract?) - (s.racketblock doc-value) - . pre-flows)))]))))))] + (with-syntax ([value-name (make-value-name #'name)] + [serialized-value (serialize-syntax #'value)]) + (syntax/loc stx + (begin + (define value-name value) + (define-syntax name + (make-proc+doc + #'value-name + (λ (doc-stx) + (syntax-case doc-stx () + [(ctx . pre-flows) + (with-syntax ([doc-name (make-doc-name #'ctx #'name)] + [doc-contract? (make-doc-name #'ctx #'contract?)] + [doc-value (unserialize-syntax #'ctx 'serialized-value)]) + #'(def/value + (s.defthing doc-name doc-contract?) + (s.racketblock doc-value) + . pre-flows))])))))))] [(_ (name:id arg:argument-spec ...) body) (define arg-list (syntax->list #'(arg ...))) - (define/with-syntax proc-name (strip-context #'name)) - (define/with-syntax (new-arg ...) (append* (map remove-contract arg-list))) - (define/with-syntax (req-contract ...) (append* (map get-required-contract arg-list))) - (define/with-syntax (opt-contract ...) (append* (map get-optional-contract arg-list))) - (syntax/loc stx - (begin - (define/contract (proc-name new-arg ...) (->* (req-contract ...) (opt-contract ...) - contract?) - body) - (define-syntax name - (proc+doc - (λ (app-stx) - (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) - (with-syntax ([doc-name (replace-context #'the-name #'name)] - [doc-args (replace-context #'the-name #'(arg ...))] - [doc-contract? (replace-context #'the-name #'contract?)] - [doc-body (replace-context #'the-name #'body)]) - (syntax/loc doc-stx - (def/value - (s.defproc (doc-name . doc-args) doc-contract?) - (s.racketblock doc-body) - . pre-flows)))]))))))])) + (with-syntax ([value-name (make-value-name #'name)] + [(new-arg ...) (append* (map remove-contract arg-list))] + [(req-contract ...) (append* (map get-required-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 (value-name new-arg ...) (->* (req-contract ...) (opt-contract ...) + contract?) + body) + (define-syntax name + (make-proc+doc + #'value-name + (λ (doc-stx) + (syntax-case doc-stx (doc) + [(ctx . pre-flows) + (with-syntax ([doc-name (make-doc-name #'ctx #'name)] + [doc-contract? (make-doc-name #'ctx #'contract?)] + [doc-args (unserialize-syntax #'ctx 'serialized-args)] + [doc-body (unserialize-syntax #'ctx 'serialized-body)]) + #'(def/value + (s.defproc (doc-name . doc-args) doc-contract?) + (s.racketblock doc-body) + . pre-flows))])))))))])) diff --git a/collects/plot/common/serialize-syntax.rkt b/collects/plot/common/serialize-syntax.rkt new file mode 100644 index 0000000000..28520583eb --- /dev/null +++ b/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]))) diff --git a/collects/plot/scribblings/params.scrbl b/collects/plot/scribblings/params.scrbl index 89e0abd4d2..ce47392105 100644 --- a/collects/plot/scribblings/params.scrbl +++ b/collects/plot/scribblings/params.scrbl @@ -6,22 +6,18 @@ @title[#:tag "params"]{Plot and Renderer Parameters} -@section{Shared 2D/3D Parameters} - -@subsection{Compatibility} +@section{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,11 +42,11 @@ 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 - (parameterize ([plot-y-transform log-transform]) - (plot (function (λ (x) x) 1 2))) - (parameterize ([plot-x-transform log-transform]) - (plot (function (λ (x) x) -1 1)))] +@examples[#:eval plot-eval + (parameterize ([plot-y-transform log-transform]) + (plot (function (λ (x) x) 1 2))) + (parameterize ([plot-x-transform log-transform]) + (plot (function (λ (x) x) -1 1)))] } @doc-apply[cbrt-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} - -@subsection{3D General Appearance} +@section{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.