Typeclass Macros

The following are syntax-case versions of the macros defined in the comp.lang.scheme article Typeclass envy, by Andre van Tonder.

The unadorned source code to these modules can be found in typeclass.scm and macrosupport.scm.

The code is written for PLT Scheme, but it should be possible to make them work on other Schemes which support syntax-case.

; macrosupport.scm

(module macrosupport mzscheme
  (define make-prefixed-id
    (lambda (scope prefix sym)
      (datum->syntax-object
       scope
       (string->symbol
        (string-append prefix (symbol->string sym))))))

  (provide make-prefixed-id))
; typeclass.scm

(module typeclass mzscheme

  (provide define-class with import lambda=> define=>)

  (require (lib "list.ss" "mzlib"))
  (require-for-syntax (lib "list.ss" "mzlib") ; for filter
                      "macrosupport.scm")

(define-syntax define-class
  (lambda (stx)
    (syntax-case stx ()
      ((_ name field ...)
       (with-syntax
           ([ctor (make-prefixed-id (syntax name) "make-"
                                    (syntax-object->datum (syntax name)))]
            [(formal ...) (generate-temporaries (syntax (field ...)))])
         (syntax
          (begin
            (define ctor
              (lambda (formal ...)
                (lambda (k) (k formal ...))))
            (define-syntax name
              (let ([fields (syntax-object->datum (syntax (field ...)))])
                (lambda (x)
                  (syntax-case x ()
                    ((_ scope k prefix-str-stx instance arg (... ...))
                     (let ([prefix-str (syntax-object->datum (syntax prefix-str-stx))])
                       (with-syntax
                           ([labels (map (lambda (stx)
                                           (make-prefixed-id (syntax scope)
                                                             prefix-str
                                                             (syntax-object->datum
                                                              (syntax-case stx ()
                                                                ((super label) (syntax label))
                                                                (label (syntax label))))))
                                         (syntax-e (syntax (field ...))))]
                            [supers (map (lambda (class-label)
                                           (with-syntax
                                               ([class (datum->syntax-object (syntax scope) (car class-label))]
                                                [label (make-prefixed-id (syntax scope) prefix-str (cadr class-label))]
                                                [prefix-sym (string->symbol prefix-str)])
                                             (syntax (class label prefix-sym))))
                                         (filter pair? fields))])
                         (syntax (k "descriptor" scope instance labels supers arg (... ...)))))))))))))))))

(define-syntax with
  (lambda (stx)
    (syntax-case stx ()
      ((k (instance-form ...) exp ...)
       (syntax (with/scope k (instance-form ...) exp ...))))))

(define-syntax with/scope
  (lambda (stx)
    (syntax-case stx ()
      ((_ scope () exp ...)
       (syntax (begin exp ...)))
      ((_ scope ((name instance) rest ...) exp ...)
       (syntax (name scope with/scope "" instance (rest ...) exp ...)))
      ((_ scope ((name instance prefix) rest ...) exp ...)
       (with-syntax ([prefix-str (symbol->string (syntax-object->datum (syntax prefix)))])
         (syntax (name scope with/scope prefix-str instance (rest ...) exp ...))))
      ((_ "descriptor" scope instance pre-labels super-bindings rest ...)
       (syntax
        (instance
         (lambda pre-labels
           (with/scope scope super-bindings
                       (with/scope scope rest ...)))))))))

(define-syntax import
  (lambda (stx)
    (syntax-case stx ()
      ((k (name instance ...) rest ...)
       (syntax (import/scope k (name instance ...) rest ...))))))

(define-syntax import/scope
  (lambda (stx)
    (syntax-case stx ()
      ((_ scope)
       (syntax "Bindings imported"))
      ((_ scope (name instance) rest ...)
       (syntax (name scope import/scope "" instance (rest ...))))
      ((_ scope (name instance prefix) rest ...)
       (with-syntax ((prefix-str (symbol->string (syntax-object->datum (syntax prefix)))))
         (syntax (name scope import/scope prefix-str instance (rest ...)))))
      ((_ "descriptor" scope instance (pre-label ...) (super-binding ...) (rest ...))
       (with-syntax ([(temp ...) (generate-temporaries (syntax (pre-label ...)))])
         (syntax
          (begin
            (define pre-label #f) ...
            (instance (lambda (temp ...)
                        (set! pre-label temp) ...))
            (import/scope scope super-binding ...)
            (import/scope scope rest ...))))))))

(define-syntax lambda=>
  (lambda (stx)
    (syntax-case stx ()
      ((k (class-form ...) body ...)
       (syntax (lambda=> k (class-form ...) body ...)))
      ((_ scope quals body ...)
       (let ([quals-binds (map (lambda (qual tmp)
                                 (with-syntax ((tmp tmp))
                                   (syntax-e
                                    (syntax-case qual ()
                                      ((cls prefix) (syntax (cls tmp prefix)))
                                      (cls          (syntax (cls tmp)))))))
                               (syntax-e (syntax quals))
                               (generate-temporaries (syntax quals)))])
         (with-syntax
             ([formals (map cadr quals-binds)]
              [quals-binds-stx quals-binds])
           (syntax
            (lambda formals
              (with/scope scope quals-binds-stx
                          body ...)))))))))

(define-syntax define=>
  (lambda (stx)
    (syntax-case stx ()
      ((k (name quals ...) body ...)
       (syntax (define name (lambda=> k (quals ...) body ...)))))))
)