From cb5c83c5a742db325143ac8d5125999d5673285f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Sat, 1 May 2010 08:31:33 -0600 Subject: [PATCH] add custom-print to printable<%>; redirect printable<%> to writable and pretty-print to pretty-write in 'scheme' --- collects/racket/private/class-internal.rkt | 19 +++++-- collects/scheme/base.rkt | 3 +- collects/scheme/class.rkt | 7 ++- collects/scheme/pretty.rkt | 7 ++- collects/scribblings/reference/class.scrbl | 26 ++++++--- collects/scribblings/reference/write.scrbl | 2 +- collects/scribblings/scheme/scheme.scrbl | 58 +++++++++++++++++--- collects/scribblings/scribble/renderer.scrbl | 2 +- 8 files changed, 97 insertions(+), 27 deletions(-) diff --git a/collects/racket/private/class-internal.rkt b/collects/racket/private/class-internal.rkt index e6f495758c..01142d85e6 100644 --- a/collects/racket/private/class-internal.rkt +++ b/collects/racket/private/class-internal.rkt @@ -34,7 +34,7 @@ class? mixin interface interface* interface? - object% object? externalizable<%> printable<%> equal<%> + object% object? externalizable<%> printable<%> writable<%> equal<%> object=? new make-object instantiate send send/apply send* class-field-accessor class-field-mutator with-method @@ -4669,14 +4669,23 @@ (define externalizable<%> (_interface () externalize internalize)) -(define printable<%> +(define writable<%> (interface* () - ([prop:custom-write (lambda (obj port write?) - (if write? + ([prop:custom-write (lambda (obj port mode) + (if mode (send obj custom-write port) (send obj custom-display port)))]) custom-write custom-display)) +(define printable<%> + (interface* () + ([prop:custom-write (lambda (obj port mode) + (case mode + [(#t) (send obj custom-write port)] + [(#f) (send obj custom-display port)] + [else (send obj custom-print port mode)]))]) + custom-write custom-display custom-print)) + (define equal<%> (interface* () ([prop:equal+hash (list @@ -4728,7 +4737,7 @@ class? mixin (rename-out [_interface interface]) interface* interface? - object% object? object=? externalizable<%> printable<%> equal<%> + object% object? object=? externalizable<%> printable<%> writable<%> equal<%> new make-object instantiate get-field set-field! field-bound? field-names send send/apply send* class-field-accessor class-field-mutator with-method diff --git a/collects/scheme/base.rkt b/collects/scheme/base.rkt index 9ce71d3cee..9838a94b0a 100644 --- a/collects/scheme/base.rkt +++ b/collects/scheme/base.rkt @@ -3,6 +3,7 @@ (provide (except-out (all-from-out racket/base) struct - hash hasheq hasheqv) + hash hasheq hasheqv + in-directory) make-base-empty-namespace make-base-namespace) diff --git a/collects/scheme/class.rkt b/collects/scheme/class.rkt index cb278f3b9b..b27204b533 100644 --- a/collects/scheme/class.rkt +++ b/collects/scheme/class.rkt @@ -1,2 +1,5 @@ -#lang scheme/private/provider -racket/class +#lang scheme/base +(require racket/class) +(provide (except-out (all-from-out racket/class) + printable<%>) + (rename-out [writable<%> printable<%>])) diff --git a/collects/scheme/pretty.rkt b/collects/scheme/pretty.rkt index 43ca9c3233..906281ea81 100644 --- a/collects/scheme/pretty.rkt +++ b/collects/scheme/pretty.rkt @@ -1,2 +1,5 @@ -#lang scheme/private/provider -racket/pretty +#lang scheme/base +(require racket/pretty) +(provide (except-out (all-from-out racket/pretty) + pretty-print) + (rename-out [pretty-write pretty-print])) diff --git a/collects/scribblings/reference/class.scrbl b/collects/scribblings/reference/class.scrbl index 33d34c6ead..55977cc3fd 100644 --- a/collects/scribblings/reference/class.scrbl +++ b/collects/scribblings/reference/class.scrbl @@ -1847,25 +1847,37 @@ The @scheme[externalizable<%>] interface includes only the @section[#:tag "objectprinting"]{Object Printing} -To customize the way that a class instance is printed by @scheme[write] -or @scheme[display], implement the @scheme[printable<%>] interface. +To customize the way that a class instance is printed by +@racket[print], @scheme[write] and @scheme[display], implement the +@scheme[printable<%>] interface. @defthing[printable<%> interface?]{ The @scheme[printable<%>] interface includes only the -@scheme[custom-write] and @scheme[custom-print] methods. Each accepts +@scheme[custom-print], @scheme[custom-write], and +@scheme[custom-display] methods. The @scheme[custom-print] method +accepts two arguments: the destination port and the current +@scheme[quaisquote] depth as an exact nonnegative integer. The +@scheme[custom-write] and @scheme[custom-display] methods each accepts a single argument, which is the destination port to @scheme[write] or @scheme[display] the object. -Calls to the @scheme[custom-write] or @scheme[custom-display] are like -calls to a procedure attached to a structure type through the -@scheme[prop:custom-write] property. In particular, recursive printing -can trigger an escape from the call. +Calls to the @racket[custom-print], @scheme[custom-write], or +@scheme[custom-display] methods are like calls to a procedure attached +to a structure type through the @scheme[prop:custom-write] +property. In particular, recursive printing can trigger an escape from +the call. See @scheme[prop:custom-write] for more information. The @scheme[printable<%>] interface is implemented with @scheme[interface*] and @scheme[prop:custom-write].} +@defthing[writable<%> interface?]{ + +Like @scheme[printable<%>], but includes only the +@scheme[custom-write] and @scheme[custom-print] methods. +A @racket[print] request is directed to @scheme[custom-write].} + @; ------------------------------------------------------------------------ @section[#:tag "objectutils"]{Object, Class, and Interface Utilities} diff --git a/collects/scribblings/reference/write.scrbl b/collects/scribblings/reference/write.scrbl index 3909c0f2e6..1553000945 100644 --- a/collects/scribblings/reference/write.scrbl +++ b/collects/scribblings/reference/write.scrbl @@ -44,7 +44,7 @@ proportional to the depth of the value being printed, due to the initial cycle check.} @defproc[(print [datum any/c][out output-port? (current-output-port)] - [exact-nonnegative-integer? qq-depth 0]) + [qq-depth exact-nonnegative-integer? 0]) void?]{ Writes @racket[datum] to @racket[out], normally the same way as diff --git a/collects/scribblings/scheme/scheme.scrbl b/collects/scribblings/scheme/scheme.scrbl index d35fafed28..0c10ad8d25 100644 --- a/collects/scribblings/scheme/scheme.scrbl +++ b/collects/scribblings/scheme/scheme.scrbl @@ -2,6 +2,10 @@ @(require (for-syntax racket) (for-label (only-in scheme/foreign unsafe! provide* define-unsafer) (only-in scheme/base make-base-namespace make-base-empty-namespace) + (only-in scheme/pretty pretty-print) + (only-in racket/pretty pretty-write) + (only-in scheme/class printable<%>) + (only-in racket/class writable<%>) scheme/gui/base scheme/sandbox)) @@ -10,24 +14,31 @@ make-base-empty-namespace-id sandbox-namespace-specs-id make-evaluator-id - make-module-evaluator-id) + make-module-evaluator-id + pretty-print-id + printable<%>-id) (begin (require (for-label (only-in scheme struct) (only-in racket/base make-base-namespace make-base-empty-namespace) + (only-in racket/pretty pretty-print) racket/sandbox)) (define unit-struct (racket struct)) (define make-base-namespace-id (racket make-base-namespace)) (define make-base-empty-namespace-id (racket make-base-empty-namespace)) (define sandbox-namespace-specs-id (racket sandbox-namespace-specs)) (define make-evaluator-id (racket make-evaluator)) - (define make-module-evaluator-id (racket make-module-evaluator)))) + (define make-module-evaluator-id (racket make-module-evaluator)) + (define pretty-print-id (racket pretty-print)) + (define printable<%>-id (racket printable<%>)))) @(def-extras unit-struct make-base-namespace-id make-base-empty-namespace-id sandbox-namespace-specs-id make-evaluator-id - make-module-evaluator-id) + make-module-evaluator-id + pretty-print-id + printable<%>-id) @(define-syntax-rule (compat-except sid rid . rest) (begin @@ -47,11 +58,14 @@ old name. @compat-except[scheme racket]{, except that @schememodname[racket]'s @scheme[struct] is not exported, the @|unit-struct| from -@schememodname[scheme/unit] is exported, @schememodname[scheme/set] -is not re-exported, and @schememodname[scheme/nest] is re-exported} +@schememodname[scheme/unit] is exported, @schememodname[scheme/set] is +not re-exported, @racket[pretty-print] is re-directed in as +@racketmodname[scheme/pretty], and @schememodname[scheme/nest] is +re-exported} @compat-except[scheme/base racket/base]{, except that -@schememodname[racket]'s @scheme[struct] is not exported, and +@schememodname[racket]'s @scheme[struct] is not exported, @scheme[in-directory] +is not exported, and @scheme[make-base-namespace] and @scheme[make-base-empty-namespace] are different} @@ -68,7 +82,21 @@ with @schememodname[scheme/base] attached.} @compat[scheme/async-channel racket/async-channel] @compat[scheme/bool racket/bool] -@compat[scheme/class racket/class] + +@; ---------------------------------------------------------------------- + +@compat-except[scheme/class racket/class]{, except that +@racket[writable<%>] is exported under the name @racket[printable<%>] +(and @|printable<%>-id| from @schememodname[racket/class] is not +exported)} + +@defthing[printable<%> interface?]{ + +An alias for @racket[writable<%>]. +} + +@; ---------------------------------------------------------------------- + @compat[scheme/cmdline racket/cmdline] @compat[scheme/contract racket/contract] @compat[scheme/control racket/control] @@ -180,7 +208,21 @@ than a precise prose description: @compat[scheme/package racket/package] @compat[scheme/path racket/path] @compat[scheme/port racket/port] -@compat[scheme/pretty racket/pretty] + +@; ---------------------------------------- + +@compat-except[scheme/pretty racket/pretty]{, except that +@racket[pretty-write] is exported under the name @racket[pretty-print] +(and @|pretty-print-id| from @schememodname[racket/pretty] is not +exported)} + +@defproc[(pretty-print [v any/c] [port output-port? (current-output-port)]) + void?]{ + +An alias for @racket[pretty-write].} + +@; ---------------------------------------- + @compat[scheme/promise racket/promise] @compat[scheme/provide racket/provide] @compat[scheme/provide-syntax racket/provide-syntax] diff --git a/collects/scribblings/scribble/renderer.scrbl b/collects/scribblings/scribble/renderer.scrbl index f9817b237f..ccd3332629 100644 --- a/collects/scribblings/scribble/renderer.scrbl +++ b/collects/scribblings/scribble/renderer.scrbl @@ -1,7 +1,7 @@ #lang scribble/doc @(require scribble/manual "utils.ss" - (for-label scheme/class)) + (for-label racket/class)) @(define-syntax-rule (defmodule/local lib . content) (begin