This page is part of the web mail archives of SRFI 57 from before July 7th, 2015. The new archives for SRFI 57 contain all messages, not just those from before July 7th, 2015.
Below is a syntax-case implementation (MzScheme version) for comment.
Apologies for the long text.
Andre
;===========================================================================================
; Syntax-Case (MzScheme version) Implementation:
;
; Andre van Tonder, 2005.
;
;============================================================================================
(module registry mzscheme
(provide register
make-entry
lookup-entry
lookup-scheme?
lookup-getter
lookup-setter
lookup-labels
lookup-supers
lookup-copier
lookup-predicate)
(require (prefix s1: (lib "1.ss" "srfi")))
(define reg '())
(define (make-entry name
is-scheme?
predicate
supers
labels
pos-labels
fields
copier)
(vector name
is-scheme?
predicate
supers
labels
pos-labels
fields
copier))
(define (entry.name entry) (vector-ref entry 0))
(define (entry.is-scheme? entry) (vector-ref entry 1))
(define (entry.predicate entry) (vector-ref entry 2))
(define (entry.supers entry) (vector-ref entry 3))
(define (entry.labels entry) (vector-ref entry 4))
(define (entry.pos-labels entry) (vector-ref entry 5))
(define (entry.fields entry) (vector-ref entry 6))
(define (entry.copier entry) (vector-ref entry 7))
(define (register name entry)
(cond ((s1:assoc name reg free-identifier=?)
=> (lambda (pair)
(set-cdr! pair entry)))
(else
(set! reg (cons (cons name entry)
reg)))))
(define (lookup-entry name)
(s1:assoc name reg free-identifier=?))
(define (lookup-getter name label)
(cond ((s1:assoc label
(entry.fields (cdr (lookup-entry name)))
free-identifier=?)
=> cadr)
(else #f)))
(define (lookup-setter name label)
(cond ((s1:assoc label
(entry.fields (cdr (lookup-entry name)))
free-identifier=?)
=> caddr)
(else #f)))
(define (lookup-scheme? name) (entry.is-scheme? (cdr (lookup-entry name))))
(define (lookup-labels name) (entry.labels (cdr (lookup-entry name))))
(define (lookup-supers name) (entry.supers (cdr (lookup-entry name))))
(define (lookup-copier name) (entry.copier (cdr (lookup-entry name))))
(define (lookup-predicate name) (entry.predicate (cdr (lookup-entry name))))
) ; registry
(module records mzscheme
(provide define-record-type
define-record-scheme
record-update
record-update!
record-compose
show)
(require (prefix s9: (lib "9.ss" "srfi")))
(require-for-syntax (prefix s1: (lib "1.ss" "srfi")))
(require-for-syntax registry)
(define-syntax define-record-type
(syntax-rules ()
((define-record-type . body)
(parse-declaration #f . body))))
(define-syntax define-record-scheme
(syntax-rules ()
((define-record-scheme . body)
(parse-declaration #t . body))))
(define-syntax parse-declaration
(syntax-rules ()
((parse-declaration is-scheme? (name super ...) (constructor pos-label ...) predicate field-clause ...)
(build-record (constructor pos-label ...) #f (super ...) (field-clause ...) name predicate is-scheme?))
((parse-declaration is-scheme? (name super ...) constructor predicate field-clause ...)
(build-record (constructor) #t (super ...) (field-clause ...) name predicate is-scheme?))
((parse-declaration is-scheme? (name super ...) constructor-clause)
(parse-declaration is-scheme? (name super ...) constructor-clause #f))
((parse-declaration is-scheme? (name super ...))
(parse-declaration is-scheme? (name super ...) #f #f))
((parse-declaration is-scheme? name . rest)
(parse-declaration is-scheme? (name) . rest))))
(define-syntax record-update!
(lambda (stx)
(syntax-case stx ()
((_ record name (label exp) ...)
(with-syntax (((setter ...)
(map (lambda (label)
(lookup-setter #`name label))
(syntax->list #`(label ...)))))
#`(let ((r record))
(setter r exp)
...
r))))))
(define-syntax record-update
(lambda (stx)
(syntax-case stx ()
((_ record name (label exp) ...)
(if (lookup-scheme? #`name)
(with-syntax ((copier (lookup-copier #`name)))
#`(let ((new (copier record)))
(record-update! new name (label exp) ...)))
#`(record-compose (name record) (name (label exp) ...)))))))
(define-syntax record-compose
(lambda (stx)
(syntax-case stx ()
((record-compose (export-name (label exp) ...))
#`(export-name (label exp) ...))
((record-compose (import-name record) import ... (export-name (label exp) ...))
(with-syntax
(((copy-label ...)
(s1:lset-intersection free-identifier=?
(lookup-labels #`export-name)
(s1:lset-difference free-identifier=?
(lookup-labels #`import-name)
(syntax->list #`(label ...))))))
(with-syntax (((getter ...)
(s1:map (lambda (label)
(lookup-getter #`import-name label))
(syntax->list #`(copy-label ...)))))
#`(let ((r record))
(record-compose import ...
(export-name (copy-label (getter r))
...
(label exp)
...)))))))))
(define-syntax build-record
(let ()
(define (build-record stx)
(syntax-case stx ()
((build-record (constructor pos-label ...)
default-order?
(super ...)
((field-label . accessors) ...)
name
predicate
is-scheme?)
(with-syntax
(((label ...)
(s1:delete-duplicates (s1:fold-right append
(syntax->list #`(pos-label ... field-label ...))
(map lookup-labels
(syntax->list #`(super ...))))
free-identifier=?))
((super ...)
(s1:delete-duplicates (s1:fold-right append
'()
(map lookup-supers
(syntax->list #`(super ...))))
free-identifier=?)))
(with-syntax
(((pos-label ...)
(if (syntax-e #`default-order?)
#`(label ...)
#`(pos-label ...)))
(((field-label getter setter) ...)
(append (map augment-field
(syntax->list #`((field-label . accessors) ...)))
(map (lambda (label)
(maybe-generate #`name `(,label getter setter)))
(s1:lset-difference free-identifier=?
(syntax->list #`(label ...))
(syntax->list #`(field-label ...)))))))
(with-syntax ((supers #`(super ...))
((pos-temp ...) (generate-temporaries #`(pos-label ...)))
((constructor predicate maker copier)
(maybe-generate #`name `(,#`constructor ,#`predicate maker copier))))
(begin
(register #`name (make-entry #`name
(syntax-e #`is-scheme?)
#`predicate
(syntax->list #`(super ... name))
(syntax->list #`(label ...))
(syntax->list #`(pos-label ...))
(map syntax->list
(syntax->list #`((field-label getter setter) ...)))
#`copier))
(if (syntax-e #`is-scheme?)
#`(begin
(define-generic (predicate x) (lambda (x) #f))
(define-generic (getter x))
...
(define-generic (setter x v))
...
(define-generic (copier x)))
#`(begin
(s9:define-record-type internal-name
(maker field-label ...)
predicate
(field-label getter setter) ...)
(define constructor
(lambda (pos-temp ...)
(populate maker (field-label ...) (pos-label pos-temp) ...)))
(extend-predicates supers predicate)
(extend-accessors supers field-label predicate getter setter)
...
(define (copier x)
(maker (getter x) ...))
(extend-copiers supers copier predicate)
(define-method (show (r predicate))
(list 'name
(list 'field-label (getter r))
...))
(define-syntax name
(syntax-rules ()
((name . bindings) (populate maker (field-label ...) . bindings))))
))))))))) ; build-record
(define (maybe-generate context maybe-identifiers)
(map (lambda (elem)
(if (identifier? elem)
elem
(datum->syntax-object context (if (symbol? elem)
(gensym elem)
(gensym)))))
maybe-identifiers))
(define (augment-field clause)
(syntax-case clause ()
((label) `(,#`label ,@(maybe-generate #`label `( getter setter))))
((label getter) `(,#`label ,@(maybe-generate #`label `(,#`getter setter))))
((label getter setter) `(,#`label ,@(maybe-generate #`label `(,#`getter ,#`setter))))))
build-record))
(define-syntax extend-predicates
(lambda (stx)
(syntax-case stx ()
((extend-predicates (super ...) new-type)
(with-syntax (((predicate ...) (map lookup-predicate
(syntax->list #`(super ...)))))
#`(begin
(define-method predicate (new-type) (x) any?)
...))))))
(define-syntax extend-copiers
(lambda (stx)
(syntax-case stx ()
((extend-copiers (super ...) copy new-type)
(with-syntax (((copier ...) (map lookup-copier
(syntax->list #`(super ...)))))
#`(begin
(define-method copier (new-type) (x) copy)
...))))))
(define-syntax extend-accessors
(lambda (stx)
(syntax-case stx ()
((extend-accessors (super ...) label new-type selector modifier)
(with-syntax (((getter ...) (s1:filter (lambda (id)
(not (eqv? id #f)))
(map (lambda (super)
(lookup-getter super #`label))
(syntax->list #`(super ...)))))
((setter ...) (s1:filter (lambda (id)
(not (eqv? id #f)))
(map (lambda (super)
(lookup-setter super #`label))
(syntax->list #`(super ...))))))
#`(begin
(define-method getter (new-type) (x) selector)
...
(define-method setter (new-type any?) (x v) modifier)
...))))))
(define-syntax populate
(lambda (stx)
(define (order ordering bindings default)
(if (null? (s1:lset-difference free-identifier=?
(map car bindings)
ordering))
(map (lambda (label)
(cond ((s1:assoc label bindings free-identifier=?) => (lambda (x) x))
(else `(,label ,default))))
ordering)
(raise-syntax-error #f "Illegal labels in" stx)))
(syntax-case stx ()
((populate maker labels . bindings)
(with-syntax ((((label exp) ...) (order (syntax->list #`labels)
(map syntax->list
(syntax->list #'bindings))
#`'<undefined>)))
#`(maker exp ...))))))
; Simple generic functions suitable for our disjoint base record types:
(define-syntax define-generic
(syntax-rules ()
((define-generic (name arg ...))
(define-generic (name arg ...)
(lambda (arg ...) (error "Inapplicable method:" 'name
"Arguments:" (show arg) ... ))))
((define-generic (name arg ...) proc)
(define name (make-generic (arg ...) proc)))))
(define-syntax define-method
(syntax-rules ()
((define-method (generic (arg pred?) ...) . body)
(define-method generic (pred? ...) (arg ...) (lambda (arg ...) . body)))
((define-method generic (pred? ...) (arg ...) procedure)
(let ((next ((generic) 'get-proc))
(proc procedure))
(((generic) 'set-proc)
(lambda (arg ...)
(if (and (pred? arg) ...)
(proc arg ...)
(next arg ...))))))))
(define-syntax make-generic
(syntax-rules ()
((make-generic (arg arg+ ...) default-proc)
(let ((proc default-proc))
(case-lambda
((arg arg+ ...)
(proc arg arg+ ...))
(()
(lambda (msg)
(case msg
((get-proc) proc)
((set-proc) (lambda (new)
(set! proc new)))))))))))
(define-generic (show x)
(lambda (x) x))
(define (any? x) #t)
) ; records
;============================================================================================
; Examples:
(require records)
; A simple record declaration:
(define-record-type point (make-point x y) point?
(x point.x point.x-set!)
(y point.y point.y-set!))
(define p (make-point 1 2))
(point? p) ;==> #t
(point.y p) ;==> 2
(point.y-set! p 7)
(point.y p) ;==> 7
; Simple record schemes.
; Record schemes don't have constructors.
; The predicates and accessors are polymorphic.
(define-record-scheme <point #f <point?
(x <point.x)
(y <point.y))
(define-record-scheme <color #f <color?
(hue <color.hue))
; Concrete instances of the above schemes.
; Constructors may be declared.
; Predicates and accessors, when provided, are monomorphic.
(define-record-type (point <point) make-point point?
(x point.x)
(y point.y))
(define-record-type (color <color) make-color)
(define-record-type (color-point <color <point) (make-color-point x y hue) color-point?
(extra color-point.extra))
(define cp (make-color-point 1 2 'blue))
(<point? cp) ;==> #t
(<color? cp) ;==> #t
(color-point? cp) ;==> #t
;(point.x cp) ;==> error
(<point.y cp) ;==> 2
(<color.hue cp) ;==> blue
(color-point.extra cp) ;==> <undefined>
; Constructing records by field labels:
(define p (point (x 1)
(y 2)))
(define cp (color-point (hue 'blue)
(x 1)
(y 2)))
; Monomorphic functional update:
(show
(record-update p point (x 7))) ;==> (point (x 7) (y 2))
(show p) ;==> (point (x 1) (y 2)) - original unaffected
; Polymorphic functional update:
(show
(record-update cp <point (x 7))) ;==> (color-point (extra <undefined>) (hue blue) (x 7) (y 2))
(show cp) ;==> (color-point (extra <undefined>) (hue blue) (x 1) (y 2))
; In-place update:
(show
(record-update! cp <point (x 7))) ;==> color-point (extra <undefined>) (hue blue) (x 7) (y 2))
(show cp) ;==> color-point (extra <undefined>) (hue blue) (x 7) (y 2))
; Use record-compose for updates polymorphic in argument but monomorphic in result type:
(show
(record-compose (<point cp) (point (x 8)))) ;==> (point (x 8) (y 2))
(show cp) ;==> (color-point (extra <undefined>) (hue blue) (x 7) (y 2))
; More general record composition example:
(define cp (make-color-point 1 2 'green))
(define c (make-color 'blue))
(show
(record-compose (<point cp) ; polymorphic import - only fields x and y of cp taken
(color c) ; monomorphic import
(color-point (x 8) ; override imported field
(extra 'hi))))
;==> (color-point (extra hi) (hue blue) (x 8) (y 2))
; Small module-functor example:
(define-record-type monoid #f #f
(mult monoid.mult)
(one monoid.one))
(define-record-type abelian-group #f #f
(add group.add)
(zero group.zero)
(sub group.sub))
(define-record-type ring #f #f
(mult ring.mult)
(one ring.one)
(add ring.add)
(zero ring.zero)
(sub ring.sub))
(define integer-monoid (monoid (mult *)
(one 1)))
(define integer-group (abelian-group (add +)
(zero 0)
(sub -)))
(define (make-ring g m) ; simple "functor"
(record-compose (monoid m)
(abelian-group g)
(ring)))
(define integer-ring (make-ring integer-group
integer-monoid))
((ring.add integer-ring) 1 2) ;==> 3
; Example of tree data type
(define-record-scheme <tree #f <tree?)
(define-record-type (node <tree) make-node node?
(lhs node.lhs)
(rhs node.rhs))
(define-record-type (leaf <tree) make-leaf leaf?
(val leaf.val))
(define (tree->list t)
(cond
((leaf? t) (leaf.val t))
((node? t) (cons (tree->list (node.lhs t))
(tree->list (node.rhs t))))))
(define t
(make-node (make-node (make-leaf 1)
(make-leaf 2))
(make-leaf 3)))
(<tree? t) ;==> #t
(tree->list t) ;==> ((1 . 2) . 3)