[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]

Syntax-case implementation



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)