[plt-scheme] Polymorphic Structure Types
; 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)
Regards
Andre
; 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>
...))])
#'(begin
(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>)
(datum->syntax-object
<supers>
(apply append
(map (lambda (<super>)
(let ([length-super (string-length (symbol->string
(syntax-e <super>)))])
(let-values (((pred getters setters)
(struct-pred-accessors-mutators
<super>
(lambda ()
(raise-syntax-error #f "not a
defined structure"
<super>)))))
(map (lambda (getter setter)
(let*
([getter-string
(symbol->string (syntax-e getter))]
[getter-length (string-length
getter-string)]
[field (string->symbol
(substring getter-string
(+ 1 length-super)
getter-length))])
(list field getter setter)))
getters
setters))))
(syntax->list <supers>)))))
(define declare-predicates/proc
(lambda (stx)
(syntax-case stx ()
[(_ <name>)
#'(void)]
[(_ <name> <super> . <supers>)
(with-syntax ([name? (make-predicate #'<name>)]
[super? (make-predicate #'<super>)]
[rest #'(declare-predicates <name> . <supers>)])
#'(begin
(define super? (let ([previous super?])
(lambda (x)
(or (previous x)
(name? x)))))
rest))])))
(define declare-fields/proc
(lambda (stx)
(syntax-case stx ()
[(_ <name> ()) #'(void)]
[(_ <name> (<accessor-triple> ...))
(begin (fprintf
(current-error-port)
"Warning: Not all supertype fields of ~e have been
declared: ~e~n"
(syntax-e #'<name>)
(map second (syntax-object->datum #'(<accessor-triple>
...))))
#'(void))]
[(_ <name> (<accessor-triple> ...) <field> . <fields>)
(let* ([accessor-triples (syntax-object->datum
#'(<accessor-triple> ...))]
[accessor-triple (assq (syntax-e #'<field>)
accessor-triples)]
[accessor-triples/triple (remove accessor-triple
accessor-triples)])
(if (not accessor-triple)
#'(declare-fields <name> (<accessor-triple> ...) .
<fields>)
(with-syntax
([(<accessor-triple> ...) (datum->syntax-object
#'<name>
accessor-triples/triple)]
[<remaining-fields> (if (assq (syntax-e #'<field>)
accessor-triples/triple)
#'(<field> . <fields>)
#'<fields>)]
[<name>-<field> (make-getter #'<name>
#'<field>)]
[set-<name>-<field>! (make-setter #'<name>
#'<field>)]
[<name>? (make-predicate #'<name>)]
[<super>-<field> (datum->syntax-object #'<name>
(second
accessor-triple))]
[set-<super>-<field>! (datum->syntax-object #'<name>
(third
accessor-triple))])
#'(begin
(define <super>-<field> (if (no-errors
<super>-<field>)
(let ([next-method
<super>-<field>])
(lambda (x)
(if (<name>? x)
(<name>-<field>
x)
(next-method
x))))
<name>-<field>))
(define set-<super>-<field>! (if (no-errors
set-<super>-<field>!)
(let ([next-method
set-<super>-<field>!])
(lambda (x y)
(if (<name>? x)
(set-<name>-<field>! x y)
(next-method
x y))))
set-<name>-<field>!))
(declare-fields <name> (<accessor-triple> ...) .
<remaining-fields>)))))])))
; Needs at least one argument:
(define (++ . <stx-args>)
(let ([args (map symbol->string (map syntax-object->datum
<stx-args>))])
(datum->syntax-object
(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>) '||) #'|| #'-)
<stx-field>))
(define (make-setter <stx-name> <stx-field>)
(++ #'set-
<stx-name>
(if (eq? (syntax-e <stx-name>) '||) #'|| #'-)
<stx-field>
#'!))
; Fragment copied from Bruce Hauman's match.ss library:
(define struct-pred-accessors-mutators
(let ((accessors-index 3)
(mutators-index 4)
(pred-index 2)
(handle-acc-list
(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
failure-thunk))
(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
![[logo]](/logo.png){kind=logo}