Racket Multimethods, v1

multi.rkt

#lang racket

(require compatibility/defmacro
         racket/stxparam)

(define-syntax-parameter current-define-multis (make-hash))
(define-syntax-parameter current-define-multi-fns (make-hash))

(define-macro (define-multi name)
  (let ([current-define-multis (syntax-parameter-value #'current-define-multis)]
        [current-define-multi-fns (syntax-parameter-value #'current-define-multi-fns)])
    (hash-set! current-define-multis name (make-hash))
    (let* ([current-define-multi (hash-ref current-define-multis name)])
      (hash-set! current-define-multi-fns
                 name
                 `(λ args
                    (cond
                      ; TODO: Raise here
                      [else
                       #f]))))))

; TODO: Mutable list instead of mutable hash
(define-macro (define-instance name arg-name pred . body)
  (let* ([current-define-multis (syntax-parameter-value #'current-define-multis)]
         [current-define-multi-fns (syntax-parameter-value #'current-define-multi-fns)]
         [current-define-multi (hash-ref current-define-multis name)])
    (hash-set! current-define-multi pred body)
    (let ([conds (map (λ (cnd)
                        (append (list (car cnd))
                                (cdr cnd)))
                      (hash->list current-define-multi))])
      (hash-set! current-define-multi-fns
                 name
                 `(λ ,arg-name
                    ,(append '(cond) conds '([else #f])))))))

(define-macro (multi-call name . args)
  (let* ([current-define-multi-fns (syntax-parameter-value #'current-define-multi-fns)]
         [current-define-multi-fn (hash-ref current-define-multi-fns name)])
    (append (list current-define-multi-fn) args)))

; Example
(define-multi foo)
(define-instance foo $    ; $ is a user-definable variable containing the args
  (equal? (first $) 'bar) ; predicate
  #t)                     ; body
(define-instance foo $
  (equal? (first $) 'baz)
  'yes)
(multi-call foo 'bar)
(multi-call foo 'baz)
(multi-call foo 'quux)