; Author: Juergen Lorenz
; ju (at) jugilo (dot) de
;
; Last update: Sep 06, 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.
; 

(module low-level-macros
  (low-level-macros with-aliases er-macro-rules ir-macro-rules
                    define-macro macro-let macro-letrec)

(import scheme
  (only chicken case-lambda condition-case gensym error print)
  (only extras sprintf))

;reduced version of bind

;;; (bind pat seq . body)
;;; ---------------------
;;; binds pattern variables of pat to correspondign subexpressions
;;; of seq and executes body in this context
(define-syntax bind
  (ir-macro-transformer
    (lambda (form inject compare?)
      ;;; own version
      (letrec (
        (checks '()) ; to be populated by destruc
        (destruc
          (lambda (pat seq)
              (cond
                ((null? pat)
                 (begin
                   (set! checks (cons `(null? ,seq) checks))
                   '()))
                ((symbol? pat) `((,pat ,seq)))
                ((pair? pat) (append (destruc (car pat) `(car ,seq))
                                     (destruc (cdr pat) `(cdr ,seq)))))))
        )
        (let ((pat (cadr form)) (seq (caddr form)) (body (cdddr form)))
          (let ((decls (destruc pat seq)))
            (let (
              (vars (map car decls))
              (error-msg
                `(error 'bind
                        (sprintf "expression ~a doesn't match pattern ~a~%"
                                 ,seq ',pat)))
              )
              `(let (
                 ;; separate destructuring from body for correct error message
                 (args
                   (condition-case
                     (if (memq #f ,(cons 'list checks))
                       ,error-msg
                       (let ,decls (list ,@vars)))
                     ((exn) ,error-msg)))
                 )
                 (apply (lambda ,vars ,@body) args)))))))))

;reduced version of bind-case

;;; (bind-case seq (pat0 . body0) (pat1 . body1) ...)
;;; -------------------------------------------------
;;; Checks if seq matches patterns pat0 pat1 ... 
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; corresponding body in this context
(define-syntax bind-case
  (syntax-rules ()
    ((_ seq (pat xpr . xprs))
     (bind pat seq xpr . xprs))
    ((_ seq clause0 clause1 ...)
     (condition-case
       (bind-case seq clause0)
       ((exn)
        (bind-case seq clause1 ...))))))

;;; (ir-macro-rules (sym ...) (pat0 xpr0) (pat1 xpr1) ...)
;;; ------------------------------------------------------
;;; where xpr0, xpr1, ... are expressions
;;; Checks the macro's use against a series of patterns, pat0, pat1 ...
;;; and executes the expression corresponding to the first matching
;;; pattern.
;;; This macro will mostly be imported with import-for-syntax, it is
;;; unhygienic by design, i.e. it pollutes the local namespace with
;;; symbols inject and compare?
(define-syntax ir-macro-rules
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((syms (cadr f)) (pairs (cddr f)))
        (let (
          (pats (map car pairs))
          (xprs (map cadr pairs))
          ;; unhygienic
          (inject (i 'inject))
          (compare? (i 'compare?))
          )
          `(ir-macro-transformer
             (lambda (form ,inject ,compare?)
               (let ,(map (lambda (sym) `(,sym (,inject ',sym)))
                           syms)
                 (bind-case form
                   ,@(map (lambda (pat xpr) `(,pat ,xpr))
                          pats xprs))))))))))

;;; (er-macro-rules (%sym ...) (pat0 xpr0) (pat1 xpr1) ...)
;;; -------------------------------------------------------
;;; where xpr0, xpr1, ... are expressions which generate the macro
;;; expansion.
;;; Checks the macro's use against a series of patterns, pat0, pat1 ...
;;; and returns the corresponding macro-expansion.
(define-syntax er-macro-rules
  (er-macro-transformer
  (lambda (f r c?)
    (let ((syms (cadr f)) (rules (cddr f)))
      (let (
        (pats (map car rules))
        (xprs (map cadr rules))
        (sym-cdr
          (lambda (%sym)
            (string->symbol 
              (substring
                (symbol->string %sym) 1))))
        (%let (r 'let))
        (%lambda (r 'lambda))
        (%bind-case (r 'bind-case))
        (%er-macro-transformer (r 'er-macro-transformer))
        (%form (r 'form))
        (%rename (r 'rename))
        )
        `(,%er-macro-transformer
           ;; not that compare? is unhygienic
           (,%lambda (,%form ,%rename compare?)
             (,%let ,(map (lambda (sym)
                            `(,sym (,%rename ',(sym-cdr sym))))
                          syms)
               (,%bind-case ,%form
                 ,@(map (lambda (pat xpr) `(,pat ,xpr))
                        pats xprs))))))))))

;As an application of the two (er|ir)-macro-rules macros we'll implement
;some further macros which will make the writing of implicit-renaming
;macros easier. For example, define-macro will have almost the same
;syntax as define-macro from earlier Chicken implementations, where it
;not for the additional with-renamed line, so that an implementation of
;an or macro would look as follows:

;  (define-macro (my-or . args)
;    (with-renamed (%if %my-or)
;      (if (null? args)
;        #f
;        (let ((tmp (car args)))
;          `(,%if ,tmp ,tmp (,%my-or ,@(cdr args)))))))

;;; initialize documentation
;(doclist '())

;;; (define-macro code (with-renamed (%sym ...) . body))
;;; (define-macro code (with-injectoed (sym ...) . body))
;;; (define-macro code . body))
;;; -----------------------------------------------------
;;; where code is the complete macro-code (name . args), i.e. the pattern
;;; of a macro call, %sym ... are aliases of sym ... and body a list of
;;; expressions which produce the macro-expansion.

(define-syntax define-macro
  (syntax-rules (with-renamed with-injected)
    ((_ (name . args) (with-renamed (%sym ...) xpr . xprs))
     (define-syntax name
       (er-macro-rules (%sym ...)
         ((_ . args) (begin xpr . xprs)))))
    ((_ (name . args) (with-injected (sym ...) xpr . xprs))
    ;; sym ... are unhygienic injected symbols
     (define-syntax name
       (ir-macro-rules (sym ...)
         ((_ . args) (begin xpr . xprs)))))
    ;; hygienic
    ((_ (name . args) xpr . xprs)
     (define-macro (name . args) (with-injected () xpr . xprs)))))

;macro-let and macro-letrec are local versions of define-macro, where
;the local macros are evaluated in parallel or recursively.
;
;;; (macro-let ((code0 (with-renamed (%sym0 ...) . body0)) ...) . body)
;;; (macro-let ((code0 (with-injected (sym0 ...) . body0)) ...) . body)
;;; (macro-let ((code0 . body0) ...) . body)
;;; -------------------------------------------------------------------
;;; where code0, %sym0 and body0 are as in er-define-macro. This is
;;; a local version of define-macro, allowing a list of
;;; (code with-xpr) lists to be processed in body in parallel.
(define-syntax macro-let
  (syntax-rules (with-renamed)
    ((_ (
       ((name0 . args0) (with-renamed syms0 xpr0 . xprs0))
       ...
       ) xpr . xprs)
     (let-syntax (
       (name0
         (er-macro-rules syms0
           ((_ . args0) (begin xpr0 . xprs0))))
       ...
       ) xpr . xprs))
    ((_ (((name0 . args0) xpr0 . xprs0) ...) xpr . xprs)
     (ir-helper let-syntax
                (((name0 . args0) xpr0 . xprs0) ...) xpr . xprs))))

;;; (macro-letrec ((code0 (with-renamed (%sym0 ...) . body0)) ...) . body)
;;; (macro-letrec ((code0 (with-injected (sym0 ...) . body0)) ...) . body)
;;; (macro-letrec ((code0 . body0) ...) . body)
;;; ----------------------------------------------------------------------
;;; where code0, %sym0 and body0 are as in define-macro. This is
;;; a local version of define-macro, allowing a list of
;;; (code with-xpr) lists to be processed in body recursively.
(define-syntax macro-letrec
  (syntax-rules (with-renamed)
    ((_ (
       ((name0 . args0) (with-renamed syms0 xpr0 . xprs0))
       ...
       ) xpr . xprs)
     (letrec-syntax (
       (name0
         (er-macro-rules syms0
           ((_ . args0) (begin xpr0 . xprs0))))
       ...
       ) xpr . xprs))
    ((_ (((name0 . args0) xpr0 . xprs0) ...) xpr . xprs)
     (ir-helper letrec-syntax
                (((name0 . args0) xpr0 . xprs0) ...) xpr . xprs))))

;;; (ir-helper op pairs . body)
;;; ------------------------
;;; Since macro-let and macro-letrec have the same code except
;;; that the former evaluates to a let-syntax and the latter to a
;;; letrec-syntax, this ir-helper starts with the op argument, which is to
;;; be replaced by either let-syntax or letrec-syntax.
(define-syntax ir-helper
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((op (cadr form)) (pairs (caddr form)) (body (cdddr form)))
        (let (
          (pats (map car pairs))
          (bodies (map cdr pairs))
          (with? (lambda (lst)
                 (and (null? (cdr lst))
                      (list? (car lst))
                      (compare? (caar lst) 'with-injected))))
          )
          (let (
            (syms (map (lambda (b)
                         (if (with? b)
                           (cadar b)
                           '()))
                       bodies))
            (xprs (map (lambda (b)
                         (if (with? b)
                           (cddar b)
                           b))
                       bodies))
            )
            `(,op (
               ,@(map (lambda (p s x)
                        `(,(car p)
                           (ir-macro-rules ,s ((_ ,@(cdr p))
                             (begin ,@x)))))
                      pats syms xprs)
               )
               ,@body)))))))

;The following macro can be used to simplify renaming.
;Its syntax is similar to Graham's with-gensyms but more flexible
;because of the extra op argument, which is mostly rename.
;
;;; (with-aliases (op %sym0 %sym1 ...) . body)
;;; ------------------------------------------
;;; executes body with aliases of sym0 sym1 ...
(define-syntax with-aliases
  (er-macro-transformer
    (lambda (f r c?)
      (let (
        (rename (caadr f))
        (%syms (cdadr f))
        (body (cddr f))
        (%let (r 'let))
        )
        (let ((syms (map (lambda (%sym)
                            (string->symbol
                              (substring (symbol->string %sym) 1)))
                    %syms)))
          `(,%let ,(map (lambda (%sym sym) `(,%sym (,rename ',sym)))
                      %syms syms)
             ,@body))))))

;;; documentation in dispatcher

(define low-level-macros
  (let (
    (alist '(
      (er-macro-rules
        "explicit-renaming variant of syntax-rules"
        (er-macro-rules (%sym ...) (pat0 xpr0) (pat1 xpr1) ...)
           "the macro's use is matched against patterns pat0 pat1 ... in
sequnce and the xpr of the first matching pat is executed
with renamed versions %sym ... of sym ...") 
      (ir-macro-rules
        "implicit-renaming variant of syntax-rules"
        (ir-macro-rules (sym ...) (pat0 xpr0) (pat1 xpr1) ...)
           "the macro's use is matched against patterns pat0 pat1 ... in
sequnce and the xpr of the first matching pat is executed
with injected - i.e. not renamed - symbols sym ...") 
      (define-macro
        "explicit or implicit renaming variant of define-macro"
        (define-macro code (with-renamed (%sym ...) . body))
        "the macro's use, code, is transformed to the macro-expansion with body
which can refer to renamed symbols %sym ... of sym ..."
        (define-macro code (with-injected (sym ...) . body))
        "the macro's use, code, is transformed to the macro-expansion with body
which can refer to injected symbols sym ..."
        (define-macro code . body)
        "the same as (define-macro code (with-injected () . body")
      (macro-let
        "local parallel version of define-macro"
        (macro-let ((code0 (with-renamed (%sym0 ...) . body0)) ...)
          . body)
        "pairs code to transformer body in parallel"
        (macro-let ((code0 (with-injected (sym0 ...) . body0)) ...)
          . body)
        "pairs code to transformer body in parallel"
        (macro-let ((code xpr . xprs) ...) . body)
        "pairs code to transformer body in parallel")
      (macro-letrec
        "local recursive version of define-macro"
        (macro-letrec ((code0 (with-renamed (%sym0 ...) . body0)) ...)
          . body)
        "pairs code to transformer body recursively"
        (macro-letrec ((code0 (with-injected (sym0 ...) . body0)) ...)
          . body)
        "pairs code to transformer body recursively"
        (macro-letrec ((code xpr . xprs) ...) . body)
        "pairs code to transformer body recursively")
      (with-aliases
        "defines and uses aliases of symbols"
        (with-aliases (op %sym0 %sym1 ...) . body)
        "executes body with aliases of sym0 sym1 ...")
      )))
    (case-lambda
      (() (map car alist))
      ((sym)
       (let ((pair (assq sym alist)))
         (if pair
           (cdr pair)
           (print "Choose one of " (map car alist))))))))

) ; module low-level-macros