;;;
;;; AspectScheme
;;; Copyright (c) 2005, 2006, 2007, 2008 by Christopher Dutchyn ([email protected]); all rights reserved.
;;;

#lang scheme

(require (only-in swindle/base let let* letrec))

(provide (except-out (all-from-out scheme) lambda #%app)

         (rename-out [#%app app/prim]
                     [app/weave #%app]
                     [lambda/static lambda])
         around fluid-around top-level-around
         top? bottom? below above
	 focus-jp
         target args
         call? exec? adv?
         
         let let* letrec)


;; 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 executions, but not calls
;;   they're just poorly named (dispatch is written `call')
;;     |  adv-jp  (a->b)->c->a->b  c	;; advice execution ... 'c' can be values as well

;; Join Point Stream
;; jps = [jp]*jp*[jp]                   ;; [below] * jp * [above]

;; Pointcut
;; pc :: jps->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
;;         |  top-level-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.
;;

;; 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",
;;  c.f. http://list.cs.brown.edu/pipermail/plt-scheme/2004-September/006723.html
;;  n.b. using dynamic-wind to provide fluid-let is subtle
(define-syntax fluid-let-parameter
  (syntax-rules ()
    [(_ ([p v]) e ...)
     (let ([y v])
       (let ([(swap) (let ([t (p)])
                       (p y)
                       (set! y t))])
         (dynamic-wind swap
                       (lambda () e ...)
                       swap)))]))

;; lexically-scoped aspects
(define-syntax lambda/static
  (lambda (stx)
    (syntax-case stx ()
      [(_ params body ...)
       (syntax/loc stx (let ([aspects (static-aspects)])
                         (lambda params
                           (fluid-let-parameter ([static-aspects aspects])
                             body ...))))])))

;; dynamically-scoped aspects
;; NB. We use dynamic binding to illuminate the connection to the
;; simplified semantics in the Science of Computer Programming paper
;; 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 body ...)
                      (quasisyntax/loc stx 
                        (fluid-let-parameter ([#,param (cons (make-aspect pc adv) (#,param))])
                          body ...))])))])
    (values (round #`dynamic-aspects)   ;dynamically-scoped
            (round #`static-aspects)))) ;lexically-scoped

;; top-level aspects
(define top-level-aspects (make-parameter '()))

(define (top-level-around pc adv)
  (top-level-aspects (cons (make-aspect pc adv) (top-level-aspects))))

;; weaver
;; current aspects -- in decending order of application!
(define (current-aspects)
  (append (dynamic-aspects)
          (static-aspects)
          (top-level-aspects)))

;; join points implemented as continuation marks
;;  (AKA fluid-let that respects safe-for-space properties)

;; ensure that our continuation mark is unique and unforgeable
(define-struct jp-mark (id))
(define jp-mark-tag (make-jp-mark 'joinpoint))
  
(define (jp-context) 
  (continuation-mark-set->list
   (current-continuation-marks) 
   jp-mark-tag))

(define-syntax with-joinpoint
  (syntax-rules ()
    [(_ jp body ...)
     ((lambda (x) x)
      (with-continuation-mark jp-mark-tag jp
        (begin body ...)))]))

;; replacement for #%app
(define-syntax app/weave
  (lambda (stx)
    (syntax-case stx ()
      [(_ f a ...)
       (syntax/loc stx (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)]
            [jp+ (jp-context)])
        (with-joinpoint jp
          (apply (weave (lambda arg-vals
                          (with-joinpoint (make-exec-jp fun-val arg-vals)
                            (apply fun-val arg-vals)))
                        '()
                        jp
                        jp+
                        (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 -- `binding'
(define (target jp- jp jp+)
  (list (jp-target jp)))

(define (args jp- jp jp+)
  (jp-args jp))

;; pointcuts -- `fundamental'
(define ((focus-jp p) jp- jp jp+)
  (p jp))

(define-values (call? exec? adv?)
  (let ([((succeed? x) . jpstream) (and (apply x jpstream) '())])
    (values (succeed? (focus-jp call-jp?))
	    (succeed? (focus-jp exec-jp?))
	    (succeed? (focus-jp adv-jp?)))))

(define (top? jp- jp jp+)
  (and (null? jp+)
       '()))

(define (bottom? jp- jp jp+)
  (and (null? jp-)
       '()))

;; pointcuts -- `higher-order recursive'
(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+))))

;; utility
(define (display-jps jp- jp jp+)
  (for-each (lambda (jp) (display `(< ,jp ,(jp-args jp)))) jp-)
  (display `(= ,jp ,(jp-args jp)))
  (for-each (lambda (jp) (display `(> ,jp ,(jp-args jp)))) jp+)
  (newline))

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

;; pointcuts -- strict `binding'
(define ((some-args as) . jpstream)
  (foldl (lambda (a v l)
           (if a
               (cons v l)
               l))
         '()
         as
         (apply args jpstream)))

(define ((with-args as) . jpstream)
  (append (apply args jpstream)
          as))

;; pointcuts -- `basic'
(define-values (call exec adv)
  (let* ([((target= f) . jpstream) (and (eq? f
                                             (car (apply target jpstream)))
                                        '())]
         [((this-target? o) f) (&& o (target= f))])
    (values (this-target? call?)
            (this-target? exec?)
            (this-target? adv?))))

;; pointcuts -- strict combinators
(define ((&& . pcs) . jpstream)
  (let loop ([pcs  pcs]
             [res  '()])
    (if (null? pcs)
        res
        (let ([r (apply (car pcs) jpstream)])
          (and r
               (loop (cdr pcs) (append res r)))))))

(define ((|| . pcs) . jpstream)
  (let loop ([pcs pcs])
    (and (not (null? pcs))
         (or (apply (car pcs) jpstream)
             (loop (cdr pcs))))))

(define ((! pc) . jpstream)
  (and (not (apply pc jpstream))
       '()))

;; pointcuts -- `higher-order recursive'
(define (((cflow-walk pc) step end) . jpstream)
  (apply (|| pc
             (&& (! end)
                 (step ((cflow-walk pc) step end)))) jpstream))

;; pointcuts -- `higher-order points-free'
(define (top pc)
  (&& pc
      (! (cflowbelow pc))))

(define (bottom pc)
  (&& pc
      (! (cflowabove pc))))

(define (cflowtop pc)
  (cflowbelow (top pc)))

(define (cflowbelow pc)
  (below ((cflow-walk pc) below top?)))

(define (cflowabove pc)
  (above ((cflow-walk pc) above bottom?)))

(define (cflowbottom pc)
  (cflowbelow (bottom pc)))

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

(define (within f)
  (cflowbelow (&& (exec f)
                  (! (cflowabove call?)))))

(provide           before           after           after-throwing           after-returning
             fluid-before     fluid-after     fluid-after-throwing     fluid-after-returning
         top-level-before top-level-after top-level-after-throwing top-level-after-returning
	 )

;; 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.

(define-syntax before
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
                              (let ([(err-proceed . args) (error 'aspectscheme "proceed in before")])
                                (begin (apply (apply (adv err-proceed) ctxt) args)
                                       (apply proceed args)))])
			 (around pc n-adv
			   body ...)))])))

(define-syntax after
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let* ([(exc? e) #t]
                                       [(handle e) (begin (after)
                                                          (raise x))])
                                  (with-handlers ([exc? handle])
                                    (let ([results (apply proceed args)])
                                      (after)
                                      results))))])
                         (around pc n-adv
			   body ...)))])))

(define-syntax after-throwing
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after-throwing")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let* ([(exc? e) #t]
                                       [(handle e) (begin (after)
                                                          (raise x))])
                                  (with-handlers ([exc? handle])
                                    (apply proceed args))))])
			 (around pc n-adv
			   body ...)))])))

