#|[
Author: Juergen Lorenz
ju (at) jugilo (dot) de

Copyright (c) 2013, 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 disclaimer.

Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer 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.
]|#


#|[
First a helper module, which might be useful not only in
low-level-macros.
]|#

(module symbols
  (export symbols prefixed-with? strip-prefix strip-suffix
          extract remove-duplicates adjoin filter flatten memp)
  (import scheme (only chicken case-lambda))

(define (symbols)
  '(prefixed-with? strip-prefix strip-suffix
    extract remove-duplicates adjoin memp filter flatten))

(define (prefixed-with? pre)
  (lambda (id)
    (let ((pre-str (symbol->string pre))
          (id-str (symbol->string id)))
      (let ((pre-len (string-length pre-str)))
        (and (< pre-len (string-length id-str))
             (string=? pre-str
                       (substring id-str 0 pre-len)))))))

(define (strip-prefix pre id)
  (string->symbol
    (substring (symbol->string id)
               (string-length
                 (symbol->string pre)))))

(define (strip-suffix suf id)
  (let ((sufstring (symbol->string suf))
        (idstring (symbol->string id)))
    (string->symbol
      (substring idstring
                 0 
                 (- (string-length idstring)
                    (string-length sufstring))))))

(define (extract ok? tree)
  (remove-duplicates
    (filter ok? (flatten tree))))

(define (memp ok? lst)
  (let loop ((lst lst))
    (if (null? lst)
      #f
      (if (ok? (car lst))
        lst
        (loop (cdr lst))))))

