[plt-dev] overriding constructor style printing

Matthew (cc'ing plt-dev)-

On Mar 3, 2009, at 4:00 PM, Matthew Flatt wrote:

> I think you want to implement the `prop:print-convert-constructor- 
> name'
> property:
>
> #lang scheme
> (provide external)
> (require mzlib/pconvert-prop)
> (define-struct internal (value) #:transparent
>   #:property prop:print-convert-constructor-name 'external)
> (define (external v) (make-internal v))

I looked into that option, but it is not sufficiently general for my  
goal.

I think reducing my issue down to a simpler test case for presentation  
to the list was a mistake; I've corrected that mistake at the end of  
this email.

----

I do not want to expose the internal structure at all; I want an  
abstract view of the fields it contains.  In general, the designer of  
an abstract data type wants to only provide an abstract view of that  
type.  Sometimes that goal conflicts with constructor-style printing,  
but not always.

In my particular case, I am trying to develop a multiset abstraction,  
``bag''.
The primary constructor for bag (or ``pseudo-constructor'' if you  
prefer) is a *procedure* and not one of the constructors resulting  
from a define-struct special form.  The pseudo-constructor for bag has  
an interface analogous to that of the list procedure.

Internally a bag is represented by a structure, unordered, with one  
field (which itself holds a list).  But I do not want my external  
student clients to see that view; I want them only to see an  
expression involving the bag pseudo-constructor, and the exported  
operations on the bag abstraction.

----

So, back to my question: "if I am developing a teachpack that is  
intended for use with the Student languages (Beginning Student et al),  
how do I override how structures I define are printed?"

I have attached the code I have below so you can see concretely what I  
am talking about.  The end goal here is that I want the following to  
work as follows at the Interactions Window:
 > (bag 1 2)
(bag 1 2)

but I cannot figure out how to get that effect in the Student  
languages.  (I *can* get it via the mzlib/pconvert library alone.)  At  
this point I have employed the prop:print-convert-constructor-name  
property to implement the following approximation:
 > (bag 1 2)
(make-bag (list 1 2))

but this does not satisfy me.

-Felix

Here is the relevant code:

;;; FILE: bag.ss
#lang scheme
(provide bag bag? bag-contains?
          bag-choose bag-choose-first bag-choose-rest
          bag-length bag-union bag-map bag-fold
          subbag?)

(require mzlib/pconvert)
(require mzlib/pconvert-prop)
#|
(install-converting-printer)
|#

;; A [Bagof X] is a (make-unordered [Listof X])

;; interpretation:
;; a (make-unordered (list x1 x2 .. xN) is a multiset containing N  
elements

(define-struct unordered (elems)
   #:property prop:equal+hash
   (let ((hasher (lambda (b hash)
                   (foldr (lambda (x n) (bitwise-ior (hash x) n)) 0))))
     (list (lambda (b1 b2 equal?)
             (and (= (bag-length b1) (bag-length b2))
                  (subbag? b1 b2)
                  (subbag? b2 b1)))
           hasher
           hasher))

   #:property prop:custom-write
   (lambda (b p write-mode)
     (let ((p* (open-output-string)))
       (if write-mode
           (write (unordered-elems b) p*)
           (display (unordered-elems b) p*))
       (write-string "#<bag " p)
       (write-string (get-output-string p*)
                     p)
       (write-string ">" p)))

   #:property prop:print-convert-constructor-name 'make-bag
   #:transparent
   )

(current-print-convert-hook
  (let ((old-hook (current-print-convert-hook)))
    (lambda (v basic-convert sub-convert)
      (if (bag? v)
          `(bag ,@(map sub-convert (unordered-elems v)))
          (old-hook v basic-convert sub-convert)))))

(define (bag? x)
   (unordered? x))

;; subbag? : [Bagof X] [Bagof X] -> Boolean
(define (subbag? b1 b2)
   (andmap (lambda (x) (bag-contains? b2 x))
           (unordered-elems b1)))

;; bag-contains? : [Bagof X] X -> Boolean
(define (bag-contains? b x)
   (not (not (member x (unordered-elems b)))))

;; bag : X ... -> [Bagof X]
(define (bag . l)
   (make-unordered l))

;; bag-choose : [Bagof X] -> (values X [Bagof X])
(define (bag-choose b)
   (values (car (unordered-elems b))
           (make-unordered (cdr (unordered-elems b)))))

;; bag-choose-first : [Bagof X] -> X
(define (bag-choose-first b)
   (call-with-values (lambda () (bag-choose b)) (lambda (x b*) x)))

;; bag-choose-rest : [Bagof X] -> [Bagof X]
(define (bag-choose-rest b)
   (call-with-values (lambda () (bag-choose b)) (lambda (x b*) b*)))

;; bag-length : [Bagof X] -> Nat
(define (bag-length b)
   (length (unordered-elems b)))

;; bag-union : [Bagof X] ... -> [Bagof X]
(define (bag-union . l)
   (make-unordered (append-map unordered-elems l)))

;; bag-map : (X -> Y) [Bagof X] -> [Bagof Y]
(define (bag-map f b)
   (make-unordered (map f (unordered-elems b))))

;; bag-append-map : (X -> [Bagof Y]) [Bagof X] -> [Bagof Y]
(define (bag-append-map f b)
   (foldr bag-union (bag) (map f (unordered-elems b))))

;; bag-fold : (X Y -> Y) Y [Bagof X] -> Y
(define (bag-fold f z b)
   (foldr f z (unordered-elems b)))

;; build-bag : Nat (Nat -> X) -> [Bagof X]
(define (build-bag n f)
   (make-unordered (build-list n f)))

;;; END OF FILE bag.ss

;; The first three lines of this file were inserted by DrScheme. They  
record metadata
;; about the language level of this file in a form that our tools can  
easily process.
#reader(lib "htdp-intermediate-lambda-reader.ss" "lang")((modname  
arrangements) (read-case-sensitive #t) (teachpacks ((lib "world.ss"  
"teachpack" "htdp"))) (htdp-settings #(#t constructor repeating- 
decimal #f #t none #f ((lib "world.ss" "teachpack" "htdp")))))
;;; FILE: arrangements.ss

(require "bag.ss")

;; A Word is a [Listof Symbol]

;; all-placements : Symbol Word -> [Bagof Word]
(check-expect (all-placements 's '()) (bag '(s)))
(check-expect (all-placements 's '(a)) (bag '(s a) '(a s)))
(check-expect (all-placements 's '(a b)) (bag '(s a b) '(a s b) '(a b  
s)))
(define (all-placements s w)
   (cond
     ((empty? w) (bag (list s)))
     (else  (bag-union
             (bag (cons s w))
             (bag-map (lambda (w*) (cons (first w) w*))
                      (all-placements s (rest w)))))))

;; arrangements : Word -> [Bagof Word]
;; produces all permutations of a-word
(check-expect (arrangements empty)        (bag empty))
(check-expect (arrangements (list 'd))    (bag (list 'd)))
(check-expect (arrangements (list 'c 'd)) (bag (list 'c 'd) (list 'd  
'c)))
(check-expect (arrangements (list 'c 'd)) (bag (list 'd 'c) (list 'c  
'd)))
(define (arrangements x)
   (cond
     ((empty? x) (bag empty))
     (else (bag-fold (lambda (w* b)
                       (bag-union (all-placements (first x) w*)
                                  b))
                     (bag)
                     (arrangements (rest x))))))

;;; END OF FILE arrangements.ss