;Author: Juergen Lorenz ; ju (at) jugilo (dot) de
;
; Copyright (c) 2017, 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 provides two modules, one with helper routines to be
imported for syntax into the other with macros, which facilitate the
writing of procedural-macros.

Chicken provides two procedural macro-systems, implicit and explicit
renaming macros. In both you have to destructure the use-form yourself
and provide for the renaming or injecting of names which could or should
be captured. Destructuring can be automated with the bind macro -- a
simplified version of the equally named macro in the bindings library --
and renaming resp. injecting can be almost automated with the help of an
auxiliary parameter, a prefix symbol, to the transformer routine.

Usually an ambituous explicit renaming macro contains a long let
defining the renamed symbols -- usually prefixed with some fixed symbol
constant like % -- which is then executed in the macro's body by
unquoting it. Our two macros create the let automatically. The only
thing you have to do is providing a prefix and using it to prefix all
symbols you want renamed.

Here is a simple example, the numeric if.

  (define-er-macro (nif form % compare?)
    (bind (_ xpr pos zer neg) form
      `(,%let ((,%result ,xpr))
         (,%cond
           ((,%positive? ,%result) ,pos)
           ((,%negative? ,%result) ,neg)
           (,%else ,zer)))))

Note, that one of the standard arguments of an er-macro-transformer,
rename, is replaced by the prefix, which characterize the symbols in the
body to be renamed. The other arguments, form and compare?, remain
untouched.

The macro searches its body for symbols starting with this prefix,
collects them in a list, removes duplicates and adds the necesary let
with pairs of the form

  (%name (rename 'name)

to the front of the body. In other words it does what you usually do by
hand.

For implicit renaming macros the list of injected symbols is usually,
but not allways, short, even empty for nif. Of course, the generated let
replaces rename with inject in this case. 
For example, here is a version of alambda, an anaphoric version of
lambda, which injects the name self:

  (define-ir-macro (alambda form % compare?)
    (bind (_ args xpr . xprs) form
      `(letrec ((,%self (lambda ,args ,xpr ,@xprs)))
         ,%self)))

]|#

