;; advice.gwm --- A general package for redefining functions
;;
;; Author: Anders Holst  (aho@sans.kth.se)  
;; Copyright (C) 1996  Anders Holst
;; Last change: 23/3 1996
;;
;; This file is copyrighted under the same terms as the rest of GWM
;; (see the X Inc license for details). There is no warranty that it
;; works. 
;;
;; --------------------------------------------------------------------- 
;;
;; This package implements a way to redefine functions in a controlled
;; and uniform way. It is modeled mainly after the "advice" package in
;; Emacs. If everyone uses this package when they redefine functions
;; in GWM, this will minimize the risk of collisions between different
;; packages redefining the same function. It will also prevent the
;; case that a function gets ruined because some file is (accidentally)
;; loaded twice, and then tries to redefine the same function twice.
;;
;; The main function 'advice' is used like this:
;;   (advice <FUNCTION> <TAG> <TYPE> <BODY ...>)
;; The <TAG> is an atom which is used as a label for this piece of
;; advice. If the same function is adviced twice with the same label
;; (and with the same <TYPE>), the old advice will be replaced. Also it
;; makes it possible to remove a particular advice.
;; There are three possible values of <TYPE>: 'before', 'after', and
;; 'around', depending on whether the advice is to be run before, after,
;; or around the call to the original function.
;; <FUNCTION> can actually be either the function name, or a list with
;; the function name followed by formal arguments. These arguments will
;; then be bound to the corresponding actual arguments during execution
;; of the body. In both cases the symbol 'args' will be bound to the
;; whole argument list.
;; During execution of the body of an 'around' advice, the original
;; function name is temporarily rebound to the original function (or,
;; well, it's a little complicated, but something to that effect
;; anyway), so to mark where the original function should go you just
;; call the function again at that point. If you are not sure how many
;; arguments the function got, or don't want to use the optional
;; parameter list, you can always call the original function with the
;; construct '(apply <FUNCTION> args)'.
;; Note that if you advice a "macro" (ie defunq) its arguments is
;; unevaluated during the execution of the body, and still the "original"
;; function in an 'around' advice works like a macro, which means that
;; the arguments to the original call may be evaluated once too less if
;; you are not careful. In any case it should always work to call the
;; original function as '(apply <FUNCTION> args)'.
;;
;; There is also a function 'unadvice' which is used like this:
;;   (unadvice <FUNCTION> [<TAG>])
;; It removes the advice with tag <TAG> from the function (or it
;; removes advices with that tag of all three advice types). If no
;; tag is given, all advices are removed, and the function is set to
;; its original again.
;;
;; If some package would like to be sure to use the original,
;; un-redefined version of some function by some reason, it can always
;; use '(advice-original <FUNCTION>)' to retrieve it. But NOTE, this
;; should *not* be used in the body of an 'around' advice, since this
;; would ruin other packages 'around' advices.
;;

