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

Copyright (c) 2011-2014, 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.
]|#

(module macro-helpers
  (export macro-helpers bind-exception symbol-dispatcher
          dbind-ex dbind-lit dbind-len dbind-def
          list-destruc seq-destruc remove-wildcards
          filter filter* flatten memp assp mappend map* flatten-map*
          plist? pnull? plength plist-ref plist-tail plist-head
          ptail phead singleton? collect* found?
          vector-head vector-tail list-of? atom?
          extract adjoin remove-duplicates replace*
          seq-length seq-ref seq-tail seq-length-ref-tail!
          prefixed-with? strip-prefix strip-suffix add-prefix
          rename-prefix
          once-only with-gensyms define-syntax-rule)
  (import scheme (only chicken
                       receive case-lambda define-values
                       let-values
                       make-parameter
                       error signal gensym print
                       make-property-condition
                       make-composite-condition))

(define (symbol-dispatcher alist)
  (case-lambda
    (()
     (map car alist))
    ((sym)
     (let ((pair (assq sym alist)))
       (if pair
         (for-each print (cdr pair))
         (print "Choose one of\n" (map car alist)))))))

(define macro-helpers
  (symbol-dispatcher '(
    (symbol-dispatcher
      (procedure: (alist) -> (procedure) or (procedure sym)))
    (bind-exception
      (procedure: (location message . arguments) -> condition))
    (map*
      (procedure: (fn . trees) -> new-tree))
    (flatten-map*
      (procedure: (fn . trees) -> new-list))
    (filter
      (procedure: (ok? lst) -> (ok-list not-ok-list)))
    (filter*
      (procedure: (ok? tree) -> (ok-tree not-ok-tree)))
    (flatten
      (procedure: (tree) -> lst))
    (collect*
      (procedure: (ok? tree) -> ok-list))
    (found?
      (procedure: (ok? tree) -> boolean))
    (extract
      (procedure: (ok? tree) -> lst))
    (memp
      (procedure: (ok? lst) -> sublst or #f))
    (assp
      (procedure: (ok? alst) -> pair or #f))
    (mappend
      (procedure: (fn lists) -> lst))
    (plength
      (procedure: (pl) -> pseudolength))
    (plist?
      (procedure: (xpr) -> boolean))
    (pnull?
      (procedure: (xpr) -> boolean))
    (plist-ref
      (procedure: (pl k) -> pseudo-kth-item))
    (plist-tail
      (procedure: (pl k) -> pseudo-kth-rest))
    (plist-head
      (procedure: (pl k) -> head-list-upto-k))
    (ptail
      (procedure: (pl) -> nil-or-atom))
    (phead
      (procedure: (pl) -> lst))
    (seq-length
      (procedure: (seq) -> generic-length))
    (seq-ref
      (procedure: (seq k) -> generic-kth-item))
    (seq-tail
      (procedure: (seq k) -> generic-kth-rest))
    (seq-length-ref-tail!
      (procedure: (type? type-length type-ref type-tail)
                  updates (seq-length seq-ref seq-tail)))
    (add-prefix
      (procedure: (prefix id) -> new-id))
    (prefixed-with?
      (procedure: (prefix) -> (procedure id)))
    (strip-prefix
      (procedure: (prefix id) -> new-id))
    (rename-prefix
      parameter:
      (rename-prefix sym ..)
      "sets rename-prefix to sym or returns it, default: '%")
    (strip-suffix
      (procedure: (suffix id) -> new-id))
    (adjoin
      (procedure: (obj lst) -> new-lst))
    (remove-duplicates
      (procedure: (lst) -> new-lst))
    (replace*
      (procedure: (what? by-fn tree) -> new-tree))
    (vector-head
      (procedure: (vec k) -> subvector))
    (vector-tail
      (procedure: (vec k) -> subvector))
    (list-of?
      (procedure: (ok?) -> predicate))
    (atom?
      (procedure: (xpr) -> boolean))
    (singleton?
      (procedure: (xpr) -> boolean))
    (once-only
      macro:
      (once-only (x ....) xpr ....)
      "arguments x ... are evaluated only once")
    (with-gensyms
      macro:
      (with-gensyms (x ....) xpr ....)
      "generates a series of gensyms x .... to be used in xpr ...")
    (define-syntax-rule
      macro:
      (define-syntax-rule (name . args) (keywords x ...) .. tpl)
      "syntax-rules with only one rule")
;    ;; should not be documented
;    (list-destruc
;      (procedure: (pat seq) or (pat seq glen gref gtail)
;                  -> (symbols literals length-checks)))
;    (seq-destruc
;      (procedure: (pat seq) or (pat seq glen gref gtail)
;                  -> (symbols literals length-checks)))
;    (remove-wildcards
;      (procedure: (compare? tree) -> reduced-tree))
;    (dbind-ex
;      (procedure: (symbols body) -> nested-let-code))
;    (dbind-lit
;      (procedure: (literals) -> literals-check-code))
;    (dbind-len
;      (procedure: (length-checks) -> length-check-code))
;    (dbind-def
;      (procedure: (op binds) -> define-code))
    )))

(define (bind-exception loc msg . args)
  (make-composite-condition
    (make-property-condition 'exn
      'location `(,loc)
      'message msg
      'arguments (apply list args))
    (make-property-condition 'bind
      'location `(,loc)
      'message msg
      'arguments (apply list args))))


;;;; pseudolists

(define (plist? xpr) #t)
  ;(or (atom? xpr)
  ;    (and (pair? xpr) (plist? (cdr xpr))))

(define (pnull? xpr)
  (or (null? xpr) (not (pair? xpr))))

(define (plist? xpr)
  (or (pnull? xpr) (pair? xpr)))

(define (plength pl)
  (let loop ((pl pl) (len 0))
    (if (pnull? pl)
      len
      (loop (cdr pl) (+ len 1)))))

;(define (plist-tail pl n)
;  (cond
;    ((or (negative? n) (> n (plength pl)))
;     (error 'plist-tail
;            "out of range"
;            pl n))
;    ((zero? n) pl)
;    (else
;     (plist-tail (cdr pl) (- n 1)))))
(define (plist-tail pl k)
  (if (or (< k 0) (> k (plength pl)))
    (error 'plist-tail "out of range" pl k)
    (let loop ((pl pl) (n 0) (result '()))
      (if (= n k)
        (values pl (reverse result))
        (loop (cdr pl) (+ n 1) (cons (car pl) result))))))

(define (plist-head pl k)
  (call-with-values
    (lambda () (plist-tail pl k))
    (lambda (tail head) head)))

(define (plist-ref pl n)
  (cond
    ((or (negative? n) (>= n (plength pl)))
     (error 'plist-ref
            "out of range"
            pl n))
    ((zero? n) (car pl))
    (else
     (plist-ref (cdr pl) (- n 1)))))

(define (ptail pl)
  (plist-tail pl (plength pl)))

(define (phead pl)
  (plist-head pl (plength pl)))

;;;; other helpers

(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 (add-prefix pre id)
  (string->symbol
    (string-append (symbol->string pre)
                   (symbol->string id))))

(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 (list-of? ok?)
  (lambda (lst)
    (not (memq #f (map ok? lst)))))

(define (atom? x)
  (not (pair? x)))

(define (singleton? xpr)
  (and (pair? xpr) (null? (cdr xpr))))

(define (map* fn . trees)
  (if (null? trees)
    '()
    (let loop ((trees trees))
      (cond
        (((list-of? pair?) trees)
         (cons (loop (map car trees))
               (loop (map cdr trees))))
        (((list-of? null?) trees)
         '())
        (((list-of? atom?) trees)
         (apply fn trees))
        (else
          (error "not all of same structure" trees))))))

(define (flatten-map* fn . trees)
  (if (null? trees)
    '()
    (let loop ((trees trees))
      (cond
        (((list-of? pair?) trees)
         (append (loop (map car trees))
                 (loop (map cdr trees))))
        (((list-of? null?) trees)
         '())
        (((list-of? atom?) trees)
         (list (apply fn trees)))
        (else
          (error "not all of same structure" trees))))))

(define (replace* what? by tree)
  (let loop ((tree tree))
    (cond
      ((what? tree) (by tree))
      ((pair? tree)
       (cons (loop (car tree))
             (loop (cdr tree))))
      ((null? tree) tree)
      (else tree))))

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

(define (assp ok? tbl)
  (let loop ((tbl tbl))
    (cond
      ((null? tbl) #f)
      ((ok? (caar tbl)) (car tbl))
      (else (loop (cdr tbl))))))

(define (filter 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)))))))

(define (filter* ok? tree)
  (let loop ((tree tree))
    (cond
      ((pair? tree)
       (let-values (
         ((car-yes car-no) (loop (car tree)))
         ((cdr-yes cdr-no) (loop (cdr tree)))
         )
         (values (if (null? car-yes) cdr-yes (cons car-yes cdr-yes))
                 (if (null? car-no) cdr-no (cons car-no cdr-no)))))
      ((null? tree)
       (values '() '()))
      (else
        (if (ok? tree)
          (values tree '())
          (values '() tree))))))

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

(define (collect* ok? tree)
  (let loop ((tree tree) (result '()))
    (cond
      ((pair? tree)
       (if (ok? (car tree))
         (cons (car tree) (loop (cdr tree) result))
         (loop (car tree) (loop (cdr tree) result))))
      ((null? tree)
       result)
      (else
        (if (ok? tree)
          (cons tree result)
          result)))))

(define (found? ok? tree)
  (let loop ((tree tree))
    (cond
      ((pair? tree)
       (or (ok? (car tree))
           (loop (car tree))
           (loop (cdr tree))))
      ((null? tree) #f)
      (else (ok? tree)))))

(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 (mappend fn lists) ; mapcan in CL
  (apply append (map fn lists)))

#|[
Now to the destructuring procdures. Note that destruc will return three
values, which are used by one of the other destructuring routines
respectively.
]|#

(define (destruc pat seq glen gref gtail)
;(define (destruc pat seq glen glen-sym gref gtail)
  (let loop ((pat pat) (seq seq) (n 0))
    (if (pair? pat)
      (let ((p (car pat)))
        (receive (rec-ex rec-lit rec-len)
          (loop (cdr pat) seq (+ n 1))
          (if (or (pair? p) (null? p))
            (let ((g (gensym)) (v `(,gref ,seq ,n)))
              (receive (g-ex g-lit g-len) (loop p g 0)
                (values
                  (cons (cons `(,g (,gref ,seq ,n))
                              g-ex) rec-ex)
                  (cons (cons `(,g (,gref ,seq ,n))
                              g-lit) rec-lit)
                  (append (replace*
                            (lambda (x) (and (symbol? x) (eq? x g)))
                            (lambda (y) v)
                            g-len)
                          rec-len))))
            (if (symbol? p)
              (values
                (cons `(,p (,gref ,seq ,n)) rec-ex)
                rec-lit
                rec-len)
              (values
                rec-ex
                (cons `(,p (,gref ,seq ,n)) rec-lit)
                rec-len)))))
      (let ((tail `(,gtail ,seq ,n))
            (length-check (lambda (p s)
                            (if (list? p)
                              `(= (,glen ',p) (,glen ,s))
                              `(<= (,glen ',p) (,glen ,s))))))
                              ;`(= ,(glen p) (,glen-sym ,s))
                              ;`(<= ,(glen p) (,glen-sym ,s))))))
        (if (null? pat)
          (values '() '() `(,(length-check pat tail)))
          (if (symbol? pat)
            (values `((,pat ,tail)) '() `(,(length-check pat tail)))
            (values '() `((,pat ,tail)) `(,(length-check pat tail)))))))))

#|[
Two exported versions of destruc
]|#

(define (list-destruc pat seq)
  (destruc pat seq 'plength 'plist-ref 'plist-tail))

(define (seq-destruc pat seq)
  (destruc pat seq 'seq-length 'seq-ref 'seq-tail))

#|[
Four procedures which use the results of destruc
]|#

;; to be called with destruc's first return value
(define (dbind-ex symbols body)
  (if (null? symbols)
    `(if ,(car body)
       (begin ,@(cdr body))
       (signal (bind-exception 'dbind-ex
                               "fenders not passed"
                               ',(car body))))
    `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
                symbols)
       ,(dbind-ex
          (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                   symbols)
          body))))

;; to be called with destruc's second return value
(define (dbind-lit literals)
  (if (null? literals)
    #t
    (let ((pairs (map (lambda (b)
                        (if (pair? (car b))
                          (car b)
                          b))
                      literals)))
      (receive (syms lits)
        (filter (lambda (p) (symbol? (car p))) pairs)
        `(let ,syms
           (if (and ,@(map (lambda (s) (cons 'equal? s)) lits))
             ,(dbind-lit
                (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                         literals))
             (signal (bind-exception 'dbind-lit
                                     "literals don't match"
                                     ',lits))))))))

;; to be called with destruc's third return value
(define (dbind-len length-checks)
  `(condition-case (and ,@length-checks)
     ((exn)
      (signal (bind-exception 'dbind-len
                              "length-checks violated"
                              ',length-checks)))))

;; to be called with destruc's first return value
(define (dbind-def op binds)
  ;; Note, that gensyms don't pollute namespaces
  (if (null? binds)
    `(,op ,(gensym) (void))
    (let ((pairs (map (lambda (b)
                        (if (pair? (car b))
                          (car b)
                          b))
                      binds)))
      `(begin ,@(map (lambda (x) `(,op ,(car x) ,(cadr x)))
                     pairs)
              ,(dbind-def op
                          (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                                   binds))))))

;;; Please note, that these four helpers needn't care for renaming,
;;; since we'll implement dbind as an implicit renaming macro, which
;;; does the renaming automatically behind the scene. Even the gensym
;;; could be avoided by the same reason. But I prefer to have differnt
;;; names for repeated calls of a renaming procedure, which is
;;; guaranteed by gensym but violated by rename.


#|[ 
Now to the generic functions seq-ref, seq-tail and seq-length which can
be used as additional arguments in destruc, provided they are imported
for-syntax.
The following two macros help to avoid repetition of code.
]|#

(define-syntax search-and-call
  (syntax-rules ()
    ((_ tbl)
     (lambda args
       (let ((pair (assp (lambda (x) (x (car args)))
                         tbl))) ; choose method
         (if pair
           (apply (cdr pair) args) ; apply it
           (error 'search-and-call "type error" args)))))))

(define-syntax add-to-table
  (syntax-rules ()
    ((_ tbl)
     (lambda (pair)
       ;; pair must be added to the front
       ;; since last query of tbl, plist?,
       ;; is always #t
       (set! tbl (cons pair tbl))))))

#|[

Generic functions are in fact closures, which search a table for a
matching operation and apply that operation in case of a match.
To be able to add new operations to that table, we must get a handle on
it. In other words, there must be other routines which operate on the
same table. define-values will come to the rescue ...
]|#

(define-values (seq-length seq-length!)
  (let ((table
          (list
            (cons vector? vector-length)
            (cons string? string-length)
            ;; must be last, because plist? is always #t
            (cons plist? plength))))
    (values
      (search-and-call table)
      (add-to-table table))))

(define-values (seq-ref seq-ref!)
  (let ((table
          (list
            (cons vector? vector-ref)
            (cons string? string-ref)
            ;; must be last, because plist? is always #t
            (cons plist? plist-ref))))
    (values
      (search-and-call table)
      (add-to-table table))))

;; Chicken's subvector is buggy
(define (vector-tail seq n)
  (if (or (negative? n) (> n (vector-length seq)))
    (error 'vector-tail
           "out of range"
           seq n)
    (let* ((len (vector-length seq))
           (tail (make-vector (- len n) #f))
           (head (make-vector n #f)))
      (do ((k 0 (+ k 1)))
        ((= k len) (values tail head))
        (if (< k n)
          (vector-set! head k (vector-ref seq k))
          (vector-set! tail (- k n) (vector-ref seq k)))))))

(define (vector-head seq n)
  (call-with-values (lambda () (vector-tail seq n))
                    (lambda (tail head) head)))
    
(define-values (seq-tail seq-tail!)
  (let ((table
          (list
            (cons vector? vector-tail)
            (cons string? substring)
            ;; must be last, because plist? is always #t
            (cons plist? plist-tail))))
    (values
      (search-and-call table)
      (add-to-table table))))

#|[ 
Instead of exporting the three mutators above we export the following
one which updates all three local tables of the accessors in one go.
This way it's impossible to forget updating one of the three tables.
]|#

;;; (seq-length-ref-tail! type? type-length type-ref type-tail)
;;; -----------------------------------------------------------
;;; updates the tables with tree functions in this order and index it
;;; with the type predicate type?.
(define (seq-length-ref-tail! type? type-length type-ref type-tail)
  (seq-length! (cons type? type-length))
  (seq-ref!    (cons type? type-ref))
  (seq-tail!   (cons type? type-tail)))

#|[
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 with only one rule.
]|#

;;; (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 (name . args) (keywords . keys) .. tpl)
;;; -----------------------------------------------------------
;;; simplyfies define-syntax in case there are no auxiliary keywords
;;; and only one syntax-rule.
(define-syntax define-syntax-rule
  (syntax-rules (keywords)
    ((_ (name . args)
        (keywords key ...) tpl)
     (define-syntax name
       (syntax-rules (key ...)
         ((_ . args) tpl))))
    ((_ (name . args) tpl)
     (define-syntax name
       (syntax-rules ()
         ((_ . args) tpl))))))

(define rename-prefix
  (make-parameter '% (lambda (x) (if (symbol? x) x '%))))

(define (remove-wildcards compare? tree) 
  (let loop ((tree tree))
    (cond
      ((pair? tree)
       (let ((left (car tree)) (right (cdr tree)))
         (cond
           ((and (pair? left)
                 (symbol? (car left))
                 (compare? (car left) '_))
            (loop right))
           ((and (pair? right)
                 (symbol? (car right))
                 (compare? (car right) '_))
            (loop left))
           (else
             (cons (loop left)
                   (loop right))))))
      ((null? tree) '())
      (else
        (if (compare? tree '_)
          '()
          tree)))))

) ; module macro-helpers