;; TODO put in module system
;; gauche.aspect (basic aspect functionality)
;; gauche.aspect.logger (useful sample usages)

(define (symbol-value . args)
  (let-optionals* args (name (module (current-module)))
      (eval name module)))

;; non-working translation of the .jl version of generic aspect wrapper
(define (aspect-wrap/jl fn pre post)
  (let1 fn-closure (symbol-value fn)
    (print (symbol-value fn))
    (set! fn                            ; XXX does not modify global fn...
          (lambda args
            (print "enter aspect")
            (apply pre fn args)
            (let1 result (apply fn-closure args)
              (apply post fn args result)
              (print "leave aspect")
              result)))
    (print (symbol-value fn))))

;; non-working macro experiment
(define-macro (aspect-wrap/m fn pre post)
  `(define ,fn
     (lambda args
       (apply ,pre ,fn args)
       (let1 result (apply ,(eval fn (current-module)) args)
         (apply ,post ,fn args result)
         result))))

;; -----------------------------------------------------------------
;; working version: just return a new function from aspect-wrap and
;; assign it at toplevel
(define (aspect-wrap fn pre post)
  (let1 fn-closure (symbol-value fn)
    (lambda args
      (apply pre fn args)
      (let1 result (apply fn-closure args)
        ;; FIXME result and args are reversed: otherwise we pass an
        ;; improper list?
        (apply post fn result args)
        result))))

(define (aspect-wrap fn pre post)
  ;; works fine as well, but prints #<closure ...> instead of a name
  (lambda args
    (apply pre fn args)
    (let1 result (apply fn args)
      (apply post fn result args)
      result)))

(define-macro (aspect-wrap fn pre post)
  `(define ,fn
     (lambda args
       (apply ,pre ',fn args)
       (let1 result (apply ,fn args)
         (apply ,post ',fn result args)
         result))))

;; NOTE using this as a base it should be possible to implement
;; join-points -> rewrite to a macro that looks for join-point
;; declarations in fn, and organises calls into the aspect at the join
;; points.

;; define an aspect, e.g. a logger
(define logger-indent 0)
(define (logger-indent-string)
  (with-output-to-string
    (lambda ()
      (dotimes (i logger-indent)
        (display "| ")))))

(define (logger-enter fn args)
  (format #t "~a(~s ~s)\n" (logger-indent-string) fn args)
  (inc! logger-indent))

(define (logger-exit fn result args)
  (dec! logger-indent)
  (format #t "~a(~s ~s) => ~s\n" (logger-indent-string) fn args result))

;; (define (logger-wrap . fns)
;;   (dolist (fn fns)
;;     (aspect-wrap fn logger-enter logger-exit)))
(define-macro (logger-wrap fn)
  `(define ',fn (aspect-wrap ',fn logger-enter logger-exit)))

(define-syntax logger-wrap
  (syntax-rules ()
    ((_ fn) (aspect-wrap 'fn logger-enter logger-exit))))

(define-macro (foo fn)
  `(format #t "~s ~s ~s ~s\n" ',fn ,fn logger-enter logger-exit))

(define (fibonacci n)
  (cond
   ((< n 3) 1)
   (else (+ (fibonacci (- n 1))
            (fibonacci (- n 2))))))

;; (macroexpand '(logger-wrap fibonacci))
;;(logger-wrap 'fibonacci)
(define fibonacci (aspect-wrap 'fibonacci logger-enter logger-exit))
;;(aspect-wrap fibonacci logger-enter logger-exit)
(fibonacci 5)

;; timer aspect
(use gauche.time)
(define (make-timer-aspect)
  (let1 timer (make <real-time-counter>)
    (define (start)
      (time-counter-start! timer))
    (define (stop)
      (time-counter-stop! timer)
      (let1 result (time-counter-value timer)
        (time-counter-reset! timer)
        result))
    (lambda args
      (case (car args)
        ((start) start)
        ((stop) stop)))))

(define (factorial-1 n)
  (cond ((= n 1) 1)
        (else (* n (factorial-1 (- n 1))))))

(define (factorial-2 n)
  (let loop ((n n) (acc 1))
    (cond
     ((< n 2) acc)
     (else (loop (- n 1) (* n acc))))))

(define timed-factorial-1
  (let1 timer (make-timer-aspect)
    (aspect-wrap 'factorial-1 (timer 'start) (timer 'stop))))

;; -----------------------------------------------------------------
;; alternative gauche solution (a la ruby): use the class system
;; modify the generic method call mechanism (subclass <generic>) so
;; that it checks for pre-aspects first, then calls the original
;; method, and finally calls post-aspects.

;; lookup in table:
;; ((pre (fn-name aspect ...) ...) (post (fn-name aspect ...) ...))

(define-class <aspect-generic> (<generic>) ())

(define-method object-apply ((self <aspect-generic>) args)
  (print "enter aspect")
  (next-method)
  (print "leave aspect"))