;;;; File: er-macros.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Oct 24, 2010
;;;;       Oct 28, 2010
;;;;       Nov 02, 2010
;;;;       Nov 04, 2010
;;;;       Nov 09, 2010
;;;;       Nov 26, 2010
;;;;       Nov 28, 2010
;;;;       Jan 19, 2011
;;;;       Jan 27, 2011
;;;;       Feb 02, 2011
;;;;       Feb 16, 2011
;;;;       Feb 18, 2011
;;;;       Jun 20, 2011
;;;;       Jun 22, 2011
;;;;       Jun 26, 2011
;;;;       Jul 13, 2011
;;;;       Jul 23, 2011


;This module does for explicit-renaming macros the same as the module
;ir-macros for implicit-renaming macros.
;
(require 'contracts)

(module er-macros *
(import scheme contracts)
(import-for-syntax (only contracts syntax-contract er-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, er-macro-define 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:

;  (er-macro-define (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 '())

;;; (er-macro-define code (with-renamed (sym% ...) . 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 xpr . xprs which produce the macro-expansion.

(define-syntax-with-contract er-macro-define
  "explicit renaming variant of define-macro"
  (syntax-rules (with-renamed)
    ((_ (name . args) (with-renamed syms xpr . xprs))
     (define-syntax name
       (er-macro-rules syms
         ((_ . args) (begin xpr . xprs)))))))

;A contract checked version of er-macro-define follows. All renaming is
;done by hand since using er-macro-define doesn't work.
;
;;; (er-macro-define-with-contract code
;;;   [docstring] (with-renamed (%sym ...) . body)) 
;;; -----------------------------------------------
(define-syntax-with-contract er-macro-define-with-contract
  (syntax-contract
    (er-macro-define-with-contract code xpr . xprs)
    "a contract checked variant of er-macro-define
where xpr . xprs is [docstring] (with-renamed syms body)")
  (er-macro-transformer
    (lambda (f r 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)))
         (sym-cdr (lambda (%sym)
                    (string->symbol
                      (substring (symbol->string %sym) 1))))
         (%let (r 'let))
         (%begin (r 'begin))
         (%doclist (r 'doclist))
         (%cons (r 'cons))
         (%append (r 'append))
         (%list (r 'list))
         (%define-syntax (r 'define-syntax))
         (%er-macro-transformer (r 'er-macro-transformer))
         (%lambda (r 'lambda))
         (%form (r 'form))
         (%rename (r 'rename))
         (%compare? (r 'compare?))
         (%bind (r 'bind))
         )
         `(,%begin 
            (,%doclist
              (,%cons
                (,%append (,%list ',name
                              (,%list ',icode ,docstring)))
                (,%doclist)))
            (,%define-syntax ,name
              (,%er-macro-transformer
                (,%lambda (,%form ,%rename ,%compare?)
                  (,%let ,(map (lambda (%sym)
                               `(,%sym (,%rename ',(sym-cdr %sym))))
                             (cadar body)) 
                    (,%bind ,code ,%form
                      ,@(cddar body)))))))))))))

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

;  (let ((f (lambda (n) (+ n 10))))
;    (er-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))))
;    (er-macro-letrec (
;      ((f n) n)
;      ((g n) `(,%f ,n))
;      )
;      (display (list (f 1) (g 1))) (newline)))
;
;returns (1 1).

;;; (er-macro-let ((code0 (with-renamed (%sym0 ...) . body0)) ...)
;;;   . body)
;;; --------------------------------------------------------------
;;; where code0, %sym0 and body0 are as in er-macro-define. This is
;;; a local version of er-macro-define, allowing a list of
;;; (code with-xpr) lists to be processed in body in parallel.
(define-syntax-with-contract er-macro-let
  "local version of er-macro-define, declarations evaluated in parallel"
  (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))))


;;; (er-macro-letrec ((code0 (with-renamed (%sym0 ...) . body0) ...)
;;; . body)
;;; ----------------------------------------------------------------
;;; where code0, %sym0 and body0 are as in er-macro-define. This is
;;; a local version of er-macro-define, allowing a list of
;;; (code with-xpr) lists to be processed in body recursively.
(define-syntax-with-contract er-macro-letrec
  "local version of er-macro-define, declarations evaluated recursively"
  (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))))


;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-contract with-aliases
  (syntax-contract (with-aliases (op . %syms) . body)
    "executes body in the scope of %sym ... where %sym is (op sym) ...")
  (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 er-macros (doclist->dispatcher (doclist)))

) ; module er-macros

;(import er-macros contracts)
;
;(doclist '())
;
;;(er-macro-define (my-or . args)
;;  (with-renamed (%if %my-or)
;;    (if (null? args)
;;      #f
;;      (let ((tmp (car args)))
;;        `(,%if ,tmp ,tmp (,%my-or ,@(cdr args)))))))
;
;(er-macro-define-with-contract (my-or . args)
;  "er-macro-define-with-contract"
;  (with-renamed (%if %my-or)
;    (if (null? args)
;      #f
;      (let ((tmp (car args)))
;        `(,%if ,tmp ,tmp (,%my-or ,@(cdr args)))))))
;
;(define-with-contract (foo x)
;  "foo"
;  (domain: (lambda (x) #t))
;  (range: (lambda (result) (equal? result x)))
;  x)
;
;(define docs (doclist->dispatcher (doclist)))