;;;
;;; AspectScheme
;;;
;;;     Copyright (C) 2005 Christopher Dutchyn.  This program is Free
;;;     Software; you can redistribute it and/or modify it under the
;;;     terms of the GNU Lesser General Public License as published by
;;;     the Free Software Foundation; either version 2.1 of the License,
;;;     or (at your option) any later version.  This program is
;;;     distributed in the hope that it will be useful, but without any
;;;     warranty; without even the implied warranty of merchantability or
;;;     fitness for a particular purpose.  See the GNU Lesser General
;;;     Public License [LGPL] for details.  For other license options and
;;;     commercial consulting, contact the author.
;;;
;;; Based on Tucker/Krishnamurthi/Dutchyn SCP submission.
;;; See also as-tests.scm.
;;;

;;; fixes and improvements
;;;      i) added static-env structure as in paper
;;;     ii) added w-c-m and c-c-m definitions
;;;    iii) made nested arounds work
;;;     iv) changed jp to jp* to match paper
;;;      v) removed superfluous static-env structure
;;;    vii) rewrite current-static-aspects to remove unneccessary foldl
;;;   viii) rewrote weave to make foldr manifest
;;;     ix) renamed aspect-pair structure to just aspect
;;;      x) suggest proceed as the preferred name for jp

(module aspect-scheme mzscheme
  (require (rename (lib "list.ss") foldr foldr))

  (define (c-c-m key) 
    (continuation-mark-set->list
     (current-continuation-marks) 
     key))
  
  (define-syntax (w-c-m stx)
    (syntax-case stx ()
      [(_ tag mark body)
       (syntax ((lambda (x) x)
                (with-continuation-mark tag mark body)))]))
 
  (define-struct aspect (pc adv))

  (define (current-aspects)
    (append (current-dynamic-aspects)
            (current-static-aspects)))
  
  ;; dynamically-scoped aspects
  (define-syntax (fluid-around stx)
    (syntax-case stx ()
      [(_ pc adv body)
       (syntax (w-c-m 'dynamic-aspect (make-aspect pc adv)
                 body))]))

  (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)
        (w-c-m 'joinpoint fun-val
          (apply (weave fun-val (c-c-m 'joinpoint) (current-aspects))
                 arg-vals))))
  
  (define (weave fun-val jp* aspects)
    (foldr (lambda (a r)
             (if ((aspect-pc a) jp*)
                 (lambda vs
                   (apply ((aspect-adv a) r) vs))
                 r))
           fun-val
           aspects))

  (define (current-dynamic-aspects)
    (c-c-m 'dynamic-aspect))
  
  ;; statically-scoped aspects
  (define-syntax (around stx)
    (syntax-case stx ()
      [(_ pc adv body)
       (syntax (w-c-m 'static-aspect
                      (cons (make-aspect pc adv)
                            (current-static-aspects))
                 body))]))
  
  (define-syntax (lambda/static stx)
    (syntax-case stx ()
      [(_ params body ...)
       (syntax
        (let ([env (current-static-aspects)])
          (lambda params
            (w-c-m 'static-aspect env
              (begin body ...)))))]))
  
  (define (current-static-aspects)
    (let ([aspectss (c-c-m 'static-aspect)])
      (if (null? aspectss)
          '()
          (car aspectss))))
  
  ;; pointcuts - fundamental
  (define (call f)
    (lambda (jp*)
      (eq? f (car jp*))))
  
  (define (top)
    (lambda (jp*)
      (null? jp*)))
  
  (define (below pc)
    (lambda (jp*)
      (and (not (null? (cdr jp*)))
           (pc (cdr jp*)))))

  ;; pointcuts - strict combinators
  (define (&& . pcs)
    (lambda (jp*)
      (andmap (lambda (pc) (pc jp*)) pcs)))

  (define (|| . pcs)
    (lambda (jp*)
      (ormap (lambda (pc) (pc jp*)) pcs)))

  (define (! pc)
    (lambda (jp*)
      (not (pc jp*))))

  ;; pointcuts - higher-order points-free
  (define (within f)
    (below (call f)))
  
  (define (cflow pc)
    (&& (! top)
        (|| pc
            (cflowbelow pc))))

  (define (cflowbelow pc)
    (&& (! top)
        (below (cflow pc))))
  
  (provide (all-from-except mzscheme #%app lambda)
           (rename app/weave #%app)
           (rename #%app app/prim)
           fluid-around
           (rename lambda/static lambda)
           around
           call top below && || ! within cflow cflowbelow))