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

#|[
In his macro bible "On Lisp, p. 232" Paul Graham implemented a beautiful macro,
dbind, which is roughly Common Lisp's destructuring-bind. It invokes
at compile time the following three procedures in Scheme (for lists only).

  (define (destruc pat seq)
    (let loop ((pat pat) (seq seq) (n 0))
      (if (pair? pat)
        (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
          (if (symbol? p)
            (cons `(,p (list-ref ,seq ,n)) recu)
            (let ((g (gensym)))
              (cons (cons `(,g (list-ref ,seq ,n))
                          (loop p g 0))
                    recu))))
        (let ((tail `(list-tail ,seq ,n)))
          (if (null? pat)
            '()
            `((,pat ,tail)))))))
  
  (define (dbind-ex binds body)
    (if (null? binds)
      `(begin ,@body)
      `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
                  binds)
         ,(dbind-ex
            (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                     binds)
            body))))

  (define (mappend fn lists)
    (apply append (map fn lists)))

Graham's code works as follows: First, destruc traverses the pattern and
groups each symbol with the location of a runtime object, using gensyms
to step down the pattern while grouping the gensym bound object with all
pairs depending on this gensym. So, for example,

  (destruc '(a (b . c) . d) 'seq)

will result in

  ((a (list-ref seq 0))
   ((#:g (list-ref seq 1)) (b (list-ref #:g 0)) (c (list-tail #:g 1)))
   (d (list-tail seq 2)))

This tree is then transformed via dbind-ex into a nested let to produce
dbind's result

  (let ((a (list-ref seq 0))
        (#:g (list-ref seq 1))
        (d (list-tail seq 2)))
    (let ((b (list-ref #:g 0))
          (c (list-tail #:g 1)))
      body))
 
This library will provide some macro-writing macros, in particular
macro-rules and define-macro, based on implicit-renaming and the local
procedures above, without a detour over bind and friends and sequences
of the bindings library. Indeed, for macro-writing macros lists are
sufficient. But off course, I have to provide some extensions to Graham's code,
length checks, wildcards, non-symbol literals, as in the bindings egg.
wildcards and nonsymbol literals bind nothing, the former matching
anything, the latter only expressions evaluating to themselfs.

The last feature missing is fenders, which is important in particular
for macro-rules and can easily be implemented with a where clause: A
pattern matches successfully if only each pattern variable can be bound
and the where clause is satisfied. If the where clause doesn't pass the
next pattern is tried.

]|#

(module procedural-macros
  (define-macro macro-rules macro-let macro-letrec once-only with-gensyms)
  (import scheme
          (only chicken print error case-lambda condition-case))
  (import-for-syntax
    (only chicken condition-case))

#|[
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
  (ir-macro-transformer
    (lambda (f i c?)
      (letrec (
        (filter
          (lambda (ok? lst)
            (let loop ((lst lst) (yes '()) (no '()))
              (if (null? lst)
                (values (reverse yes) (reverse no))
                (let ((first (car lst)) (rest (cdr lst)))
                  (if (ok? first)
                    (loop rest (cons first yes) no)
                    (loop rest yes (cons first no))))))))
        (mappend
          (lambda (fn lists)
            (apply append (map fn lists))))
        (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))))))
        (destruc
          (lambda (pat seq)
            (let loop ((pat pat) (seq seq) (n 0))
              (cond
                ((pair? pat)
                 (let ((p (car pat)) (recu (loop (cdr pat) seq (+ n 1))))
                   (cond
                     ((symbol? p)
                      (if (c? p '_)
                        ;; skip
                        recu
                        `((,p (list-ref ,seq ,n)) ,@recu)))
                     ((pair? p)
                      (let ((g (gensym)))
                        `(((,g (list-ref ,seq ,n)) ,@(loop p g 0))
                           ,@recu)))
                     (else
                       `((,p (equal? ',p (list-ref ,seq ,n)))
                         ,@recu))
                     )))
                ((symbol? pat)
                 `((,pat (list-tail ,seq ,n))))
                ((null? pat)
                 `((,pat (null? (list-tail ,seq ,n)))))
                ))))
        (dbind-ex
          (lambda (binds body)
            (if (null? binds)
              ;`(begin ,@body)
              body
              (call-with-values
                (lambda ()
                  (filter (lambda (pair) (symbol? (car pair)))
                          (map (lambda (b) (if (pair? (car b)) (car b) b))
                               binds)))
                (lambda (defs checks)
                  `(let ,defs
                     (if (and ,@(map cadr checks))
                       ,(dbind-ex
                          (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                                   binds)
                          body)
                       (error 'dbind-ex
                              "match error"
                              `(and ,@(map cadr ',checks))))))
                ))))
        )
        (let ((f* (let loop ((tail (cdr f)) (head '()))
                    (if (symbol? (car tail))
                      (loop (cdr tail) (cons (car tail) head))
                      (cons head tail)))))
          (let ((syms (car f*))
                (keys (cadr f*))
                ;; insert empty where clause into each rule without one
                ;; to simplify matters via standardization
                (all-rules (map (lambda (rule)
                                  (let ((second (cadr rule)))
                                    (if (and (pair? second)
                                             (c? (car second) 'where))
                                      rule
                                      `(,(car rule) (where #t) ,@(cdr rule)))))
                                (cddr f*)))
                (gform 'form))
            `(ir-macro-transformer
               (lambda (form inject compare?)
                 (let ,(map (lambda (s)
                              `(,s (inject ',s)))
                            syms)
                   ,(let loop ((rules all-rules))
                      (if (null? rules)
                        `(error 'macro-rules
                                "no rule matches"
                                form
                                'in
                                ',(map (lambda (rule)
                                         `(,(car rule) ; pattern
                                           ,(cadr rule))) ; where clause
                                       all-rules))
                        (let ((rule (car rules)))
                          `(condition-case
                             ,(dbind-ex
                                (condition-case (destruc (car rule) gform)
                                  ((exn) (loop (cdr rules))))
                                (let* ((pat (car rule))
                                       (fpat (flatten* pat))
                                       (kpat (filter (lambda (x)  ;;;;
                                                       (memq x keys))
                                                     fpat))
                                       ;; compare? keywords with its names
                                       (key-checks
                                         (map (lambda (p s)
                                                `(compare? ,p ,s))
                                              kpat
                                              (map (lambda (x) `',x)
                                                   kpat))))
                                  (let* ((tpl (cdr rule))
                                         (fenders
                                           (append key-checks
                                                   (cdar tpl))))
                                    `(if (and ,@fenders)
                                        ,@(cdr tpl)
                                        ,(loop (cdr rules))))))
                             ((exn) ,(loop (cdr 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-syntax define-macro
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((code (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        `(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-syntax macro
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((op (cadr form))
            (pat-tpl-pairs (caddr form))
            (xpr (cadddr form))
            (xprs (cddddr form)))
        (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-syntax macro-let
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat-tpl-pairs (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        `(macro 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-syntax macro-letrec
  (ir-macro-transformer
    (lambda (form inject compare?)
      (let ((pat-tpl-pairs (cadr form))
            (xpr (caddr form))
            (xprs (cdddr form)))
        `(macro letrec-syntax ,pat-tpl-pairs ,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)))))

;;; (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
  (ir-macro-transformer
    (lambda (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 tpl) ....)
      "procedural version of syntax-rules"
      "with optional injected literals"
      "and quasiquoted templates")
    (define-macro
      macro:
      (define-macro (name . args) 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 ....")
    (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