multi.rkt

#lang racket/base

(require ; compatibility/defmacro
         racket/stxparam
         (for-syntax racket/base
                     racket/syntax
                     data/gvector))

(provide define-multi
         multi
         )

(define-syntax-parameter current-define-multis (make-hash))
(define-syntax-parameter current-define-args (make-hash))

#| (define-macro (define-multi . rest) |#
#|   (let ([define-multis (syntax-parameter-value #'current-define-multis)] |#
#|         [name (caar rest)]) |#
#|     (when (not (hash-has-key? define-multis name)) |#
#|       (hash-set! define-multis name (make-gvector))) |#
#|     (let ([args-name (cdar rest)] |#
#|           [pred-and-body (cdr rest)] |#
#|           [define-multi (hash-ref define-multis name)] |#
#|           [define-args (syntax-parameter-value #'current-define-args)]) |#
#|       (when (and (hash-has-key? define-args name) |#
#|                  (not (equal? (hash-ref define-args name) |#
#|                               args-name))) |#
#|         (raise (exn:fail:contract "args must be same for all define-multis with same name" |#
#|                                   (current-continuation-marks)))) |#
#|       (gvector-add! define-multi pred-and-body) |#
#|       (hash-set! define-args name args-name)))) |#

(define-syntax (define-multi stx)
  (syntax-case stx ()
    [(_ rest ...)
     (with-syntax ([define-multis (syntax-parameter-value #'current-define-multis)]
                   [name (caar (syntax->datum #'(rest ...)))])
       (when (not (hash-has-key? (syntax-e #'define-multis) (syntax->datum #'name)))
         (hash-set! (syntax-e #'define-multis) (syntax->datum #'name) (make-gvector)))
       (with-syntax ([args-name (cdar (syntax->datum #'(rest ...)))]
                     [pred-and-body (cdr (syntax->datum #'(rest ...)))]
                     [define-multi (hash-ref (syntax-e #'define-multis) (syntax->datum #'name))]
                     [define-args (syntax-parameter-value #'current-define-args)])
         (when (and (hash-has-key? (syntax-e #'define-args) (syntax->datum #'name))
                    (not (equal? (hash-ref (syntax-e #'define-args) (syntax->datum #'name))
                                 (syntax->datum #'args-name))))
           (raise (exn:fail:contract "args must be same for all define-multis with same name"
                                     (current-continuation-marks))))
         (gvector-add! (syntax-e #'define-multi) (syntax->datum #'pred-and-body))
         (hash-set! (syntax-e #'define-args) (syntax->datum #'name) (syntax->datum #'args-name))
         #'(void)))]))

#| (define-macro (multi name . args) |#
#|   (when (not (hash-has-key? (syntax-parameter-value #'current-define-args) name)) |#
#|     (raise (exn:fail:contract "corresponding define-multi not defined" |#
#|                               (current-continuation-marks)))) |#
#|   (let* ([define-multi (hash-ref (syntax-parameter-value #'current-define-multis) name)] |#
#|          [args-name (hash-ref (syntax-parameter-value #'current-define-args) name)] |#
#|          [conds (gvector->list define-multi)]) |#
#|     (when (not (equal? (length args-name) (length args))) |#
#|       (raise (exn:fail:contract "number of arguments do not match" |#
#|                                 (current-continuation-marks)))) |#
#|     `(let-values ([,args-name (values ,@args)]) |#
#|        (cond |#
#|          ,@conds |#
#|          [else |#
#|           (raise (exn:fail:contract "no define-multi matched the given args" |#
#|                                     (current-continuation-marks)))])))) |#

(define-syntax (multi stx)
  (syntax-case stx ()
    [(_ name args ...)
     (with-syntax ([define-args (syntax-parameter-value #'current-define-args)])
       (when (not (hash-has-key? (syntax-e #'define-args) (syntax->datum #'name)))
         (raise (exn:fail:contract "corresponding define-multi not defined"
                                   (current-continuation-marks))))
       (with-syntax* ([define-multis (syntax-parameter-value #'current-define-multis)]
                      [define-multi (hash-ref (syntax-e #'define-multis) (syntax->datum #'name))]
                      [args-name (hash-ref (syntax-e #'define-args) (syntax->datum #'name))]
                      [conds (gvector->list (syntax-e #'define-multi))])
         (when (not (equal? (length (syntax-e #'args-name))
                            (length (syntax-e #'(args ...)))))
           (raise (exn:fail:contract "number of arguments do not match"
                                     (current-continuation-marks))))
         #`(let-values ([#,(syntax-e #'args-name) (values #,@(syntax-e #'(args ...)))])
             (cond
               #,@(syntax-e #'conds)
               [else
                (raise (exn:fail:contract "no define-multi matched the given args"
                                          (current-continuation-marks)))]))))]))

(module* main #f
  (define-multi (foo $)
    (equal? $ 'bar)
    'bar)
  (define-multi (foo $)
    (equal? $ 'baz)
    'baz)
  (multi foo 'bar)
  ;=> 'bar
  (multi foo 'baz)
  ;=> 'baz
  (with-handlers ([exn:fail:contract?
                   (λ (e) (displayln e))])
    (multi foo 'quux))
  ;=> exn:fail:contract: no define-multi matched the given args
)