(define-syntax after-returning
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after-returning")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let ([results (apply proceed args)])
				  (after)
				  results))])
			 (around pc n-adv
			   body ...)))])))


(define-syntax fluid-before
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
                              (let ([(err-proceed . args) (error 'aspectscheme "proceed in before")])
                                (begin (apply (apply (adv err-proceed) ctxt) args)
                                       (apply proceed args)))])
			 (fluid-around pc n-adv
			   body ...)))])))

(define-syntax fluid-after
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let* ([(exc? e) #t]
                                       [(handle e) (begin (after)
                                                          (raise x))])
                                  (with-handlers ([exc? handle])
                                    (let ([results (apply proceed args)])
                                      (after)
                                      results))))])
                         (fluid-around pc n-adv
			   body ...)))])))

(define-syntax fluid-after-throwing
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after-throwing")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let* ([(exc? e) #t]
                                       [(handle e) (begin (after)
                                                          (raise x))])
                                  (with-handlers ([exc? handle])
                                    (apply proceed args))))])
			 (fluid-around pc n-adv
			   body ...)))])))

(define-syntax fluid-after-returning
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after-returning")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let ([results (apply proceed args)])
				  (after)
				  results))])
			 (fluid-around pc n-adv
			   body ...)))])))

(define-syntax top-level-before
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
                              (let ([(err-proceed . args) (error 'aspectscheme "proceed in before")])
                                (begin (apply (apply (adv err-proceed) ctxt) args)
                                       (apply proceed args)))])
			 (top-level-around pc n-adv)))])))

(define-syntax top-level-after
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let* ([(exc? e) #t]
                                       [(handle e) (begin (after)
                                                          (raise x))])
                                  (with-handlers ([exc? handle])
                                    (let ([results (apply proceed args)])
                                      (after)
                                      results))))])
                         (top-level-around pc n-adv)))])))

(define-syntax top-level-after-throwing
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after-throwing")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let* ([(exc? e) #t]
                                       [(handle e) (begin (after)
                                                          (raise x))])
                                  (with-handlers ([exc? handle])
                                    (apply proceed args))))])
			 (top-level-around pc n-adv)))])))

(define-syntax top-level-after-returning
  (lambda (stx)
    (syntax-case stx ()
      [(_ pc adv body ...)
       (syntax/loc stx (let ([(((n-adv proceed) . ctxt) . args)
			      (let* ([(err-proceed . args) (error 'aspectscheme "proceed in after-returning")]
                                     [(after) (apply (apply (adv err-proceed) ctxt) args)])
				(let ([results (apply proceed args)])
				  (after)
				  results))])
			 (top-level-around pc n-adv)))])))