; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Last update: Sep 08, 2011
;
; Copyright (c) 2011, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following disclaimer.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following disclaimer in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
; 


;Inspired by Paul Graham's classic "On Lisp" this module introduces
;anaphoric macros, which are unhygienic by design. Hence they can not
;implemented with syntax-rules! In fact, they introduce new identifiers
;behind the scene, mostly named it, which can be referenced in the body
;without being declared. Please note, that this identifier is not
;renamed! 
;
;We implement all anaphoric macros with ir-macro-transformer.

(module anaphora *

(import scheme (only chicken case-lambda print))

;;; (aif test? consequent [alternative])
;;; ------------------------------------
;;; anaphoric if, where consequent and alternative can refer to result
;;; of test? named it
(define-syntax aif
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((it (inject 'it)))
        (let (
          (test? (cadr form))
          (consequent (caddr form))
          (alternative (cdddr form))
          )
          (if (null? alternative)
            `(let ((,it ,test?))
               (if ,it ,consequent))
            `(let ((,it ,test?))
               (if ,it ,consequent ,(car alternative)))))))))

;;; (awhen test? xpr . xprs)
;;; ------------------------
;;; anaphoric when, where xpr ... can refer to result of test?
;;; named it
(define-syntax awhen
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((it (inject 'it)))
        (let (
          (test? (cadr form))
          (xpr (caddr form))
          (xprs (cdddr form))
          )
          `(let ((,it ,test?))
             (if ,it (begin ,xpr ,@xprs))))))))

;;; (acond . clauses)
;;; -----------------
;;; anaphoric cond, where each clause is a list (test? xpr ...) in which
;;; each xpr can refer to result of test? named it.
;;; The last clause can start with else which evaluates to #t.
(define-syntax acond
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((it (inject 'it)))
        (let ((clauses (cdr form)))
          (let loop ((clauses clauses))
            (if (null? clauses)
              #f
              (let* (
                (clause (car clauses))
                (cnd (car clause))
                )
                `(let ((sym ,(if (compare? cnd 'else) #t cnd)))
                   (if sym
                     (let ((,it sym))
                       ,@(cdr clause))
                     ,(loop (cdr clauses))))))))))))

;;; (awhile test? xpr . xprs)
;;; -------------------------
;;; anaphoric while, where each xpr ... can refer to the result of
;;; the successive test?, named it
(define-syntax awhile
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((it (inject 'it)))
        (let (
          (test? (cadr form))
          (xpr (caddr form))
          (xprs (cdddr form))
          )
          `(let loop ((,it ,test?))
             (when ,it
               ,xpr ,@xprs
               (loop ,test?))))))))

;;; (aand . args)
;;; -------------
;;; anaphoric and, where each successive argument can refer to the
;;; result of the previous argument, named it.
(define-syntax aand
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((it (inject 'it)))
        (let ((args (cdr form)))
          (let loop ((args args))
            (cond 
              ((null? args) #t)
              ((null? (cdr args)) (car args))
              (else 
                `(let ((,it ,(car args)))
                   (if ,it
                     ,(loop (cdr args))))))))))))

;;; (alambda args xpr . xprs)
;;; -------------------------
;;; anaphoric lambda, where the body xpr ... can refer to self, so that
;;; recursion is possible
(define-syntax alambda
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((self (inject 'self)))
        (let ((args (cadr form)) (body (cddr form)))
          `(letrec ((,self (lambda ,args ,@body)))
             ,self))))))

;;; documentation dispatcher

(define anaphora
  (let (
    (alist '(
      (aif
        (aif test? consequent [alternative])
        "anaphoric if, consequent and alternative can refer to result it
of test?")
      (awhen
         (awhen test? xpr . xprs)
         "anaphoric when, where xpr ... can refer to result of test?
named it")
      (acond
        (acond . clauses)
        "anaphoric cond, where each clause is a list (test? xpr ...) in which
each xpr can refer to result of test? named it.
The last clause can start with else which evaluates to #t.")
      (awhile
        (awhile test? xpr . xprs)
        "anaphoric while, where each xpr ... can refer to the result of
the successive test?, named it")
      (aand
        (aand . args)
        "anaporic and, each arg can refer to the previous arg with it")
      (alambda
        (alambda args . body)
        "anaphoric lambda, where body can refer to self")
      )))
    (case-lambda
      (() (map car alist))
      ((sym)
       (let ((pair (assq sym alist)))
         (if pair
           (cdr pair)
           (print "Choose one of " (map car alist))))))))

) ; module anaphora