[plt-scheme] Polymorphic Structure Types

From: Andre van Tonder (andre at het.brown.edu)
Date: Mon Apr 21 22:29:56 EDT 2003

; I have put together some macros for defining polymorphic
; record types with multiple supertypes, in a way that is compatible
; with the match.ss pattern matching library.  See below for source and
; examples.

; Motivation:
; The built-in Mzscheme define-struct type allows single inheritance
; of structure types.  However, many problems may be expressed
; very naturally in terms of structures that may have more
; than one supertype (see e.g. how heavily interfaces are used in Java),
; without necessarily needing a more heavyweight object system.
; In addition, since I personally like programming in pattern-matching
; style, I wanted match.ss to work polymorphically on subtypes.

; Note that strongly-typed functional languages (e.g. Haskell, ML)
; are usually weak in their support for extensible product types,
; although O'Haskell and Hugs with TREX do support them in some form.

; Examples of use:

(require (lib "poly-records.ss" "mzscheme"))

(define-record point x y)
(define-record color r g b)

; Define a record with supertypes point and color:
; Fields can be in any order, but
; if all the fields present in supertype are not declared
; an expand-time warning will be printed.
; This is somewhat in the spirit of Java interfaces.
; This ensures that reordering of fields of supertypes
; will not break procedures defined on the subtype and helps
; modularity by making the ordering of the subtype fields
; explicit (important for constructors and positional pattern
; matching expressions).

(define-record colored-point (point color) x y r g b tag)

; Define some instances:

