(use srfi-1)
(use gauche.sequence)

(define-class <advice> ()
  ((advice-type   :init-keyword :advice-type)
   (advice-symbol   :init-keyword :advice-symbol)
   (original-symbol :init-keyword :original-symbol)
   (body :init-value #f :init-keyword :body)
   (next :init-value #f)))

(define-class <dummy-advice> (<advice>)
  ((advice-table  :init-value (make-hash-table) :allocation :class)
   (advicing-body :init-value #f :init-keyword :advicing-body)))

(define-macro (define-advice advice-symbol name specs . form)
  (let ((args (gensym))
        (new-form (cond ((eq? (car specs) 'around) form)
                        ((eq? (car specs) 'before)
                         `(,@form
                           (advice:do-it)))
                        ((eq? (car specs) 'after )
                         `((advice:do-it)
                           (let ()
                             ,@form))))))
    (advice:activate name)
    `(define ,advice-symbol
       (make <advice>
         :advice-type   ',(car specs)
         :advice-symbol   ',advice-symbol
         :original-symbol ',name
         :body
         (lambda ,args
           (let* ((advice:return-value #f)
                  (advice:do-it
                   (lambda ()
                     (set! advice:return-value
                           (apply (slot-ref
                                   (slot-ref ,advice-symbol 'next) 'body)
                                  ,args))
                     advice:return-value))
                  (advice:arg-ref  (lambda (i)   (ref ,args i)))
                  (advice:arg-set! (lambda (i v) (set! (ref ,args i) v))))
             ,@new-form))))))

(define (advice:activated? original-symbol)
  (and (advice:get-dummy original-symbol)
       (eq? (slot-ref (advice:get-dummy original-symbol) 'advicing-body)
            (eval original-symbol (current-module)))))

(define (advice:activate original-symbol)
  (unless (advice:activated? original-symbol)
    (unless (advice:get-dummy original-symbol)
      (let ((table (class-slot-ref <dummy-advice> 'advice-table))
            (dummy (make <dummy-advice>)))
        (slot-set! dummy 'original-symbol original-symbol)
        (slot-set! dummy 'next dummy) ;; ring
        (slot-set! dummy 'body (eval original-symbol (current-module)))
        (hash-table-put! table original-symbol dummy)))
    (let ((args (gensym)))
      (eval
       `(begin
          (set! ,original-symbol
                (lambda ,args
                  (apply (slot-ref
                          (slot-ref (advice:get-dummy ',original-symbol) 'next)
                          'body)
                         ,args)))
          (slot-set! (advice:get-dummy ',original-symbol)
                     'advicing-body
                     ,original-symbol))
       (current-module)))))

(define (advice:deactivate original-symbol)
  (when (advice:activated? original-symbol)
    (eval `(set! ,original-symbol
                 (slot-ref (advice:get-dummy ,original-symbol) 'body))
          (current-module))))

(define (advice:enabled? advice)
  (let loop ((a (advice:get-dummy (slot-ref advice 'original-symbol))))
    (cond ((eq? a #f) #f)
          ((eq? a advice) #t)
          ((is-a? (slot-ref a 'next) <dummy-advice>) #f)
          (else (loop (slot-ref a 'next))))))

(define (advice:get-dummy original-symbol)
  (hash-table-get
   (class-slot-ref <dummy-advice> 'advice-table) original-symbol #f))

(define (advice:enable advice . rest)
  (unless (advice:enabled? advice)
    (let* ((os (slot-ref advice 'original-symbol))
           (index (if (null? rest) 0 (car rest)))
           (inner-advice (advice:ref os index)))
      (slot-set! advice       'next (slot-ref inner-advice 'next))
      (slot-set! inner-advice 'next advice))))

(define (advice:disable advice)
  (when (advice:enabled? advice)
    (let* ((os (slot-ref advice 'original-symbol))
           (outer-advice (advice:ref os (- (advice:index advice) 1))))
      (slot-set! outer-advice 'next (slot-ref advice 'next))
      (slot-set!       advice 'next #f))))

(define (advice:ref original-symbol index)
  (let ((dummy (advice:get-dummy original-symbol)))
    (if dummy
        (let loop ((a dummy)
                   (i 0))
          (cond ((= i index) a)
                ((is-a? (slot-ref a 'next) <dummy-advice>) dummy)
                (else (loop (slot-ref a 'next)
                            (+ i 1)))))
        #f)))

(define (advice:index advice)
  (if (advice:enabled? advice)
      (let loop ((a (advice:get-dummy (slot-ref advice 'original-symbol)))
                 (i 0))
        (cond ((eq? a advice) i)
              (else (loop (slot-ref a 'next)
                          (+ i 1)))))
      #f))


;;; sample

(define (foo x)
  (print x)
  #t)

(define-advice foo-around1 foo (around)
  (print "around1 before")
  (advice:do-it)
  (print "around1 after")
  advice:return-value)

(define-advice foo-around2 foo (around)
  (print "around2 before")
  (advice:do-it)
  (print "around2 after")
  advice:return-value)

(foo "foo original")
;; => foo original
;;    #t

(advice:enable foo-around1)
(foo "foo original")
;; => around1 before
;;    foo original
;;    around1 after
;;    #t


(advice:enable foo-around2)
(foo "foo original")
;; => around2 before
;;    around1 before
;;    foo original
;;    around1 after
;;    around2 after
;;    #t

(advice:disable foo-around1)
(foo "foo original")
;; => around2 before
;;    foo original
;;    around2 after
;;    #t

(advice:disable foo-around2)
(foo "foo original")
;; => foo original
;;    #t

(define-advice foo-after1 foo (after)
  (print "after1")
  advice:return-value)

(advice:enable foo-after1)
(foo "foo original")

(define-advice foo-before1 foo (before)
  (print "before1"))

(advice:enable foo-before1)
(foo "foo original")