Add rebellion/custom-write modules

custom-write.rkt

@@ -0,0 +1,2 @@
+#lang reprovide
+rebellion/private/custom-write

custom-write/struct.rkt

@@ -0,0 +1,2 @@
+#lang reprovide
+rebellion/private/custom-write-struct

custom-write/tuple.rkt

@@ -0,0 +1,2 @@
+#lang reprovide
+rebellion/private/custom-write-tuple

main.scrbl

@@ -9,6 +9,7 @@ languages, new frameworks, and new tools with.
 
 @local-table-of-contents[#:style 'immediate-only]
 
+@include-section[(lib "rebellion/private/custom-write.scrbl")]
 @include-section[(lib "rebellion/private/entry.scrbl")]
 @include-section[(lib "rebellion/private/equal+hash.scrbl")]
 @include-section[(lib "rebellion/private/generative-token.scrbl")]
@@ -19,7 +20,6 @@ languages, new frameworks, and new tools with.
 @include-section[(lib "rebellion/private/point.scrbl")]
 @include-section[(lib "rebellion/private/record.scrbl")]
 @include-section[(lib "rebellion/private/struct-descriptor.scrbl")]
-@include-section[(lib "rebellion/private/struct-write-property.scrbl")]
 @include-section[(lib "rebellion/private/table.scrbl")]
 @include-section[(lib "rebellion/private/tuple-type.scrbl")]
 @include-section[(lib "rebellion/private/variant.scrbl")]

private/custom-write-struct.rkt

@@ -0,0 +1,25 @@
+#lang racket/base
+
+(require racket/contract/base)
+
+(provide
+ (contract-out
+  [make-struct-constructor-style-custom-write
+   (-> struct-descriptor? custom-write-function/c)]))
+
+(require racket/struct
+         rebellion/custom-write
+         rebellion/struct-descriptor)
+
+;@------------------------------------------------------------------------------
+
+(define (make-struct-constructor-style-custom-write descriptor)
+  (define type-name (struct-descriptor-name descriptor))
+  (define size
+    (+ (struct-descriptor-mutable-fields descriptor)
+       (struct-descriptor-immutable-fields descriptor)
+       (struct-descriptor-auto-fields descriptor)))
+  (define accessor (struct-descriptor-accessor descriptor))
+  (make-constructor-style-printer
+   (λ (this) type-name)
+   (λ (this) (build-list size (λ (pos) (accessor this pos))))))

private/custom-write-tuple.rkt

@@ -0,0 +1,23 @@
+#lang racket/base
+
+(require racket/contract/base)
+
+(provide
+ (contract-out
+  [make-tuple-constructor-style-custom-write
+   (-> tuple-descriptor? custom-write-function/c)]))
+
+(require racket/struct
+         rebellion/custom-write
+         rebellion/tuple-type)
+
+;@------------------------------------------------------------------------------
+
+(define (make-tuple-constructor-style-custom-write descriptor)
+  (define type (tuple-descriptor-type descriptor))
+  (define type-name (tuple-type-name type))
+  (define size (tuple-type-size type))
+  (define accessor (tuple-descriptor-accessor descriptor))
+  (make-constructor-style-printer
+   (λ (_) type-name)
+   (λ (this) (build-list size (λ (pos) (accessor this pos))))))

private/custom-write.rkt

@@ -0,0 +1,39 @@
+#lang racket/base
+
+(require racket/contract/base)
+
+(provide
+ (contract-out
+  [custom-write-mode/c flat-contract?]
+  [custom-write-function/c chaperone-contract?]
+  [make-named-object-custom-write
+   (->* (symbol?) (#:name-getter (-> any/c (or/c symbol? #f)))
+        custom-write-function/c)]
+  [make-constant-custom-write (-> symbol? custom-write-function/c)]))
+
+;@------------------------------------------------------------------------------
+
+(define custom-write-mode/c (or/c boolean? 0 1))
+
+(define custom-write-function/c
+  (-> any/c output-port? custom-write-mode/c void?))
+
+(define (make-named-object-custom-write type-name
+                                        #:name-getter [get-name object-name])
+  (define type-part (string-append "#<" (symbol->string type-name)))
+  (λ (this out mode)
+    (parameterize ([current-output-port out])
+      (write-string type-part)
+      (define name (get-name this))
+      (when name
+        (write-string ":")
+        (write-string (symbol->string name)))
+      (write-string ">"))
+    (void)))
+
+(define (make-constant-custom-write name)
+  (define str (string-append "#<" (symbol->string name) ">"))
+  (λ (this out mode)
+    (parameterize ([current-output-port out])
+      (write-string str))
+    (void)))

private/custom-write.scrbl

@@ -0,0 +1,121 @@
+#lang scribble/manual
+
+@(require (for-label racket/base
+                     racket/contract/base
+                     racket/pretty
+                     racket/struct
+                     rebellion/custom-write
+                     rebellion/custom-write/struct
+                     rebellion/custom-write/tuple
+                     rebellion/struct-descriptor
+                     rebellion/tuple-type
+                     rebellion/tuple-type-definition)
+          (submod rebellion/private/scribble-evaluator-factory doc)
+          scribble/example)
+
+@(define make-evaluator
+   (make-module-sharing-evaluator-factory
+    #:public (list 'racket/pretty
+                   'rebellion/custom-write
+                   'rebellion/custom-write/struct
+                   'rebellion/custom-write/tuple
+                   'rebellion/struct-descriptor
+                   'rebellion/tuple-type
+                   'rebellion/tuple-type-definition)
+    #:private (list 'racket/base)))
+
+@title{Custom Write Implementations}
+@defmodule[rebellion/custom-write]
+
+A @deftech{custom write implementation} is a function that prints values and is
+suitable for use with @racket[prop:custom-write]. Custom write implementations
+must satisfy the @racket[custom-write-function/c] contract.
+
+@defthing[custom-write-function/c chaperone-contract?
+          #:value (-> any/c output-port? custom-write-mode/c void?)]{
+ A @tech{contract} describing functions suitable for use with @racket[
+ prop:custom-write].}
+
+@defthing[custom-write-mode/c flat-contract?
+          #:value (or/c boolean? 0 1)]{
+ A @tech{contract} describing the @racket[_mode] argument to functions matching
+ @racket[custom-write-function/c]. See @racket[gen:custom-write] for details.}
+
+@defproc[(make-named-object-custom-write
+          [type-name symbol?]
+          [#:name-getter get-name (-> any/c (or/c symbol? #f)) object-name])
+         custom-write-function/c]{
+ Constructs a @tech{custom write implementation} that prints values as opaque,
+ unreadable, named objects, similar to the way functions are printed.
+
+ @(examples
+   #:eval (make-evaluator) #:once
+   (struct person (name)
+     #:property prop:object-name (struct-field-index name)
+     #:property prop:custom-write (make-named-object-custom-write 'person))
+
+   (person 'alyssa)
+   (person 'jared)
+   (person #f))}
+
+@defproc[(make-constant-custom-write [name symbol?]) custom-write-function/c]{
+ Constructs a @tech{custom write implementation} that prints all values as the
+ same opaque constant value named @racket[name], similar to the way @racket[eof]
+ prints.
+
+ @(examples
+   #:eval (make-evaluator) #:once
+   (struct widget ()
+     #:property prop:custom-write (make-constant-custom-write 'widget))
+
+   (widget))}
+
+@section{Struct Custom Write Implementations}
+@defmodule[rebellion/custom-write/struct]
+
+@defproc[(make-struct-constructor-style-custom-write
+          [descriptor struct-descriptor?])
+         custom-write-function/c]{
+ Constructs a @tech{custom write implementation} that prints instances of the
+ structure type described by @racket[descriptor] in a manner similar to the way
+ that @racket[make-constructor-style-printer] prints values.
+
+ @(examples
+   #:eval (make-evaluator) #:once
+   (define (make-props descriptor)
+     (define custom-write
+       (make-struct-constructor-style-custom-write descriptor))
+     (list (cons prop:custom-write custom-write)))
+
+   (define point-descriptor
+     (make-struct-type/descriptor #:name 'point
+                                  #:immutable-fields 2
+                                  #:property-maker make-props))
+   (define point (struct-descriptor-constructor point-descriptor))
+
+   (point 1 2)
+   (parameterize ([pretty-print-columns 10])
+     (pretty-print (point 100000000000000 200000000000000))))}
+
+@section{Tuple Custom Write Implementations}
+@defmodule[rebellion/custom-write/tuple]
+
+@defproc[(make-tuple-constructor-style-custom-write
+          [descriptor tuple-descriptor?])
+         custom-write-function/c]{
+ Constructs a @tech{custom write implementation} that prints instances of the
+ @tech{tuple type} described by @racket[descriptor] in a manner similar to the
+ way that @racket[make-constructor-style-printer] prints values.
+
+ @(examples
+   #:eval (make-evaluator) #:once
+   (define-tuple-type point (x y)
+     #:property-maker
+     (λ (descriptor)
+       (define custom-write
+         (make-tuple-constructor-style-custom-write descriptor))
+       (list (cons prop:custom-write custom-write))))
+
+   (point 1 2)
+   (parameterize ([pretty-print-columns 10])
+     (pretty-print (point 100000000000000 200000000000000))))}

private/permutation.rkt

@@ -46,12 +46,12 @@
           (equal? (permutation-size perm) expected-size)))))
 
 (define (make-permutation-properties descriptor)
-  (list (cons prop:equal+hash
-              (make-struct-equal+hash descriptor))
-        (cons prop:custom-write
-              (make-constructor-style-printer
-               (λ (_) 'permutation)
-               (λ (this) (permutation-vector this))))))
+  (define custom-write
+    (make-constructor-style-printer
+     (λ (_) 'permutation)
+     (λ (this) (permutation-vector this))))
+  (list (cons prop:equal+hash (make-struct-equal+hash descriptor))
+        (cons prop:custom-write custom-write)))
 
 (define permutation-descriptor
   (make-struct-type/descriptor

private/tuple-type.rkt

@@ -45,13 +45,13 @@
 
 (require racket/math
          racket/struct
+         rebellion/custom-write/struct
+         rebellion/equal+hash
+         rebellion/equal+hash/struct
          rebellion/keyset
          rebellion/permutation
          rebellion/private/struct-definition-util
-         rebellion/struct-descriptor
-         rebellion/equal+hash
-         rebellion/equal+hash/struct
-         rebellion/struct-write-property)
+         rebellion/struct-descriptor)
 
 (module+ test
   (require (submod "..")
@@ -62,8 +62,7 @@
 
 (define (make-transparent-style-properties descriptor)
   (define equal+hash (make-struct-equal+hash descriptor))
-  (define custom-write
-    (make-constructor-style-struct-write-property descriptor))
+  (define custom-write (make-struct-constructor-style-custom-write descriptor))
   (list (cons prop:equal+hash equal+hash)
         (cons prop:custom-write custom-write)))