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

(define-syntax define-key-macro ;; internal
  (er-macro-transformer
    (lambda (f r c?)
      (let ((key (cadr f))
            (adjoin
              (lambda (sym syms)
                (if (memq sym syms)
                  syms
                  (cons sym syms))))
            (prefixed?
              (lambda (fix sym)
                (and (symbol? sym)
                  (let ((sfix (symbol->string fix))
                        (ssym (symbol->string sym)))
                    (let ((fixlen (string-length sfix))
                          (symlen (string-length ssym)))
                      (and (< fixlen symlen)
                           (string=? sfix (substring ssym 0 fixlen))))))))
            (%form (r 'form))
            (%rename (r 'rename))
            (%inject (r 'inject))
            (%compare? (r 'compare?))
            (%lambda (r 'lambda))
            (%let (r 'let))
            (%bind-case (r 'bind-case))
            (%define-syntax (r 'define-syntax))
            (%er-macro-transformer (r 'er-macro-transformer))
            (%ir-macro-transformer (r 'ir-macro-transformer))
            (%_ (r '_))
            (%define-key-macro (r 'define-key-macro))
            (%where (r 'where))
            (%key? (r 'key?))
            )
        (let ((transformer
                (case key
                  ((#:er) %er-macro-transformer)
                  ((#:ir) %ir-macro-transformer)))
              (mapper
                (case key
                  ((#:er) %rename)
                  ((#:ir) %inject)))
              (strip-prefix
                (lambda (fix sym)
                  (and (prefixed? fix sym)
                       (string->symbol
                         (substring (symbol->string sym)
                                    (string-length (symbol->string
                                                     fix)))))))
              (extract-prefixed
                (lambda (fix xss)
                  (let ((prefixed '()))
                    (let recur ((xss xss))
                    ;(print "PPP " prefixed)
                      (cond
                        ((pair? xss)
                         (let ((first (car xss)) (rest (cdr xss)))
                           (cond
                             ((pair? first)
                              (recur (car first))
                              (recur (cdr first)))
                             ((null? first)
                              (error 'define-er-macro
                                     "no nil in car position"))
                             (else
                              (set! prefixed
                                (if (prefixed? fix first)
                                  (adjoin first prefixed)
                                  prefixed))))
                           (recur rest)))
                        ((null? xss) prefixed)
                        (else
                          (recur
                            (if (prefixed? fix xss)
                              (adjoin xss prefixed)
                              prefixed)))))))))
          (let ((insert-mapped-symbols
                  (lambda (pat fend fix tpl) ;(fix pat tpl)
                    `(,pat ,fend
                    ;`(,(cons '_ (cdr pat)) ;pat
                       (,%let ,(map (lambda (t)
                                      `(,t (,mapper ',(strip-prefix fix t))))
                                                                    ;(car pat) t))))
                                    (extract-prefixed fix tpl));(car pat) tpl))
                                  ,@tpl)))))
(bind-case (cddr f)
  (((name . args) (where . fenders) prefix xpr . xprs)
   `(,%define-key-macro ,(cadr f)
      ,name ((,%_ ,@args) (,%where ,@fenders) ,prefix ,xpr ,@xprs)))
  (((name . args) prefix xpr . xprs)
   `(,%define-key-macro ,(cadr f)
      ,name ((,%_ ,@args) (,%where) ,prefix ,xpr ,@xprs)))
  ;((name . pat-fend-fix-tpls)
  ((name . pat-rest)
   (let ((pat-fend-fix-tpls
           ;; check for where clause
           (map (lambda (lst)
                  (cond
                    ((and (pair? (cadr lst))
                          (c? (caadr lst) %where)
                          (symbol? (caddr lst)))
                     lst)
                    ((and (pair? (cadr lst))
                          (c? (caadr lst) %where))
                     (error 'er/ir-macro "prefix missing"))
                    (else
                      (apply list
                             (car lst)
                             `(,%where)
                             (if (symbol? (cadr lst))
                               (cadr lst)
                               (error 'er/ir-macro "prefix missing"))
                             (cddr lst)))))
               pat-rest)))
     `(,%define-syntax ,name
        (,transformer
          (,%lambda (,%form ,mapper ,%compare?)
            (,%bind-case ,%form
              ,@(map insert-mapped-symbols
                  (map car pat-fend-fix-tpls)
                  (map (lambda (fend)
                         (if (null? (cdr fend))
                           ;; no keyword-checks
                           fend
                           ;; do keyword-checks
                           `(,(car fend)
                             ,@(map (lambda (p)
                                      (if (c? (car p) %key?) 
                                        `(,%compare? ,(cadr p)
                                                     (,mapper ',(cadr p)))
                                        p))
                                    (cdr fend)))))
                       (map cadr pat-fend-fix-tpls))
                  (map caddr pat-fend-fix-tpls)
                  (map cdddr pat-fend-fix-tpls))))))))
    )))))))

;;; (define-er-macro (name . args) (where . fenders) prefix xpr . xprs)
;;; (define-er-macro (name . args) prefix xpr . xprs)
;;; (define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)
;;; (define-er-macro name (pat prefix xpr . xprs) . others)
;;; -------------------------------------------------------------------------
;;; where fenders check for keywords via key?
;;; Version of define-macro, where symbols prefixed with prefix
;;; are automatically renamed
(define-syntax define-er-macro
  (syntax-rules (where)
    ((_ (name . args) (where . fenders) prefix xpr . xprs)
     (define-key-macro #:er (name . args) (where . fenders)
       prefix xpr . xprs))
    ((_ (name . args) prefix xpr . xprs)
     (define-key-macro #:er (name . args)
       prefix xpr . xprs))
    ((_ name . pat-rest)
     (define-key-macro #:er name . pat-rest))
    ))

;;; (define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)
;;; (define-ir-macro (name . args) prefix xpr . xprs)
;;; (define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)
;;; (define-ir-macro name (pat prefix xpr . xprs) . others)
;;; -------------------------------------------------------------------------
;;; where fenders check for keywords via key?
;;; Version of define-macro, where symbols prefixed with prefix
;;; are automatically injected.
(define-syntax define-ir-macro
  (syntax-rules (where)
    ((_ (name . args) (where . fenders) prefix xpr . xprs)
     (define-key-macro #:ir (name . args) (where . fenders)
       prefix xpr . xprs))
    ((_ (name . args) prefix xpr . xprs)
     (define-key-macro #:ir (name . args)
       prefix xpr . xprs))
    ((_ name . pat-rest)
     (define-key-macro #:ir name . pat-rest))
    ))

;;; (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)))
                 )
            `(,%ir-macro-transformer
               (,%lambda (,%form ,%inject ,%compare?)
                 (,%let ,(map (lambda (s)
                                `(,s (,%inject ',s)))
                         syms)
                     (,%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)
    (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")
    (define-er-macro
      macro:
      (define-er-macro (name . args) (where . fenders) prefix xpr . xprs)
      (define-er-macro (name . args) prefix xpr . xprs)
      (define-er-macro name (pat (where . fenders) prefix xpr . xprs) . others)
      (define-er-macro name (pat prefix xpr . xprs) . others)
      "where fenders check for keywords via key? predicate."
      "Version of define-macro, where symbols prefixed with prefix"
      "are automatically renamed.")
    (define-ir-macro
      macro:
      (define-ir-macro (name . args) (where . fenders) prefix xpr . xprs)
      (define-ir-macro (name . args) prefix xpr . xprs)
      (define-ir-macro name (pat (where . fenders) prefix xpr . xprs) . others)
      (define-ir-macro name (pat prefix xpr . xprs) . others)
      "where fenders check for keywords via key? predicate."
      "Version of define-macro, where symbols prefixed with prefix"
      "are automatically 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