;;;
;;; AspectScheme v. 2.2 -- with bindings, execution join points, and top-level aspects.
;;; Copyright (c) 2005 by Christopher Dutchyn (cdutchyn@cs.ubc.ca); all rights reserved.
;;;

(module aspect-scheme-2 mzscheme
  (require (only (lib "list.ss") foldl foldr))

  ;; Join Point
  ;; jp ::= call-jp a->b   a		;; procedure application ('a' can be values (ie. tuple {...})
  ;;     |  exec-jp a->b   a		;; procedure execution (cannot be advised only matched)
  					;;   AspectJ matches and transforms dispatches and calls, but not executions
                                        ;;   they're just poorly named (dispatch == `call', call == `execution')
  ;;     |  adv-jp  (a->b)->c->a->b  c	;; advice execution ... 'c' can be values as well

  ;; Pointcut
  ;; pc :: {[jp]*jp*[jp]}->c		;; above * jp * below

  ;; Advice
  ;; adv :: (a->b)->c->a->b
  
  ;; Aspect
  ;; aspect ::=    fluid-around pc adv body  ;; dynamic scoping
  ;;         |           around pc adv body  ;; lexical scoping
  ;;         |  toplevel-around pc adv       ;; top-level scoping (i.e. body is rest of repl)
  ;;
  ;; It is still unclear (to me), how AspectScheme should play with modules -- another layer of scoping.
  ;; I think it's a worthy (future) research project.
  ;;
  ;; Other kinds of advice are special cases:
  ;;
  ;; (before pc                       | (around pc
  ;;                                  |         (lambda (proceed)
  ;;         (lambda ctxt             |           (lambda ctxt
  ;;           (lambda args           |             (lambda args
  ;;             ...adv-body...))     |               ...adv-body...
  ;;                                  |               (proceed args))))
  ;;   body)                          |   body)

  ;; (after pc                        | (around pc
  ;;                                  |         (lambda (proceed)
  ;;        (lambda ctxt              |           (lambda ctxt
  ;;          (lambda args            |             (lambda args
  ;;                                  |               (let-values ([r (with-handlers ([(lambda (x) #t)
  ;;                                  |                                               (lambda (x) adv-body
  ;;                                  |                                                            raise x)])
  ;;                                  |                                 (proceed args)])
  ;;            adv-body))            |                 adv-body
  ;;                                  |                 (values r)))))
  ;;   body)                          |   body)

  ;; (after-throwing pc               | (around pc
  ;;                                  |         (lambda (proceed)
  ;;                 (lambda ctxt     |           (lambda ctxt
  ;;                   (lambda args   |             (lambda args
  ;;                                  |               (with-handlers ([(lambda (x) #t)
  ;;                     adv-body))   |                                (lambda (x) adv-body
  ;;                                  |                                            raise x)])
  ;;                                  |                 (proceed args)))))
  ;;   body)                          |   body)
  ;;

  ;; (after-returning pc              | (around pc
  ;;                                  |         (lambda (proceed)
  ;;                  (lambda ctxt    |           (lambda ctxt
  ;;                    (lambda args  |             (lambda args
  ;;                                  |               (let-values ([r (proceed args)])
  ;;            adv-body))            |                 adv-body
  ;;                                  |                 (values r)))))
  ;;   body)                          |   body)

  ;; aspect structure
  (define-struct aspect (pc adv))

  (define-struct          jp (target args))
  (define-struct (call-jp jp)(           ))
  (define-struct (exec-jp jp)(           ))
  (define-struct (adv-jp  jp)(           ))
  
  ;; PLT Scheme modules fail with fluid-let and regular definitions so we must use parameters
  ;;   the error is "set!: cannot mutate module-required variable", cf.
  ;; http://list.cs.brown.edu/pipermail/plt-scheme/2004-September/006723.html
  (define-syntax (fluid-let-parameter stx)
    (syntax-case stx ()
      [(_ ([p v]) e ...)
       (syntax (let ([y v])
                 (let ([swap (lambda ()
                               (let ([t (p)])
                                 (p y)
                                 (set! y t)))])
                   (dynamic-wind swap
                                 (lambda () e ...)
                                 swap))))]))
  
  ;; dynamically-scoped aspects
  ;; NB. We use dynamic binding to illuminate the connection to
  ;; the simplified semantics in the Science of Computer Programming
  ;; where dynamic-scoped variables hold static and dynamic aspects.
  (define dynamic-aspects (make-parameter '()))

  (define-syntax (fluid-around stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax
        (fluid-let-parameter ([dynamic-aspects
                               (cons (make-aspect pc adv) (dynamic-aspects))])
          body ...))]))
  
  ;; lexically-scoped aspects
  (define static-aspects (make-parameter '()))
  
  (define-syntax (around stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax
        (fluid-let-parameter ([static-aspects (cons (make-aspect pc adv) (static-aspects))])
          body ...))]))

  (define-syntax (lambda/static stx)
    (syntax-case stx ()
      [(_ params body ...)
       (syntax
        (let ([aspects (static-aspects)])
          (lambda params
            (fluid-let-parameter ([static-aspects aspects])
               body ...))))]))
  
  ;; top-level aspects
  (define toplevel-aspects (make-parameter '()))

  (define (toplevel-around pc adv)
    (toplevel-aspects (cons (make-aspect pc adv) (toplevel-aspects))))

  ;; weaver
  ;; current aspects
  (define (current-aspects)
    (append (dynamic-aspects)
            (static-aspects)
            (toplevel-aspects)))
  
  ;; join points implemented as continuation marks
  (define (jp-context) 
    (continuation-mark-set->list
     (current-continuation-marks) 
     'joinpoint))
  
  (define-syntax (with-joinpoint stx)
    (syntax-case stx ()
      [(_ jp body ...)
       (syntax ((lambda (x) x)
                (with-continuation-mark 'joinpoint jp
                  (begin body ...))))]))
  
  ;; replacement for #%app
  (define-syntax (app/weave stx)
    (syntax-case stx ()
      [(_ f a ...) (syntax (app/weave/rt f a ...))]))
  
  (define (app/weave/rt fun-val . arg-vals)
    (if (primitive? fun-val)
        (apply fun-val arg-vals)
        (let ([jp (make-call-jp fun-val arg-vals)])
          (with-joinpoint jp
            (apply (weave (lambda arg-vals
                            (with-joinpoint (make-exec-jp fun-val arg-vals)
                              (apply fun-val arg-vals)))
                          '() jp (jp-context)
                          (current-aspects))
                   arg-vals)))))
  
  (define (weave fun-val jp- jp jp+ aspects)
    (foldr (lambda (aspect fun)
             (cond
               [((aspect-pc aspect) jp- jp jp+)
                => (lambda (ctxt-vals)
                     (with-joinpoint (make-adv-jp (aspect-adv aspect) ctxt-vals)
                       (apply ((aspect-adv aspect) fun) ctxt-vals)))]
               [else fun]))
           fun-val
           aspects))

  ;; pointcuts -- strict combinators
  ;; NB. This PLT Scheme module does not export app/weave for #%app
  ;; until the end of the module, so these definitions do not
  ;; require app/prim.
  (define ((&& . pcs) jp- jp jp+)
    (let loop ([pcs  pcs]
               [res  '()])
      (if (null? pcs)
          (reverse res)
          (let ([r ((car pcs) jp- jp jp+)])
            (and r
                 (loop (cdr pcs) (append (reverse r) res)))))))
  
  (define ((|| . pcs) jp- jp jp+)
    (let loop ([pcs pcs])
      (and (not (null? pcs))
           (or ((car pcs) jp- jp jp+)
               (loop (cdr pcs))))))

  (define ((! pc) jp- jp jp+)
    (and (not (pc jp- jp jp+))
         '()))

  ;; pointcuts -- structural
  (define (top? jp- jp jp+)
    (and (null? jp+)
         '()))
  
  (define (top pc)
    (&& pc
        (! (cflowbelow pc))))
  
  (define ((below pc) jp- jp jp+)
    (and (not (null? jp+))
         (pc (cons jp jp-) (car jp+) (cdr jp+))))
  
  (define ((above pc) jp- jp jp+)
    (and (not (null? jp-))
         (pc (cdr jp-) (car jp-) (cons jp jp+))))

  (define (bottom pc)
    (&& pc
        (! (cflowabove pc))))
  
  (define (bottom? jp- jp jp+)
    (and (null? jp-)
         '()))

  ;; pointcuts -- `binding'
  (define (target jp- jp jp+)
    (list (jp-target jp)))
  
  (define (args jp- jp jp+)
    (jp-args jp))

  (define ((some-args as) jp- jp jp+)
    (foldl (lambda (a v l)
             (if a
                 (cons v l)
                 l))
           '()
           as
           (jp-args jp)))
 
  ;; pointcuts -- fundamental
  (define ((kind= k?) jp- jp jp+)
    (and (k? jp)
         '()))
  
  (define call? (kind= call-jp?))
  
  (define exec? (kind= exec-jp?))
  
  (define adv? (kind= adv-jp?))

  (define ((target= f) jp- jp jp+)
    (and (eq? f (jp-target jp))
         '()))
  
  (define (call f)
    (&& call?
        (target= f)))

  (define (exec f)
    (&& exec?
        (target= f)))

  (define (adv a)
    (&& adv?
        (target= a)))

  ;; pointcuts - higher-order recursive
  (define (((cflow-walk step end) pc) jp- jp jp+)
    ((|| pc
         (&& (! end)
             (step ((cflow-walk step end) pc)))) jp- jp jp+))

  ;; pointcuts - higher-order points-free
  (define (cflowtop pc)
    (cflowbelow (top pc)))
  
  (define (cflowbelow pc)
    (below ((cflow-walk below top?) pc)))

  (define (cflowabove pc)
    (above ((cflow-walk above bottom) pc)))
  
  (define (cflowbottom pc)
    (cflowbelow (bottom pc)))

  ;; pointcuts - compatibility
  (define (cflow pc)
    ((cflow-walk below top?) pc))

  ;; this one is interesting -- can you do this without cflowabove?
  ;; I think not; it is a special case of enclosingexecution where
  ;; no other executions are allowed in between _here_ and the execution
  ;; ie. we have a dynamic test for a lexical condition
  ;; of course, tail call optimization makes executions disappear, so
  ;; we presume that TCO for `interesting' executions does happen
  ;; Furthermore, since `interesting' (== tested for in a pointcut)
  ;; executions might not be known until after we've accumulated a context
  ;; with them
  ;;  (let ([f (lambda (g)
  ;;             (let ([h (lambda () 1)])
  ;;               (around (&& (call h)
  ;;                           (cflow (call g)))
  ;;                       (lambda (jp)
  ;;                         (lambda ()
  ;;                           (+ 1 (jp))))
  ;;                     (h))))])
  ;;    (f f))
  ;; then the problem becomes insurmountable in the general case.
  ;; So what specific cases can be optimized (modulo tail calls)?

  (define (within f)
    (cflowbelow (&& (exec f)
                    (! (cflowabove call?))))) ;; exec? is incorrect since advice isn't within

  (provide (all-from-except mzscheme #%app lambda)
           (rename app/weave #%app)
           (rename #%app app/prim)
           fluid-around
           (rename lambda/static lambda)
           around
           toplevel-around

           && || !
           top? top below above bottom bottom?
           target args some-args
           call? exec? adv? call exec adv
           cflowtop cflowbelow cflowbottom cflowabove
           cflow within
           ))