; Author: Juergen Lorenz ; ju (at jugilo (dot) de
;
; Copyright (c) 2013-2020, 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 dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser 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 procedural-macros (
  define-macro
  macro-rules
  macro-let
  macro-letrec
  once-only
  with-renamed-symbols
  with-gensyms
  procedural-macros
  )

(import scheme
        bindings
        (only (chicken base) print error case-lambda))
(import-for-syntax (only bindings bind bind-case)
                   (only (chicken keyword) string->keyword))

;;; (define-macro signature
;;;   (with-renaming (compare? . %syms)
;;;     xpr . xprs))
;;; (define-macro signature
;;;   xpr . xprs)
;;; ---------------------------------
;;; where with-renaming is either
;;; with-implicit- or with-explicit-renaming.
;;; If not given and no keys are needed, with-implict-renaming is used.
;;; Defines an explicit- or implicit-renaming macro name
;;; with use-form signature.
(define-syntax define-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((signature (cadr f))
            ;(transformer (caddr f)))
            (first (caddr f))
            (%compare? (r 'compare?))
            (%with-explicit-renaming (r 'with-explicit-renaming))
            (%with-implicit-renaming (r 'with-implicit-renaming))
            )
        (let ((transformer
                (cond
                  ((c? (car first) %with-explicit-renaming)
                   first)
                  ((c? (car first) %with-implicit-renaming)
                   first)
                  (else
                    `(,%with-implicit-renaming (,%compare?)
                                               ,@(cddr f))))))
          ;(print "TTT " transformer)
          (let ((with-renaming (car transformer)) 
                (symbols (cadr transformer))
                (xpr (caddr transformer))
                (xprs (cdddr transformer))
                (%let (r 'let))
                (%cdr (r 'cdr))
                (%bind (r 'bind))
                (%lambda (r 'lambda))
                (%form (r 'form))
                (%rename (r 'rename))
                (%inject (r 'inject))
                (%er-macro-transformer (r 'er-macro-transformer))
                (%ir-macro-transformer (r 'ir-macro-transformer))
                (%define-syntax (r 'define-syntax))
                (%with-renaming (r 'with-renaming))
                )
            (let ((transform
                    (cond
                      ((c? with-renaming %with-explicit-renaming)
                       %rename)
                      ((c? with-renaming %with-implicit-renaming)
                       %inject)
                      (else
                        (error "invalid renaming type" with-renaming))))
                  (macro-transformer
                    (cond
                      ((c? with-renaming %with-explicit-renaming)
                       %er-macro-transformer)
                      ((c? with-renaming %with-implicit-renaming)
                       %ir-macro-transformer)
                      (else
                        (error "invalid renaming type" with-renaming))))
                  )
              `(,%define-syntax ,(car signature)
                 (,macro-transformer
                   (,%lambda (,%form ,transform ,%compare?)
                     (,%bind ,(cdr signature) (,%cdr ,%form)
                       (,%let ((,(car symbols) ,%compare?)
                               ,@(map (lambda (s)
                                        `(,s (,transform
                                               ',(string->symbol
                                                   (substring
                                                     (symbol->string s) 1)))))
                                      (cdr symbols)))
                         ,xpr ,@xprs)))))
              )))))))

;;; (macro-rules sym ... (key ...) (pat tpl) ....)
;;; ----------------------------------------------
;;; where sym ... are injected non-hygienic symbols, key ... are
;;; additional keywords, pat ....  are nested lambda-lists without
;;; spezial meaning of ellipses and tpl .... usually evaluate to
;;; quasiquoted templates. To be imported for syntax.
;;; The implementation transfforms keys to keywords and uses bind-case's
;;; property to match equal literals.
(define-syntax macro-rules
  (er-macro-transformer
    (lambda (f r c?)
      (receive (syms tail)
        (let loop ((tail (cdr f)) (head '()))
          (if (symbol? (car tail))
            (loop (cdr tail) (cons (car tail) head))
            (values (reverse head) tail)))
        (let ((keys (car tail))
              (rules (cdr tail))
              (%let (r 'let))
              (%form (r 'form))
              (%lambda (r 'lambda))
              (%inject (r 'inject))
              (%compare? (r 'compare?))
              (%bind-case (r 'bind-case))
              (%ir-macro-transformer (r 'ir-macro-transformer))
              (map*
                (lambda (fn tree)
                  (let recur ((tree tree))
                    (cond
                      ((pair? tree)
                       (cons (recur (car tree))
                             (recur (cdr tree))))
                      ((symbol? tree) (fn tree))
                      (else tree)))))
              (symbol->keyword
                (lambda (sym)
                  (string->keyword (symbol->string sym))))
              (memp
                (lambda (ok? lst)
                  (let loop ((lst lst))
                    (cond
                      ((null? lst) #f)
                      ((ok? (car lst)) lst)
                      (else (loop (cdr lst)))))))
              )
          (let* ((keys->keywords
                  (lambda (sym)
                    (let ((syms (memp (lambda (x)
                                        (c? x (r sym)))
                                      keys)))
                      (if syms
                        (symbol->keyword (car syms))
                        sym))))
                 (rewrite-keys
                   (lambda (form)
                     (map* keys->keywords form)))
                 )
         ;(print "XXX " (rewrite-keys f))
            `(,%ir-macro-transformer
               (,%lambda (,%form ,%inject ,%compare?)
                 (,%let ,(map (lambda (s)
                                `(,s (,%inject ',s)))
                         syms)
         ;(print "FFF " ,%form)
         ;(print "SSS " (,rewrite-keys ,%form))
         ;(print "TTT " ,(rewrite-keys %form))
                     (,%bind-case ;,%form ,@rules)
                       ;,%form
                       (,rewrite-keys ,%form)
                       ;,(rewrite-keys %form)
                       ,@(map (lambda (c d)
                                (cons (rewrite-keys c)
                                      d))
                              (map car rules) (map cdr rules))))))
            ))))))  


#|[
Now follow the local versions of define-macro, macro-let and
macro-letrec.
]|#

;;; (macro-let (((signature body) ...) ...) xpr ....)
;;; --------------------------------------------------
;;; evaluates xpr ... in the context of parallel macros name ....
;(define-macro (macro-let signature-body-list xpr . xprs) 
;  (with-explicit-renaming (compare? %let-syntax %macro-rules)
(define-macro (macro-let signature-body-list xpr . xprs) 
  (with-explicit-renaming (compare? %let-syntax %macro-rules)
    (let ((signatures (map car signature-body-list))
          (bodies (map cdr signature-body-list)))
      `(,%let-syntax ,(map (lambda (sig body)
                                `(,(car sig)
                                  (,%macro-rules () 
                                    (,(cons '_ (cdr sig)) ,@body))))
                             signatures bodies)
         ,xpr ,@xprs))))

;;; (macro-letrec (((signature body) ...) ...) xpr ....)
;;; ----------------------------------------------------
;;; evaluates xpr ... in the context of recursive macros name ....
(define-macro (macro-letrec signature-body-list xpr . xprs) 
  (with-explicit-renaming (compare? %letrec-syntax %macro-rules)
    (let ((signatures (map car signature-body-list))
          (bodies (map cdr signature-body-list)))
      `(,%letrec-syntax ,(map (lambda (sig body)
                                `(,(car sig)
                                  (,%macro-rules () 
                                    (,(cons '_ (cdr sig)) ,@body))))
                             signatures bodies)
         ,xpr ,@xprs))))

;;; (once-only (x ....) xpr ....)
;;; -----------------------------
;;; macro-arguments x .... are only evaluated once and from left to
;;; right in the body xpr ....
;;; The code is more or less due to
;;; P. Seibel, Practical Common Lisp, p. 102
(define-syntax once-only
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((syms (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        (let ((%syms (map rename syms))
              (%let (rename 'let))
              (%list (rename 'list)))
          `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) %syms)
             `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
                                   %syms syms))
                ,(,%let ,(map (lambda (n g) `(,n ,g))
                            syms %syms)
                   ,xpr ,@xprs))))))))

;;; (with-renamed-symbols (renamer . %syms) xpr . xprs)
;;; ---------------------------------------------------
(define-syntax with-renamed-symbols
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((syms (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form))
            )
        (let ((renamer (car syms))
              (%syms (cdr syms))
              (%let (rename 'let))
              )
          `(,%let ,(map (lambda (s)
                          ;`(,(symbol-append prefix s) (,renamer ',s)))
                          `(,s (,renamer
                            ',(string->symbol
                               (substring (symbol->string s) 1)))))
                        %syms)
             ,xpr ,@xprs))))))

;;; (with-gensyms (name ....) xpr ....)
;;; -----------------------------------
;;; binds name ... to (gensym 'name) ... in body xpr ...
(define-syntax with-gensyms
  (ir-macro-transformer
    (lambda (form inject compare?)
      `(let ,(map (lambda (n) `(,n (gensym ',n))) (cadr form))
         ,@(cddr form)))))

;;; (procedural-macros sym ..)
;;; --------------------------
;;; documentation procedure.
(define procedural-macros
  (let ((alst '(
    (macro-rules
      macro:
      (macro-rules literal ... (keyword ...) (pat tpl) ....)
      "procedural version of syntax-rules"
      "with optional injected literals"
      "and quasiquoted templates"
      "To be imported for syntax")
    (define-macro
      macro:
      (define-macro (name . args) (with-renaming (compare? %x ...) xpr ....))
      (define-macro (name . args) xpr ....)
      "where with-renaming is one of with-explicit- or with-implicit-renaming"
      "and %x ... is the symbol x prefixed with one letter only."
      "Defines an explicit- or implicit-renaming macro name,"
      "automatically destructuring args with bind and creating local bindings"
      "for compare? and %x ... to x ... renamed or injected respectively,"
      "evaluating xpr ... in this context."
      "The latter version is used if no keys are needed and nothing is"
      "to be injected")
    (macro-let
      macro:
      (macro-let (((name args) xpr ...) ...) body ....)
      "evaluates body ... in the context of parallel macros name ....")
    (macro-letrec
      macro:
      (macro-letrec (((name args) xpr ...) ...) body ....)
      "evaluates body ... in the context of recursive macros name ....")
    (once-only
      macro:
      (once-only (x ....) xpr ....)
      "arguments x ... are evaluated only once and"
      "from left to right in the body xpr ...."
      "To be imported for syntax")
    (with-renamed-symbols
      macro:
      (with-renamed-symbols (renamer %x ....) xpr ....)
      "binds a series of names prefixed with one letter, e.g. %,
      %x .... to the images of the original names, x ....,"
      "under renamer and evaluates xpr .... in this context"
      "To be imported for syntax")
    (with-gensyms
      macro:
      (with-gensyms (x ....) xpr ....)
      "binds x ... to (gensym 'x) ... in body xpr ...")
    (procedural-macros
      procedure:
      "documaentation procedure: returns the list of exported symbols"
      "if called with no arguments, or the documentation of its only"
      "symbol argument")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'procedural-macros
                  "not exported" sym)))))))

) ; module procedural-macros