; Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2013-2016, 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.

#|[
This library will provide some macro-writing macros, in particular
macro-rules and define-macro, based on explicit- and implicit-renaming.
The syntax of macro-rules mimics that of syntax-rules, except that it
allows for injected symbols before the keyword list and the templates
are usually quasiquoted lists. Since we use bind-case from the bindings
egg, this library accepts wildcards, non-symbol literals and fenders.
]|#

(require-library bindings basic-sequences)

(module procedural-macros
  (define-macro macro-rules macro-let macro-letrec once-only
   define-ir-macro-transformer define-er-macro-transformer
   with-mapped-symbols with-gensyms procedural-macros)
  
  (import scheme
          (only bindings bind-case)
          (only chicken print error case-lambda))

#|[
Let's start with some helpers which might be occasionally useful
]|#

;;; (define-er-macro-transformer form rename compare?)
;;; --------------------------------------------------
;;; wrapper around er-macro-transformer
(define-syntax define-er-macro-transformer
  (syntax-rules ()
    ((_ (name form rename compare?) xpr . xprs)
     (define-syntax name
       (er-macro-transformer
         (lambda (form rename compare?) xpr . xprs))))))

;;; (define-ir-macro-transformer form inject compare?)
;;; --------------------------------------------------
;;; wrapper around ir-macro-transformer
(define-syntax define-ir-macro-transformer
  (syntax-rules ()
    ((_ (name form inject compare?) xpr . xprs)
     (define-syntax name
       (ir-macro-transformer
         (lambda (form inject compare?) xpr . xprs))))))

