#lang scheme
(require
 scheme/stxparam
 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)
     (local [(define overloads
               ((multimethod-current-overloads mm)))
             (define signature
               (keyword-apply (multimethod-make-signature mm)
                 kw-args kw-vals args))
             (define methods
               (find-methods overloads signature))
             (define ((make-method-call methods))
               (if (null? methods)
                   (raise (make-exn:fail:multimethod
                           (format
                            "multimethod: no unique next method for signature ~e"
                            signature)
                           (current-continuation-marks)
                           overloads signature))
                   (keyword-apply (car methods)
                     kw-args kw-vals (make-method-call (cdr methods)) args)))]
       ((make-method-call methods))))))

(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-parameter call-next-method
  (λ (stx)
    (raise-syntax-error #f "used out of method context" stx)))

(define-syntax define-method
  (syntax-rules (::)
    [(define-method (name . args) #:default
       expr ...)
     (define-method name #:default
       (λ (local-next-method . args)
         (syntax-parameterize ([call-next-method (make-rename-transformer
                                                  #'local-next-method)])
           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
       (λ (local-next-method . args)
         (syntax-parameterize ([call-next-method (make-rename-transformer
                                                  #'local-next-method)])
           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
 call-next-method
 define-method
 define-preference)