(define a-point (make-point 50 70))
(define a-colored-point (make-colored-point 10 20 1 2 3 'a-tag))

; Predicates and accessors of supertypes will work
; polymorphically also on subtype, e.g.

(color?  a-colored-point)   ;=> #t
(point-x a-point)           ;=> 50
(point-x a-colored-point)   ;=> 10
(color-g a-colored-point)   ;=> 2

; Instances of subtype can be used polymorphically in
; (match.ss) pattern matching expressions instead of
; any one of its supertypes.

(match a-point         [($ point x y)   (list x y)])   ;=>  '(50 70)
(match a-colored-point [($ point x y)   (list x y)])   ;=>  '(10 20)
(match a-colored-point [($ color r g b) (list r g b)]) ;=>  '(1 2 3)

; By the way, Bruce Hauman has made a very nice port of a more
; sophisticated version of the match.ss library.  You can get it
; from
;   http://sol.cs.wcu.edu/~bhauman/scheme/pattern.html
; and then you can use "field selector patterns", useful
; for records with many fields:

; (match a-colored-point [(and (= point-x x) (= color-g g)) (list x g)])

             ;=> '(10 2)


; Macros:
; Written by Andre van Tonder (andre at het.brown.edu)
; Expanded and commented version available upon request.

(module poly-records mzscheme

  (provide define-record)

  (require-for-syntax (lib "list.ss"))

  (require (lib "etc.ss"))

  ; Fragmentt copied from Eli Barzilay's code:
  (define-syntax no-errors
    (syntax-rules ()
      [(_ <body>)
       (with-handlers ((void (lambda (x) #f))) <body>)]))

  (define-syntax-set (define-record declare-fields declare-predicates)

    (define (define-record/proc stx)
      (syntax-case stx ()
        [(_ <name> (<super> ...) <field> ...)
         (with-syntax ([<accessor-triple-list> (super-accessors #'(<super>
               (define-struct <name> (<field> ...))
               (declare-predicates <name> <super> ...)
               (declare-fields <name> <accessor-triple-list> <field> ...)))]
        [(_ <name> <field> ...)
         #'(define-record <name> ()  <field> ...)]))

    (define (super-accessors <supers>)
       (apply append
              (map (lambda (<super>)
                     (let ([length-super (string-length (symbol->string
(syntax-e <super>)))])
                       (let-values (((pred getters setters)
                                      (lambda ()
                                        (raise-syntax-error #f "not a
defined structure"
                         (map (lambda (getter setter)
                                      (symbol->string (syntax-e getter))]
                                     [getter-length (string-length
                                     [field (string->symbol
                                             (substring getter-string
                                                        (+ 1 length-super)
                                  (list field getter setter)))
                   (syntax->list <supers>)))))

    (define declare-predicates/proc
      (lambda (stx)
        (syntax-case stx ()
          [(_ <name>)
          [(_ <name> <super> . <supers>)
           (with-syntax ([name?  (make-predicate #'<name>)]
                         [super? (make-predicate #'<super>)]
                         [rest   #'(declare-predicates <name> . <supers>)])
                 (define super? (let ([previous super?])
                                  (lambda (x)
                                    (or (previous x)
                                        (name? x)))))

    (define declare-fields/proc
      (lambda (stx)
        (syntax-case stx ()
          [(_ <name> ()) #'(void)]
          [(_ <name> (<accessor-triple> ...))
           (begin (fprintf
                   "Warning: Not all supertype fields of ~e have been
declared: ~e~n"
                   (syntax-e #'<name>)
                   (map second (syntax-object->datum #'(<accessor-triple>
          [(_ <name> (<accessor-triple> ...) <field> . <fields>)
           (let* ([accessor-triples        (syntax-object->datum
#'(<accessor-triple> ...))]
                  [accessor-triple         (assq (syntax-e #'<field>)
                  [accessor-triples/triple (remove accessor-triple
             (if (not accessor-triple)
                 #'(declare-fields <name> (<accessor-triple> ...) .
                     ([(<accessor-triple> ...) (datum->syntax-object

                      [<remaining-fields>    (if (assq (syntax-e #'<field>)

                                                 #'(<field> . <fields>)
                      [<name>-<field>        (make-getter #'<name>
                      [set-<name>-<field>!   (make-setter #'<name>
                      [<name>?               (make-predicate #'<name>)]
                      [<super>-<field>       (datum->syntax-object #'<name>
                      [set-<super>-<field>!  (datum->syntax-object #'<name>
                       (define <super>-<field> (if (no-errors
                                                   (let ([next-method
                                                     (lambda (x)
                                                       (if (<name>? x)
                       (define set-<super>-<field>! (if (no-errors
                                                        (let ([next-method
                                                          (lambda (x y)
                                                            (if (<name>? x)

(set-<name>-<field>! x y)
x y))))

                       (declare-fields <name> (<accessor-triple> ...) .

    ; Needs at least one argument:
    (define (++ . <stx-args>)
      (let ([args (map symbol->string (map syntax-object->datum
         (car <stx-args>)
         (string->symbol (apply string-append args))
         (car <stx-args>))))

    (define (make-predicate <stx-name>)
      (++ <stx-name> #'?))

    (define (make-getter <stx-name> <stx-field>)
      (++ <stx-name>
          (if (eq? (syntax-e <stx-name>) '||) #'|| #'-)

    (define (make-setter <stx-name> <stx-field>)
      (++ #'set-
          (if (eq? (syntax-e <stx-name>) '||) #'|| #'-)

    ; Fragment copied from Bruce Hauman's match.ss library:
    (define struct-pred-accessors-mutators
      (let ((accessors-index 3)
            (mutators-index 4)
            (pred-index 2)
             (lambda (l)
               (letrec ((RC
                         (lambda (ac-list)
                           (cond ((null? ac-list) '())
                                 ((not ac-list) '())
                                 (else (cons (car ac-list)
                                             (RC (cdr ac-list))))))))
                 (reverse (RC l))))))
        (lambda (struct-name failure-thunk)
          (let* ((info-on-struct (syntax-local-value struct-name
                 (accessors (handle-acc-list
                             (list-ref info-on-struct accessors-index)))
                 (mutators (handle-acc-list
                            (list-ref info-on-struct mutators-index)))
                 (pred (list-ref info-on-struct pred-index)))
            (values pred accessors mutators)))))

    ) ;; end syntax-set
  ) ;; end module

Posted on the users mailing list.