;;; (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
;;; -------------------------------------------------------------
;;; binds a series of prefixed names, prefix-x ....
;;; to the images of the original names, x ...., under mapper
;;; and evaluates xpr .... in this context
(define-syntax with-mapped-symbols
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((mapper (cadr form))
            (prefix (caddr form))
            (syms (cadddr form))
            (xpr (car (cddddr form)))
            (xprs (cdr (cddddr form)))
            (%let (rename 'let)))
        (let ((strip-prefix
                (lambda (sym)
                  (let ((len (string-length (symbol->string prefix))))
                    (string->symbol
                      (substring (symbol->string sym) len))))))
          `(,%let ,(map (lambda (s)
                          `(,s (,mapper ',(strip-prefix s))))
                        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)))))

#|[
The workhorse of the library is the following macro, a procedural
version of syntax-rules, but without its limitations.
]|#

;;; (macro-rules sym ... (key ...) (pat (where fender ...) .. tpl) ....)
;;; --------------------------------------------------------------------
;;; where sym ... are injected non-hygienig symbols, key ... are
;;; additional keywords, pat ....  are nested lambda-lists without
;;; spezial meaning of ellipses and tpl .... usually evaluate to
;;; quasiquoted templates. The optional fenders belong to the pattern
;;; matching process.
(define-syntax macro-rules
  (er-macro-transformer
    (lambda (f r c?)
      (let (
        (f* (let loop ((tail (cdr f)) (head '()))
              (if (symbol? (car tail))
                (loop (cdr tail) (cons (car tail) head))
                (cons head tail))))
        (filter
          (lambda (ok? lst)
            (compress (map ok? lst) lst)))
        (flatten*
          ; imported flatten doesn't work with pseudo-lists
          (lambda (tree)
            (let loop ((tree tree) (result '()))
              (cond
                ((pair? tree)
                 (loop (car tree) (loop (cdr tree) result)))
                ((null? tree) result)
                (else
                  (cons tree result))))))
        (%x (r 'x))
        (%let (r 'let))
        (%form (r 'form))
        (%where (r 'where))
        (%lambda (r 'lambda))
        (%inject (r 'inject))
        (%compare? (r 'compare?))
        (%bind-case (r 'bind-case))
        (%ir-macro-transformer (r 'ir-macro-transformer))
        )
        (let ((syms (car f*))
              (keys (cadr f*))
              (rules (cddr f*)))
          (let* ((pats (map car rules))
                 (fpats (map flatten* pats))
                 (kpats (map (lambda (fp)
                               (filter (lambda (x)
                                         (memq x keys))
                                       fp))
                             fpats))
                 ;; compare? keywords with its names
                 (key-checks
                   (map (lambda (kp)
                          (map (lambda (p s)
                                 `(,p (,%lambda (,%x)
                                                (,%compare? ,%x ,s))))
                               kp
                               (map (lambda (x) `',x)
                                    kp)))
                        kpats))
                 ;; prepare where clause for each rule
                 ;; to check keys
                 (all-rules (map (lambda (rule checks)
                                   (let ((second (cadr rule)))
                                     (if (and (pair? second)
                                              (c? (car second) %where))
                                       `(,(car rule)
                                          (,%where ,@(cdr second) ,@checks)
                                          ,@(cddr rule))
                                       `(,(car rule)
                                          (,%where ,@checks)
                                          ,@(cdr rule)))))
                                 rules key-checks)))
            `(,%ir-macro-transformer
               (,%lambda (,%form ,%inject ,%compare?)
                 (,%let ,(map (lambda (s)
                           `(,s (,%inject ',s)))
                         syms)
                   (,%bind-case ,%form
                                ,@all-rules))))))))))

#|[
And now a hygienic procedural version of our old friend, define-macro,
accepting fenders in where clauses.
]|#

;;; (define-macro (name . args) (where fender ...) .. xpr ....)
;;; -----------------------------------------------------------
;;; simple hygienic macro without injections and keywords.
(define-er-macro-transformer (define-macro form rename compare?)
  (let ((code (cadr form))
        (xpr (caddr form))
        (xprs (cdddr form));)
        (%macro-rules (rename 'macro-rules))
        (%define-syntax (rename 'define-syntax)))
    `(,%define-syntax ,(car code)
       (,%macro-rules ()
         ((_ ,@(cdr code)) ,xpr ,@xprs)))))

#|[
Now follow the local versions of define-macro, macro-let and
macro-letrec. Since the syntax of both is identical, they are
implemented by means of a helper macro.
]|#

;; helper for macro-let and macro-letrec
(define-er-macro-transformer (macro-with form rename compare?)
  (let ((op (cadr form))
        (pat-tpl-pairs (caddr form))
        (xpr (cadddr form))
        (xprs (cddddr form))
        (%macro-rules (rename 'macro-rules)))
    (let ((pats (map car pat-tpl-pairs))
          (tpls (map cdr pat-tpl-pairs)))
      `(,op ,(map (lambda (pat tpl)
                    `(,(car pat)
                       (,%macro-rules ()
                         ((_ ,@(cdr pat)) ,@tpl))))
                  pats tpls)
                   ,xpr ,@xprs))))

;;; (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
;;; -------------------------------------------------------------------------
;;; evaluates body ... in the context of parallel macros name ....
(define-er-macro-transformer (macro-let form rename compare?)
  (let ((pat-tpl-pairs (cadr form))
        (xpr (caddr form))
        (xprs (cdddr form));)
        (%macro-with (rename 'macro-with))
        (%let-syntax (rename 'let-syntax)))
    `(,%macro-with ,%let-syntax ,pat-tpl-pairs ,xpr ,@xprs)))

;;; (macro-letrec (((name . args) (where fender ...) .. xpr ...) ...) body ....)
;;; ----------------------------------------------------------------------------
;;; evaluates body ... in the context of recursive macros name ....
(define-er-macro-transformer (macro-letrec form rename compare?)
  (let ((pat-tpl-pairs (cadr form))
        (xpr (caddr form))
        (xprs (cdddr form));)
        (%macro-with (rename 'macro-with))
        (%letrec-syntax (rename 'letrec-syntax)))
    `(,%macro-with ,%letrec-syntax ,pat-tpl-pairs ,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-ir-macro-transformer (once-only form inject compare?)
  (let ((names (cadr form))
        (body (cddr form)))
    (let ((gensyms (map (lambda (x) (gensym)) names)))
      `(let ,(map (lambda (g) `(,g (gensym))) gensyms)
         `(let ,(list ,@(map (lambda (g n) ``(,,g ,,n))
                             gensyms names))
            ,(let ,(map (lambda (n g) `(,n ,g))
                        names gensyms)
               ,@body))))))

;;; (procedural-macros sym ..)
;;; -----------------------
;;; documentation procedure.
(define procedural-macros
  (let ((alst '(
    (macro-rules
      macro:
      (macro-rules literal ... (keyword ...) (pat (where fender ...) .. tpl) ....)
      "procedural version of syntax-rules"
      "with optional injected literals"
      "and quasiquoted templates")
    (define-macro
      macro:
      (define-macro (name . args) (where fender ...) .. xpr ....)
      "a version of macro-rules with only one rule"
      "no injected symbols and no keywords")
    (macro-let
      macro:
      (macro-let (((name . args) (where fender ...) .. xpr ...) ...) body ....)
      "evaluates body ... in the context of parallel macros name ....")
    (macro-letrec
      macro:
      (macro-letrec (((name . args) (where fender ...) .. 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 ....")
    (define-er-macro-transformer
      macro:
      (define-er-macro-tansformer name form rename compare?)
      "wrapper around er-macro-transformer")
    (define-ir-macro-transformer
      macro:
      (define-ir-macro-tansformer name form rename compare?)
      "wrapper around ir-macro-transformer")
    (with-mapped-symbols
      macro:
      (with-mapped-symbols mapper prefix- (prefix-x ....) xpr ....)
      "binds a series of prefixed names, prefix-x ...."
      "to the images of the original names, x ...., under mapper"
      "and evaluates xpr .... in this context")
    (with-gensyms
      macro:
      (with-gensyms (x ....) xpr ....)
      "generates a series of gensyms x .... to be used in body xpr ...")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'procedural-macros
                  "not exported" sym)))))))
) ; procedural-macros