;;; File: ir-macros.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Jun 20, 2011
;;;;       Jun 22, 2011
;;;;       Jul 11, 2011
;;;;       Jul 22, 2011


;This module does to implicit renaming macros, which are new to
;chicken-4.7.0, what the er-macros module did to explicit renaming ones.
;
(require 'contracts)

(module ir-macros
  (ir-macros ir-macro-define ir-macro-define-with-contract ir-macro-let ir-macro-letrec)
(import scheme contracts)
(import-for-syntax (only contracts syntax-contract ir-macro-rules))

;As an application of the ir-macro-rules macro from the contracts module
;we'll implement some further macros which will make the writing of
;implicit-renaming macros easier. For example, ir-macro-define will have
;the same syntax as define-macro from earlier Chicken implementations,
;so that an implementation of an or macro would look as follows:

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

;;; initialize documentation
(doclist '())

;;; (ir-macro-define code xpr . xprs) 
;;; ---------------------------------
;;; where code is the complete macro-code (name . args), i.e. the
;;; pattern of a macro call, and xpr . xprs expressions which generate
;;; the macro-expansion. In case the body xpr . xprs is of the form
;;; (with (sym ...) xpr . xprs) the local namespace is polluted by 
;;; unhygienic injected symbols sym ...
(define-syntax-with-contract ir-macro-define
  "implicit reanaming variant of syntax-rules"
  (syntax-rules (with-injected)
    ((_ (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)
     (ir-macro-define (name . args) (with-injected () xpr . xprs)))))

;A contract checked version of ir-macro-define follows.
;
;;; (ir-macro-define-with-contract code [docstring] . body) 
;;; -------------------------------------------------------
(define-syntax-with-contract ir-macro-define-with-contract
  (syntax-contract (ir-macro-define-with-contract code xpr . xprs)
    "a contract checked variant of ir-macro-define")
  (ir-macro-transformer
    (lambda (f i c?)
    (let ((code (cadr f)) (body (cddr f)))
     (let ((start (car body)))
       (let (
         (name (car code))
         (docstring (if (string? start) start ""))
         (body (if (string? start) (cdr body) body))
         (icode (cons '_ (cdr code)))
         )
         (if (c? (caar body) 'with-injected)
         `(begin 
            (doclist
              (cons
                (append (list ',name
                              (list ',icode ,docstring)))
                (doclist)))
            (define-syntax ,name
              (ir-macro-transformer
                (lambda (form inject compare?)
                  (let ,(map (lambda (sym) `(,sym (inject ',sym))) (cadar body)) 
                    (bind ,code (cons (inject (car form)) (cdr form))
                                ;form
                      ,@(cddar body)))))))
         `(begin
            (doclist
              (cons
                (append (list ',name
                              (list ',icode ,docstring)))
                (doclist)))
            (define-syntax ,name
              (ir-macro-transformer
                (lambda (form inject compare?)
                  (bind ,icode (cons (inject (car form)) (cdr form))
                               ;form
                    ,@body))))))))))))

;ir-macro-let and ir-macro-letrec are local versions of ir-macro-define,
;where the local macros are evaluated in parallel or recursively. For
;example

;  (let ((f (lambda (n) (+ n 10))))
;    (ir-macro-let (
;      ((f n) n)
;      ((g n) `(f ,n))
;      )
;      (display (list (f 1) (g 1))) (newline)))
;
;will result in (1 11) while  
;
;  (let ((f (lambda (n) (+ n 10))))
;    (ir-macro-letrec (
;      ((f n)  n)
;      ((g n) `(f ,n))
;      )
;      (display (list (f 1) (g 1))) (newline)))
;
;returns (1 1).
;
;;; (helper op pairs . body)
;;; ------------------------
;;; Since ir-macro-let and ir-macro-letrec have the same code except
;;; that the former evaluates to a let-syntax and the latter to a
;;; letrec-syntax, this helper starts with the op argument, which is to
;;; be replaced by either let-syntax or letrec-syntax.
(define-syntax 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)))))))

;;; (ir-macro-let ((code xpr . xprs) ...) . body)
;;; ---------------------------------------------
;;; where code and xpr . xprs are as in ir-macro-define. This is
;;; a local version of ir-macro-define, allowing a list of
;;; (code xpr . xprs) lists to be processed in body in parallel.
(define-syntax-with-contract ir-macro-let
  "implicit-renaming macro-let, pairing macro-code with macro-body
in the declaration part"
  (syntax-rules ()
    ((_ ((code xpr . xprs) ...) . body)
     (helper let-syntax ((code xpr . xprs) ...) . body))))

;;; (ir-macro-letrec ((code xpr . xprs) ...) . body)
;;; ------------------------------------------------
;;; where code and xpr . xprs are as in ir-macro-define.
;;; Local version of ir-macro-define, allowing a list of
;;; (code xpr . xprs) lists to be processed in body recursively.

(define-syntax-with-contract ir-macro-letrec
  "implicit-renaming macro-letrec, pairing macro-code with macro-body
in the declaration part"
  (syntax-rules ()
    ((_ ((code xpr . xprs) ...) . body)
     (helper letrec-syntax ((code xpr . xprs) ...) . body))))

;;; save documentation
(define ir-macros (doclist->dispatcher (doclist)))

) ; module ir-macros