suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixed contracts in documentation

Browse Source
This commit is contained in:
Neil Toronto 2011-10-07 13:08:54 -06:00
parent 7aa6153da1
commit 8a60e1816a
3 changed files with 201 additions and 137 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

224
collects/plot/common/contract-doc.rkt
View File

@ -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))])))))))]))

62
collects/plot/common/serialize-syntax.rkt Normal file
View File

@ -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])))

52
collects/plot/scribblings/params.scrbl
View File

@ -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.