(define (filter ok? lst)
  (let loop ((lst lst) (result '()))
    (if (null? lst)
      (reverse result)
      (let ((first (car lst)) (rest (cdr lst)))
        (if (ok? first)
          (loop rest (cons first result))
          (loop rest result))))))

(define (flatten tree)
  (let loop ((tree tree) (result '()))
    (cond
      ((null? tree) result)
      ((not (pair? tree)) (cons tree result))
      (else
        (loop (car tree) (loop (cdr tree) result))))))

(define (remove-duplicates lst)
  (let loop ((lst lst) (result '()))
    (if (null? lst)
      (reverse result)
      (loop (cdr lst) (adjoin (car lst) result)))))

(define (adjoin obj lst)
  (if (member obj lst) lst (cons obj lst)))

) ; module symbols

#|[
Low-level-macros made easy
==========================
As an application of our binding macros, especially bind and bind-case,
we will now provide macros define-macro, letrec-macro and let-macro as
well as macro-rules to make writing low-level macros easy.
]|#

(module low-level-macros
  (export low-level-macros bind bind-case
          macro-rules define-macro let-macro letrec-macro
          once-only with-gensyms define-syntax-rule)
  (import scheme
          (only chicken condition-case print error))
  (import-for-syntax symbols)

(define (low-level-macros)
  '(bind bind-case macro-rules define-macro let-macro letrec-macro
    once-only with-gensyms define-syntax-rule))

#|[
The following two macros are simplyfied versions of equally named macros
from the bindings module, restricting sequences to lists and
pseudolists. This is sufficient for destructuring macro-arguments.
The first is a variant of Common Lisp's destructuring-bind.
]|#

;;; (bind pat seq (where . fenders) .. xpr . xprs)
;;; ----------------------------------------------
;;; binds pattern variables of pat to corresponding subexpressions of
;;; seq and executes tthe body xpr . xprs in this context. If a where
;;; expression is supplied, all fenders must return #t for seq to be
;;; successfully bound.
(define-syntax bind
  (syntax-rules (where)
    ((_ pat seq (where . fenders) xpr . xprs)
     (bind pat seq
       (if (and . fenders)
         (begin xpr . xprs)
         (error 'bind
                (print seq
                       " doesn't match pattern " 'pat
                       " with fenders " 'fenders)))))
    ((_(a . b) seq xpr . xprs)
     (let ((seq1 seq))
       (if (pair? seq1)
         (bind a (car seq1)
           (bind b (cdr seq1) xpr . xprs))
         (error 'bind
                (print seq1
                       " doesn't match pattern " '(a .  b))))))
    ((_ () seq xpr . xprs)
     (let ((seq1 seq))
       (if (null? seq1)
         (let () xpr . xprs)
         (error 'bind
                (print seq1
                       " doesn't match pattern " '())))))
    ((_ a seq xpr . xprs)
     (let ((seq1 seq))
       (let ((a seq1)) xpr . xprs)))))

#|[
The following macro does more or less the same what the match macro from
the matchable package does, for example

  (bind-case '(1 (2 3))
    ((x y) (where (list? y)) (list x y))
    ((x (y . z)) (list x y z))
    ((x (y z)) (list x y z))) ;-> '(1 2 (3))

or, to give a more realistic example, mapping:

  (define (my-map fn lst)
    (bind-case lst
      (() '())
      ((x . xs) (cons (fn x) (my-map fn xs)))))
]|#

;;; (bind-case seq (pat (where . fenders) .. xpr . xprs) ....)
;;; ----------------------------------------------------------
;;; Checks if seq matches pattern pat [satisfying fenders] ....
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; corresponding body xpr . xprs
(define-syntax bind-case
  (syntax-rules (where)
    ((_ seq (pat (where . fenders) xpr . xprs) . clauses)
     (condition-case
       (bind pat seq (where . fenders) xpr . xprs)
       ((exn) (bind-case seq . clauses))))
    ((_ seq (pat (where . fenders) xpr . xprs))
     (bind pat seq (where . fenders) xpr . xprs))
    ((_ seq (pat xpr . xprs))
     (bind pat seq xpr . xprs))
    ((_ seq (pat xpr . xprs) . clauses)
     (condition-case
       (bind pat seq xpr . xprs)
       ((exn) (bind-case seq . clauses))))
    ((_ seq)
     (error 'bind-case
            (print seq " doesn't match any pattern")))
    ))


;;; (define-macro (name . args)
;;;   [(with-inject-prefix pre | (with-rename-prefix pre)]
;;;     [(with-keywords (x y ...)]
;;;       . body)))
;;; ----------------------------------------------------------------------------
(define-syntax define-macro
  (ir-macro-transformer
    (lambda (f i c?)
      (let ((pat (cadr f)) (body (caddr f)))
        (let (
          (type (cond ((c? (car body) 'with-rename-prefix) 'er)
                      ((c? (car body) 'with-inject-prefix) 'ir)
                      (else 'no)))
          )
          (let (
            (transformer (case type
                           ((er) 'er-macro-transformer)
                           (else 'ir-macro-transformer)))
            (rename-or-inject (case type
                                ((er) 'rename)
                                (else 'inject)))
            (body (case type
                    ((no) body)
                    (else (caddr body))))
            (pre (case type
                   ((no) #f)
                   (else (cadr body))))
            )
            (let ((keywords? (c? (car body) 'with-keywords)))
              (cond
                ((and pre keywords?)
                 (let ((keywords (cadr body)) (body (caddr body)))
                   `(define-syntax ,(car pat)
                      (,transformer
                        (lambda (form ,rename-or-inject compare?)
                          (bind ,(cdr pat) (cdr form)
                            (where ,@(map (lambda (x)
                                             `(compare? ,x ',(i x)))
                                           (extract (lambda (x) 
                                                      (memq x keywords))
                                                    (cdr pat))))
                            (let ,(map (lambda (s)
                                         `(,s (,rename-or-inject
                                                ',(strip-prefix (i pre)
                                                                (i s)))))
                                       (extract (prefixed-with? (i pre))
                                                body))
                              ,body)))))))
                (pre
                 `(define-syntax ,(car pat)
                    (,transformer
                      (lambda (form ,rename-or-inject compare?)
                        (bind ,(cdr pat) (cdr form)
                          (let ,(map (lambda (s)
                                       `(,s (,rename-or-inject
                                              ',(strip-prefix (i pre)
                                                              (i s)))))
                                       (extract (prefixed-with? (i pre))
                                                body))
                            ,body))))))
                (keywords?
                 (let ((keywords (cadr body)) (body (caddr body)))
                   `(define-syntax ,(car pat)
                      (ir-macro-transformer
                        (lambda (form inject compare?)
                          (bind ,(cdr pat) (cdr form)
                            (where ,@(map (lambda (x)
                                             `(compare? ,x ',(i x)))
                                           (extract (lambda (x) 
                                                      (memq x keywords))
                                                   (cdr pat))))
                            ,body))))))
                (else
                 `(define-syntax ,(car pat)
                    (ir-macro-transformer
                      (lambda (form inject compare?)
                        (bind ,(cdr pat) (cdr form)
                          ,body)))))))))))))

;;; (letrec-macro ((macro-code tpl) ...) . body)
;;; --------------------------------------------
;;; defines local macros by binding recursively macro-codes to templates
;;; and evaluating body in this context.
(define-syntax letrec-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((binds (cadr f))
            (body (cddr f))
            (%letrec-syntax (r 'letrec-syntax)))
        `(,%letrec-syntax
           ,(map (lambda (m)
                   `(,(cadr m) ,(caddr m)))
                 (map (lambda (b)
                        (expand `(define-macro ,@b)))
                      binds))
           ,@body)))))

;;; (let-macro ((macro-code tpl) ...) . body)
;;; -----------------------------------------
;;; defines local macros by binding in parallel macro-codes to templates
;;; and evaluating body in this context.
(define-syntax let-macro
  (er-macro-transformer
    (lambda (f r c?)
      (let ((binds (cadr f))
            (body (cddr f))
            (%let-syntax (r 'let-syntax)))
        `(,%let-syntax
           ,(map (lambda (m)
                   `(,(cadr m) ,(caddr m)))
                 (map (lambda (b)
                        (expand `(define-macro ,@b)))
                      binds))
           ,@body)))))

;;; (macro-rules sym ... (keyword ...)
;;;   (pat0 tpl0) (pat1 tpl1) ...)
;;; ----------------------------------
;;; where sym ... are injected non-hygienig symbols, keyword ... are
;;; additionl keywords, pat0 pat1 ...  are nested lambda-lists without
;;; spezial meaning of ellipses and tpl0 tpl1 ... evaluate to
;;; quasiquoted templates.
(define-syntax macro-rules
  (ir-macro-transformer
    (lambda (f i c?)
      ;; head is list of injected syms, tail starts with keyword-list
      (let (
        (tail-head
          (call-with-values
            (lambda ()
              (let loop ((tail (cdr f)) (head '()))
                (if (or (null? tail) (list? (car tail)))
                  (values tail head)
                  (loop (cdr tail) (cons (car tail) head)))))
            list))
        )
        (let ((tail (car tail-head)) (head (cadr tail-head)))
          (let ((keywords (car tail)) (rules (cdr tail)))
            (let (
              (inject-it (lambda (h) `(,h (inject ',h))))
              )
              (cond
                ((and (null? head) (null? keywords))
                 ; no injected symbols, no additional keywords
                 `(ir-macro-transformer
                    (lambda (form inject compare?)
                      (bind-case form ,@rules))))
                      ;(bind-case form ,rule ,@rules))))
                ((null? head)
                 ; no injected symbols
                 `(ir-macro-transformer
                    (lambda (form inject compare?)

                      (bind-case form
                        ,@(map (lambda (rule)
                                `(,(car rule)
                                   (where ,@(map (lambda (x)
                                                   `(compare? ,x ',(i x)))
                                                 (extract (lambda (x) 
                                                            (memq x keywords))
                                                          rule)))
                                   ,(cadr rule)))
                               rules)))))
                ((null? keywords)
                 ;; no additional keywords
                 `(ir-macro-transformer
                    (lambda (form inject compare?)
                      (let ,(map inject-it head)
                        (bind-case form ,@rules)))))
                (else
                  `(ir-macro-transformer
                     (lambda (form inject compare?)
                       (let ,(map inject-it head)
                         (bind-case form
                           ,@(map (lambda (rule)
                                    `(,(car rule)
                                       (where ,@(map (lambda (x)
                                                       `(compare? ,x ',(i x)))
                                                     (extract (lambda (x) 
                                                                (memq x keywords))
                                                              rule)))
                                       ,(cadr rule)))
                                  rules))))))))))))))

#|[
The following three macros are here for convenience. The first two are
of great help in writing low-level-macros, the last ony simplifies
high-level macros without additional keywords and only one rule - it's
defined in miscmacros as well.
]|#

;;; (once-only (x ...) . body)
;;; --------------------------
;;; macro-arguments x ... are only evaluated once and from left to right
(define-syntax once-only  ; ok
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((names (cadr form))
            (body (cddr form))
            (%let (rename 'let))
            (%list (rename 'list))
            (%gensym (rename 'gensym)))
        (let ((gensyms (map gensym names)))
          `(,%let ,(map (lambda (g) `(,g (,%gensym))) gensyms)
             (,%list ',%let ,(cons %list
                               (map (lambda (g n) `(,%list ,g ,n))
                                    gensyms names))
                (,%let ,(map (lambda (n g) `(,n ,g)) names gensyms)
                   ,@body))))))))

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

;;; (define-syntax-rule (macro-code) tpl)
;;; -------------------------------------
;;; simplyfies define-syntax in case there are no auxiliary keywords
;;; and only one syntax-rule.
(define-syntax define-syntax-rule
  (syntax-rules ()
    ((_ (name . args) tpl)
     (define-syntax name
       (syntax-rules ()
         ((_ . args) tpl))))))

) ; module low-level-macros