;;;
;;; AspectScheme v. 2.3 -- with bindings, execution join points, and top-level aspects.
;;; Copyright (c) 2005, 2006 by Christopher Dutchyn ([email protected]); all rights reserved.
;;;

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

  ;; cribbed from swindle/base.ss -- thanks Eli!
  (define-syntaxes (let~ let*~ letrec~)
    (let* ([process (lambda (stx var0 val0 . flat?)
                      (syntax-case var0 (values)
                        [(values var ...) (null? flat?) #`((var ...) . #,val0)]
                        [_ (let loop ([var var0] [args '()])
                             (if (identifier? var)
                                 (if (null? args)
                                     (let ([val (syntax->list val0)])
                                       (if (and (pair? val) (null? (cdr val)))
                                           (list (if (null? flat?) (list var) var) (car val))
                                           (raise-syntax-error #f "bad binding" stx #`(#,var0 #,@val0))))
                                     (let ([sym (syntax-e var)])
                                       (let loop ([i   (sub1 (length args))]
                                                  [as  (reverse args)]
                                                  [val val0])
                                         (if (< i 0)
                                             (list (if (null? flat?) (list var) var)
                                                   (car (syntax->list val)))
                                             (loop (sub1 i) (cdr as)
                                                   (let ([val #`((lambda #,(car as) #,@val))])
                                                     (if (zero? i)
                                                         val
                                                         (syntax-property val
                                                                          'inferred-name
                                                                          (if (zero? i)
                                                                              sym
                                                                              (string->symbol
                                                                               (format "~a:~a" sym i)))))))))))
                                 (syntax-case var ()
                                   [(var . args1) (loop #'var (cons #'args1 args))])))]))]
           [mk-bindings
            (lambda (stx bindings . flat?)
              (syntax-case bindings ()
                [((var val more ...) ...)
                 (datum->syntax-object #'bindings
                                       (map (lambda (x y) (apply process stx x y flat?))
                                            (syntax->list #'(var ...))
                                            (syntax->list #'((val more ...) ...)))
                                       #'bindings)]))]
           [mk-let
            (lambda (tag . lbl)
              (lambda (stx)
                (syntax-case stx ()
                  [(_ label bindings body0 body ...)
                   (and (identifier? #'label) (pair? lbl))
                   (quasisyntax/loc stx
                     (#,(car lbl) label #,(mk-bindings stx #'bindings #t) body0 body ...))]
                  [(_ bindings body0 body ...)
                   (quasisyntax/loc stx
                     (#,tag #,(mk-bindings stx #'bindings) body0 body ...))])))])
      (values (mk-let #'let-values #'let)
              (mk-let #'let*-values)
              (mk-let #'letrec-values))))
  
  ;; Join Point
  ;;                proc           args
  ;; 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 (before, after) are special cases; using them might inform a type-
  ;; checker and enable it to recognize behaviour as extensional rather than superpositional.
  ;;
  ;; (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
    (syntax-rules ()
      [(_ ([p v]) e ...)
       (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.
  ;; As noted above, fluid-let fails, so we use the next-best thing.
  (define dynamic-aspects (make-parameter '()))
  (define  static-aspects (make-parameter '()))

  (define-syntaxes (fluid-around around)
    (let ([round (lambda (param)
                   (lambda (stx)
                     (syntax-case stx ()
                       [(_ pc adv body0 ...)
                        (quasisyntax/loc stx 
                          (fluid-let-parameter ([#,param (cons (make-aspect pc adv) (#,param))])
                            body0 ...))])))])
      (values (round #`dynamic-aspects)   ;dynamically-scoped
              (round #`static-aspects)))) ;lexically-scoped
              
  ;; lexically-scoped aspects
  (define-syntax lambda/static
    (syntax-rules ()
      [(_ params body ...)
       (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 -- in decending order of application!
  (define (current-aspects)
    (append (dynamic-aspects)
            (static-aspects)
            (toplevel-aspects)))
  
  ;; join points implemented as continuation marks
  ;;  (AKA fluid-let that respects safe-for-space properties)
  (define (jp-context) 
    (continuation-mark-set->list
     (current-continuation-marks) 
     'joinpoint))
  
  (define-syntax with-joinpoint
    (syntax-rules ()
      [(_ jp body ...)
       ((lambda (x) x)
        (with-continuation-mark 'joinpoint jp
          (begin body ...)))]))
  
  ;; replacement for #%app
  (define-syntax app/weave
    (syntax-rules ()
      [(_ f a ...) (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 let
                                     let*
                                     letrec
                                     #%app
                                     lambda)
           (rename let~ let)
           (rename let*~ let*)
           (rename letrec~ letrec)
           (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
           ))