#lang scheme
(require
 srfi/26
 "overloads.ss")

(provide
 (struct-out exn:fail:multimethod))

(define-struct multimethod
  (make-signature
   current-overloads)
  #:property prop:procedure
  (make-keyword-procedure
   (λ (kw-args kw-vals mm . args)
     (let ([overloads ((multimethod-current-overloads mm))]
           [signature (keyword-apply (multimethod-make-signature mm)
                        kw-args kw-vals args)])
       (keyword-apply (find-method overloads signature)
         kw-args kw-vals args)))))

(define (make-multimethod* make-signature
                           #:overloads [overloads (make-overloads)])
  (make-multimethod make-signature (make-parameter overloads)))

(provide/contract
 [multimethod? (any/c . -> . boolean?)]
 [multimethod-make-signature (multimethod? . -> . procedure?)]
 [multimethod-current-overloads (multimethod? . -> . (parameter/c overloads?))]
 [rename make-multimethod* make-multimethod
         ((procedure?) (#:overloads overloads?) . ->* . multimethod?)])

(define-syntax define-multimethod
  (syntax-rules (::)
    [(define-multimethod (name . args) :: signature options ...)
     (define-multimethod name :: (λ args signature)
       options ...)]
    [(define-multimethod name :: signature options ...)
     (define name
       (make-multimethod* signature options ...))]))

(define-syntax parameterize-multimethod
  (syntax-rules ()
    [(parameterize-multimethod (name ...)
       expr ...)
     (parameterize ([(multimethod-current-overloads name)
                     ((multimethod-current-overloads name))]
                    ...)
       expr ...)]))

(define-syntax define-method
  (syntax-rules (::)
    [(define-method (name . args) #:default
       expr ...)
     (define-method name #:default
       (λ args
         expr ...))]
    [(define-method name #:default method)
     (let* ([current-overloads (multimethod-current-overloads name)]
            [overloads (current-overloads)]
            [signature (overloads-default-signature overloads)])
       (current-overloads
        (cond
          [(begin method)
           => (cut set-method overloads signature <>)]
          [else
           (remove-method overloads signature)])))]
    [(define-method (name . args) :: signature
       expr ...)
     (define-method name :: `signature
       (λ args
         expr ...))]
    [(define-method name :: signature method)
     (let* ([current-overloads (multimethod-current-overloads name)]
            [overloads (current-overloads)])
       (current-overloads
        (cond
          [(begin method)
           => (cut set-method overloads signature <>)]
          [else
           (remove-method overloads signature)])))]))

(define-syntax define-preference
  (syntax-rules (:: < > =)
    [(define-preference name :: (< signature-a signature-b))
     (let ([current-overloads (multimethod-current-overloads name)])
       (current-overloads
        (prefer-method (current-overloads) `signature-a `signature-b)))]
    [(define-preference name :: (> signature-a signature-b))
     (let ([current-overloads (multimethod-current-overloads name)])
       (current-overloads
        (prefer-method (current-overloads) `signature-b `signature-a)))]
    [(define-preference name :: (= signature-a signature-b))
     (let ([current-overloads (multimethod-current-overloads name)])
       (current-overloads
        ((let ([signature-a `signature-a]
               [signature-b `signature-b])
           (compose
            (cut unprefer-method <> signature-b signature-a)
            (cut unprefer-method <> signature-a signature-b)))
         (current-overloads))))]))

(provide
 define-multimethod
 parameterize-multimethod
 define-method
 define-preference)