(require 'stdlib)

;; generic aspect wrapper
(define (aspect-wrap fn pre post)
  (let ((fn-closure (symbol-value fn)))
    (set fn (lambda args
              (funcall pre fn args)
              (let ((result (apply fn-closure args)))
                (funcall post fn args result)
                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
;; TODO rewrite to closure+dispatch form
(define (logger-enter fn args)
  (printf "logger-enter %s %s\n" fn args))

(define (logger-exit fn args result)
  (printf "logger-exit %s %s => %s\n" fn args result))

(define (logger-wrap #!rest fns)
  (dolist (fn fns)
    (aspect-wrap fn logger-enter logger-exit)))

;; wrap a function with the aspect
(define (square x)
  (* x x))

(logger-wrap 'square)

;;(printf "result: %s\n" (square 7))
;; => "logger-enter square"
;; => "logger-exit square"
;; => 49

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

(logger-wrap 'fibonacci)
;(puts (fibonacci 5))

;; -----------------------------------------------------------------
;; defclass, defaspect macro experiment
;; TODO see ocl.jl for invariant, pre-condition, post-condition syntax
(defmacro defclass (#!rest args)
  (let ((class-name (first args))
        (forms (rest args))
        attribs methods)
    (define (method-body name)
      (rest (assoc name (map cdr forms))))
    (define (attribute-initialiser name)
      (rest (assoc name (map cdr forms))))
    ;; collect def{attrib,method} names
    (dolist (form forms)
      (case (car form)
            ((defattrib)
             (push (second form) attribs))
            ((defmethod)
             (push (second form) methods))
            (t (puts "unknown item"))))
    ;; generate form
    `(define (,class-name)              ; XXX make- ,class-name ?
       ;; attribute closure
       (let (,@(map (lambda (a)
                      (list a (first (attribute-initialiser a))))
                    attribs))
         ;; method definitions
         ,@(map (lambda (m)
                  `(define (,@m) ,@(method-body m)))
                methods)
         ;; dispatcher
         (lambda args
           (apply
            (case (car args)
                  ,@(map (lambda (m) `((,(car m)) ,(car m))) methods)
                  ,@(map (lambda (a) `((,a) (lambda () ,a))) attribs)
                  ((type) (lambda () ',class-name))
                  ((interface) (lambda () (list ',attribs ',methods)))
                  (t (error "%s: unknown method `%s'"
                            ',class-name (car args))))
            (cdr args)))))))

;; e.g.
(defclass counter
  ;; (defattrib name #!optional init mode), mode: 'read 'write 'r/w 'none
  (defattrib count 0)

  ;; (defmethod name #!rest body)
  (defmethod (increment)
    (setq count (1+ count)))

  (defmethod (decrement)
    (setq count (1- count))))

(define c (counter))
(puts (c 'count))
(c 'increment)
(c 'increment)
(c 'decrement)
(puts (c 'count))

;; methods with parameters
(defclass stack
  (defattrib the-stack ())
  (defmethod (push item)
    (setq the-stack (cons item the-stack)))
  (defmethod (pop)
    (let ((head (first the-stack)))
      (setq the-stack (rest the-stack))
      head))
  (defmethod (to-list)
    the-stack))

(let ((s (stack)))
  (puts (s 'type))
  (puts (s 'interface))
  (s 'push 'aap)
  (s 'push 'noot)
  (puts (s 'to-list))
  (puts (s 'pop))
  (puts (s 'pop)))

;; -----------------------------------------------------------------
;; especially non-working macro approach
;; (defmacro wrap-before (fn #!rest body)
;;   `(,@body
;;     (funcall ,fn)))

;; (defmacro wrap-before (fn #!rest body)
;;   `(define (,fn)
;;      ,@body
;;      (funcall (closure-function ,fn))))

;; ;; fn w/o arg
;; (define (print-foo)
;;   (puts "foo"))

;; (wrap-before print-foo (puts "before"))

;; how a fn with 1 arg should look after wrapping with before and
;; after aspects. Note that both aspects are in the same lexical
;; context as the fn itself, and thus will be able to modify it.
;; (define (print-square x)
;;   (let (environment)
;;     (before)
;;     (printf "%s^2 = %s\n" x (* x x))
;;     (after)))

;; (wrap-before print-square
;;              (puts "wrap-before"))

;; -----------------------------------------------------------------
;; another try
;; (defmacro wrap (fn before after)
;;   `(define (,fn) (progn ,before ,fn ,after)))

;; (define (f)
;;   (puts "in f"))

;; (f)
;; (wrap f (lambda () (puts "before")) (lambda () (puts "after")))
;; (f)