(module basic-macro-helpers *
  (import scheme
          (only chicken case-lambda assert print error))

(define (pseudo-list sentinel . args)
  (let loop ((args args))
    (if (null? args)
      sentinel
      (cons (car args) (loop (cdr args))))))

(define (pseudo-list? xpr)
  #t)

(define (pseudo-null? xpr)
  (not (pair? xpr)))

(define (pseudo-length pl)
;; sentinel doesn't count in length!
  (if (pair? pl)
    (+ 1 (pseudo-length (cdr pl)))
    0))

(define (pseudo-sentinel pl)
  (if (pair? pl)
    (let ((rest (cdr pl)))
      (if (pair? rest)
        (pseudo-sentinel rest)
        rest))
    pl))

(define (pseudo-ref pl n)
  (assert (< n (pseudo-length pl)))
  (cond
    ((not (pair? pl)) pl)
    ((= n 0) (car pl))
    (else
     (pseudo-ref (cdr pl) (- n 1)))))

(define (pseudo-tail pl n)
  (assert (<= n (pseudo-length pl)))
  (cond
    ((not (pair? pl)) pl)
    ((= n 0) pl)
    (else
     (pseudo-tail (cdr pl) (- n 1)))))

(define (pseudo-head pl n)
  (assert (<= n (pseudo-length pl)))
  (if (not (pair? pl))
    '()
    (let loop ((k 0) (pl pl) (result '()))
      (if (= k n)
        (reverse result)
        (loop (+ k 1) (cdr pl) (cons (car pl) result))))))

(define (pseudo-flatten tree)
  ; imported flatten doesn't work with pseudo-lists
  (let loop ((tree tree) (result '()))
    (cond
      ((pair? tree)
       (loop (car tree) (loop (cdr tree) result)))
      ((null? tree) result)
      (else
        (cons 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)))

(define (filter ok? lst)
  (let loop ((lst lst) (result '()))
    (cond
      ((null? lst) (reverse result))
      ((ok? (car lst))
       (loop (cdr lst) (cons (car lst) result)))
      (else
        (loop (cdr lst) result)))))

(define (sym-prepends? pre sym)
  (assert (symbol? pre))
  (assert (symbol? sym))
  (let ((spre (symbol->string pre))
        (ssym (symbol->string sym)))
    (let ((prelen (string-length spre))
          (symlen (string-length ssym)))
      (and (< prelen symlen)
           (equal? (string->list spre)
                   (string->list (substring ssym 0 prelen)))))))

(define (sym-tail pre sym)
  (let ((spre (symbol->string pre))
        (ssym (symbol->string sym)))
    (let ((prelen (string-length spre))
          (symlen (string-length ssym)))
      (string->symbol (substring ssym prelen)))))

;;; (basic-macro-helpers sym ..)
;;; ----------------------------
;;; documentation procedure.
(define basic-macro-helpers
  (let ((alst '(
    (pseudo-list
      procedure:
        (pseudo-list sentinel . args)
        "creates a new pseudo-list from args"
        "and sentinel")
    (pseudo-list?
      procedure:
        (pseudo-list? xpr)
        "is xpr a pseudo-list?"
        "returns always #t")
    (pseudo-null?
      procedure:
        (pseudo-null? xpr)
        "is xpr pseudo-null?, i.e. not a pair")
    (pseudo-length
      procedure:
        (pseudo-length pl)
        "length of a pseudo-list pl"
        "the sentinel doesn't count")
    (pseudo-sentinel
      procedure:
        (pseudo-sentinel pl)
        "returns the sentinel of a pseudo-list, i.e '()"
        "in the case of a proper list")
    (pseudo-ref
      procedure:
        (pseudo-ref pl n)
        "returns the nth item of pl, where n is less than"
        "pl's pseudo-length")
    (pseudo-tail
      procedure:
        (pseudo-tail pl n)
        "returns the tail of pl starting with index n, where n is"
        "less than or equal to pl's pseudo-length")
    (pseudo-head
      procedure:
        (pseudo-head pl n)
        "returns the head of pl up to but excluding index n,"
        "where n is less than or equal to pl's pseudo-length")
    (pseudo-flatten
      procedure:
        (pseudo-flatten tree)
        "flattens the nested pseudo-list tree to a proper list")
    (remove-duplicates
      procedure:
        (remove-duplicates lst)
        "removes duplicates of a proper list")
    (adjoin
      procedure:
        (adjoin obj lst)
        "adds obj to a proper list, provided, it isn't already there")
    (filter
      procedure:
        (filter ok? lst)
        "filters a proper list by means of a predicate ok?")
    (sym-prepends?
      procedure:
        (sym-prepends? pre sym)
        "checks, if the symbol sym starts with the symbol pre")
    (sym-tail
      procedure:
        (sym-tail pre sym)
        "returns the tail of the symbol sym by"
        "stripping its prefix pre")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'basic-macros
                  "not exported" sym)))))))
) ; module basic-macro-helpers

(module basic-macros ;*
  (define-er-macro define-ir-macro bind bind-case once-only basic-macros)
  (import scheme basic-macro-helpers
          (only chicken condition-case case-lambda print error))
  (import-for-syntax; basic-macro-helpers)
                      (except basic-macro-helpers
                              pseudo-list
                              pseudo-length
                              pseudo-sentinel
                              pseudo-list?))

#|[
The following is Graham's dbind extended with  wildcards,
non-symbol literals and length-checks. For example

  (bind (x (y z)) '(1 (2 3)) (list x y z))

will result in '(1 2 3)
]|#

;;; (do-bind pat seq xpr . xprs)
;;; ----------------------------
;;; internal helper to be wrapped in bind:
;;; binds pattern variables of pat to corresponding subexpressions of
;;; seq and executes body xpr . xprs in this context.
(define-syntax do-bind
  (er-macro-transformer
    (lambda (form rename compare?)
  (let ((pat (cadr form))
        (seq (caddr form))
        (xpr (cadddr form))
        (xprs (cddddr form))
        (%_ (rename '_))
        (%if (rename 'if))
        (%seq (rename 'seq))
        (%and (rename 'and))
        (%let (rename 'let))
        (%begin (rename 'begin))
        (%error (rename 'error))
        (%equal? (rename 'equal?))
        (%pseudo-ref (rename 'pseudo-ref))
        (%pseudo-tail (rename 'pseudo-tail))
        (%pseudo-null? (rename 'pseudo-null?)))
    (let ((body `(,%begin ,xpr ,@xprs)))
      (letrec (
        (no-dups?
          (lambda (lst)
            (call-with-current-continuation
              (lambda (cc)
                (let loop ((lst lst) (result '()))
                  (if (null? lst)
                    #t
                    (loop (cdr lst)
                          ;(if (memq (car lst) result)
                          ;; keywords can be used as literals
                          (if (and (not (keyword? (car lst)))
                                   (memq (car lst) result))
                            (cc #f)
                            (cons (car lst) result)))))))))
        (destructure
          (lambda (pat seq)
            (let ((len (let loop ((pat pat) (result 0))
                         (cond
                           ((null? pat) result)
                           ((pair? pat)
                            (loop (cdr pat) (+ 1 result)))
                           (else result)))))
              (let loop ((k 0) (pairs '()) (literals '()) (tails '()))
                (if (= k len)
                  (let ((sentinel
                          ;last dotted item or '()
                          (let loop ((result pat) (k len))
                            (if (zero? k)
                              result
                              (loop (cdr result) (- k 1))))))
                    (cond
                      ((null? sentinel)
                       (values pairs literals
                               (cons `(,%pseudo-null?
                                        (,%pseudo-tail ,seq ,k))
                                     tails)))
                      ((symbol? sentinel)
                       (if (compare? sentinel %_)
                         (values pairs literals tails)
                         (values (cons (list sentinel
                                             `(,%pseudo-tail ,seq ,k))
                                       pairs)
                                 literals tails)))
                      (else
                        (values pairs
                                (cons `(,%equal? ',sentinel
                                                 (,%pseudo-tail ,seq ,k))
                                      literals)
                                tails))))
                  (let ((item (pseudo-ref pat k)))
                          ;(let loop ((pat pat) (k k))
                          ;  (cond
                          ;    ((not (pair? pat)) pat)
                          ;    ((= k 0) (car pat))
                          ;    (else (loop (cdr pat) (- k 1)))))))
                    (cond
                      ;((symbol? item)
                      ((and (symbol? item) (not (keyword? item)))
                       (if (compare? item %_)
                         (loop (+ k 1) pairs literals tails)
                         (loop (+ k 1)
                               (cons (list item `(,%pseudo-ref ,seq ,k)) pairs)
                               literals
                               tails)))
                      ((pair? item)
                       (call-with-values
                         (lambda ()
                           (destructure item `(,%pseudo-ref ,seq ,k)))
                         (lambda (ps ls ts)
                           (loop (+ k 1)
                                 (append ps pairs)
                                 (append ls literals)
                                 (append ts tails)))))
                      (else ;(atom? item) ; literal 
                        (loop (+ k 1)
                              pairs
                              (cons `(,%equal? ',item
                                               (,%pseudo-ref ,seq ,k))
                                    literals)
                              tails))
                      )))))))
        )
        (call-with-values
          (lambda () (destructure pat seq))
          (lambda (pairs literals tails)
            (if (no-dups? (map car pairs))
              `(,%if (,%and ,@tails)
                     (,%if (,%and ,@literals)
                           (,%let ,pairs ,body)
                           (,%error 'bind "literals don't match" ',literals))
                     (,%error 'bind "length mismatch" ',tails))
              `(,%error 'bind
                        "duplicate pattern variables"
                        ',(map car pairs)))))
          ))))))

;;;; (bind pat seq xpr . xprs)
;;;; (bind pat seq (where (x x? ...) ...) xpr . xprs)
;;;; ------------------------------------------------
;;;; binds pattern variables of pat to corresponding subexpressions of
;;;; seq and executes body xpr . xprs in this context
(define-syntax bind
  (syntax-rules (where)
    ((_ pat seq (where (x x? ...) ...) xpr . xprs)
     (let ((%seq seq))
       (do-bind pat %seq
         (if (and (and (x? x) ...) ...)
           (begin xpr . xprs)
           (error 'bind "where-clause violated")))))
    ((_ pat seq xpr . xprs)
     (let ((%seq seq))
       (do-bind pat %seq xpr . xprs)))))

;;;; (bind-case seq (pat xpr . xprs) ....)
;;;; -------------------------------------
;;;; Checks if seq matches patterns pat ...
;;;; 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 ()
;    ((_ seq)
;     (error 'bind-case `("no match for" ,seq)))
;    ((_ seq (pat xpr . xprs))
;     (bind pat seq xpr . xprs))
;    ((_ seq clause . clauses)
;     (condition-case (bind-case seq clause)
;       ((exn) (bind-case seq . clauses))))
;    ))

;;; (bind-case seq (pat xpr . xprs) ...)
;;; (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 ()
    ((_ seq)
     (error 'bind-case "no match, possibly caused by fenders, for" seq))
    ((_ seq (pat (where . fenders) xpr . xprs))
     (condition-case (bind pat seq (where . fenders) xpr . xprs)
       ((exn) (bind-case seq))))
    ((_ seq (pat xpr . xprs))
     (bind-case seq (pat (where) xpr . xprs)))
    ((_ seq clause . clauses)
     (condition-case (bind-case seq clause)
       ((exn) (bind-case seq . clauses))))
    ))

;;; (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 ((names (cadr form))
        (body (cons (caddr form) (cdddr form)))
        (%let (rename 'let))
        (%list (rename 'list))
        ;(%gensym (rename 'gensym))
        )
    (let ((syms (map rename names)))
      ;`(,%let ,(map (lambda (g) `(,g ',g)) syms)
      `(,%let ,(map (lambda (g) `(,g ,(rename `',g))) syms)
      ;`(,%let ,(map (lambda (g) `(,g (,rename ',g))) syms)
      ;`(,%let ,(map (lambda (g) `(,g (,%gensym))) syms)
         `(,',%let ,(,%list ,@(map (lambda (g n) ``(,,g ,,n))
                               syms names))
            ,(,%let ,(map (lambda (n g) `(,n ,g))
                        names syms)
               ,@body))))))))
;(define-syntax once-only
;  (ir-macro-transformer
;    (lambda (form inject compare?)
;  (let ((names (cadr form))
;        (body (cons (caddr form) (cdddr 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))))))))
;
;;; (define-er-macro (name form rename-prefix compare?) xpr . xprs)
;;; ---------------------------------------------------------------
;;; defines an explicit-renaming macro name with use-form form,
;;; automatically renaming symbols starting with inject-rpefix
(define-syntax define-er-macro
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((header (cadr form))
            (body (cons (caddr form) (cdddr form))))
        (let ((name (car header))
              (frm (cadr header))
              (pre (caddr header))
              (cmp? (cadddr header))
              (ren 'rename)
              (%let (rename 'let))
              (%lambda (rename 'lambda))
              (%define-syntax (rename 'define-syntax))
              (%er-macro-transformer (rename 'er-macro-transformer)))
          `(,%define-syntax ,name
             (,%er-macro-transformer
               (,%lambda (,frm ,ren ,cmp?)
                 ;,(declare-prefixed-syms pre ren body)))))))))
                 (,%let ,(map (lambda (sym)
                                `(,sym (,ren ',(sym-tail pre sym))))
                              (remove-duplicates
                                (filter (lambda (sym)
                                          (and (symbol? sym)
                                               (sym-prepends? pre sym)))
                                        (pseudo-flatten body))))
                   ,@body)))))))))

;;; (define-ir-macro (name form inject-prefix compare?) xpr . xprs)
;;; ---------------------------------------------------------------
;;; defines an implicit-renaming macro name with use-form form,
;;; automatically injecting symbols starting with inject-rpefix
(define-syntax define-ir-macro
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((header (cadr form))
            (body (cons (caddr form) (cdddr form))))
        (let ((name (car header))
              (form (cadr header))
              (pre (caddr header))
              (cmp? (cadddr header))
              (inj 'inject)
              (%let (rename 'let))
              (%lambda (rename 'lambda))
              (%define-syntax (rename 'define-syntax))
              (%ir-macro-transformer (rename 'ir-macro-transformer)))
          `(,%define-syntax ,name
             (,%ir-macro-transformer
               (,%lambda (,form ,inj ,cmp?)
                 ;,(declare-prefixed-syms pre inj body)))))))))
                 (,%let ,(map (lambda (sym)
                                `(,sym (,inj ',(sym-tail pre sym))))
                              (remove-duplicates
                                (filter (lambda (sym)
                                          (and (symbol? sym)
                                               (sym-prepends? pre sym)))
                                        (pseudo-flatten body))))
                   ,@body)))))))))

;;; (basic-macros sym ..)
;;; ---------------------
;;; documentation procedure.
(define basic-macros
  (let ((alst '(
    (bind
      macro:
      (bind pat seq (where fender ...) .. xpr ....)
      "a variant of Common Lisp's destructuring-bind"
      "where pat and seq are a nested pseudo-lists and"
      "optional fenders of the form (x x? ...) are checked"
      "before evaluating the body xpr ...")
    (bind-case
      macro:
      (bind-case seq (pat (where fender ...) .. xpr ...) ....)
      "matches a nested pseudo-list seq against nested pseudo-lists"
      "pat ... with optional fenders ... in sequence in a case regime")
    (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
      macro:
      (define-er-macro name form rename-prefix compare?)
      "creates an explicit-renaming macro, where all symbols"
      "starting with rename-prefix are renamed automatically")
    (define-ir-macro
      macro:
      (define-ir-macro name form inject-prefix compare?)
      "creates an implicit-renaming macro, where all symbols"
      "starting with inject-prefix are injected automatically")
    )))
    (case-lambda
      (()
       (map car alst))
      ((sym)
       (let ((lst (assq sym alst)))
         (if lst
           (for-each print (cdr lst))
           (error 'basic-macros
                  "not exported" sym)))))))

) ; module basic-macros