(defun advice-embed-body (argl body)
  (if (not argl)
      (eval (+ '(lambda (args)) body))
    (with (len (length argl)
           ctx (list-make (* len 2))
           i 0)
      (while (< i len)
        (## (* i 2) ctx (# i argl))
        (## (+ (* i 2) 1) ctx (list '# i 'args))
        (setq i (+ i 1)))
      (eval (list 'lambda '(args) (+ (list 'with ctx) body))))))

(defun advice-construct-inner (hooks i symb origf)
  (if (not hooks)
      origf
    (not (< i (length hooks)))
      (if (member (type origf) '(fsubr fexpr))
          (eval (` (lambdaq args 
                     (with ((, symb)
                            (, (eval symb)))
                       (eval (+ (list (, origf)) args))))))
        (eval (` (lambda args 
                   (with ((, symb)
                          (, (eval symb)))
                     (eval (+ (list (, origf))
                              (mapfor ele args (list 'quote ele)))))))))
    (if (member (type origf) '(fsubr fexpr))
        (eval (` (lambdaq args
                   (with ((, symb)
                          (, (advice-construct-inner hooks (+ i 1) symb origf)))
                     ((, (# i hooks)) args)))))
      (eval (` (lambda args
                 (with ((, symb)
                        (, (advice-construct-inner hooks (+ i 1) symb origf)))
                   ((, (# i hooks)) args))))))))

(defunq advice args
  (with (func (if (= (type (# 0 args)) 'list)
                  (# 0 (# 0 args))
                (# 0 args))
         argl (if (= (type (# 0 args)) 'list)
                  (sublist 1 (length (# 0 args)) (# 0 args))
                ())
         adtag (eval (# 1 args))
         adtype (eval (# 2 args))
         body (sublist 3 (length args) args)
         origsymb (atom (+ "ad_" func "_orig"))
         presymb (atom (+ "ad_" func "_pre"))
         postsymb (atom (+ "ad_" func "_post"))
         insymb (atom (+ "ad_" func "_in"))
         hook () pos ())
    (if (not (boundp origsymb))
        (progn
          (set origsymb (eval func))
          (set presymb (copy '(() ())))
          (set postsymb (copy '(() ())))
          (set insymb (copy '(() () ())))
          (set func (if (member (type (eval func)) '(fsubr fexpr))
                        (eval (` (lambdaq args
                             (with (ad_res ())
                               (for f (# 0 (, presymb)) (f args))
                               (setq ad_res 
                                     (eval (+ (list (# 2 (, insymb))) args)))
                               (for f (# 0 (, postsymb)) (f args))
                               ad_res))))
                      (eval (` (lambda args
                           (with (ad_res ())
                             (for f (# 0 (, presymb)) (f args))
                             (setq ad_res
                                   (eval (+ (list (# 2 (, insymb)))
                                            (mapfor e args (list 'quote e)))))
                             (for f (# 0 (, postsymb)) (f args))
                             ad_res))))))
          (## 2 (eval insymb) (eval origsymb))))
    (setq hook (if (= adtype 'before)
                   (eval presymb)
                 (= adtype 'after)
                   (eval postsymb)
                 (= adtype 'around)
                   (eval insymb)))
    (setq pos (member adtag (# 1 hook)))
    (if hook 
        (progn
          (if pos 
              (## pos (# 0 hook) (advice-embed-body argl body))
            (= adtype 'after)
            (progn
              (## 0 hook (+ (# 0 hook)
                            (list (advice-embed-body argl body))))
              (## 1 hook (+ (# 1 hook) (list adtag))))
            (progn
              (## 0 hook (+ (list (advice-embed-body argl body))
                            (# 0 hook)))
              (## 1 hook (+ (list adtag) (# 1 hook)))))
          (if (= adtype 'around)
              (## 2 hook (advice-construct-inner (# 0 hook) 0 func (eval origsymb))))
          )
      (? "Bad advice type: " adtype))
    (if hook t ())))

(defunq unadvice args
  (with (func (if (= (type (# 0 args)) 'list)
                  (# 0 (# 0 args))
                (# 0 args))
         adtag (eval (# 1 args))
         origsymb (atom (+ "ad_" func "_orig"))
         presymb (atom (+ "ad_" func "_pre"))
         postsymb (atom (+ "ad_" func "_post"))
         insymb (atom (+ "ad_" func "_in"))
         hook () pos () ret ())
    (if (boundp origsymb)
        (if adtag
            (progn
              (for hook (list (eval presymb) (eval postsymb) (eval insymb))
                (setq pos (member adtag (# 1 hook)))
                (if pos 
                    (progn 
                      (setq ret t)
                      (delete-nth pos (# 0 hook))
                      (delete-nth pos (# 1 hook)))))
              (if pos
                  (## 2 hook (advice-construct-inner (# 0 hook)
                                                     0 func (eval origsymb))))
              ret)
          (progn
            (set func (eval origsymb))
            (unbind presymb)
            (unbind postsymb)
            (unbind insymb)
            (unbind origsymb)
            t)))))
          
(defunq advice-original (func)
  (with (origsymb (atom (+ "ad_" func "_orig")))
    (if (boundp origsymb)
        (eval origsymb)
      (eval func))))
