; 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.

#|[
The fundamental binding-construct, bind, is patterned after Paul Graham's
dbind, cf. "On Lisp", p. 232.
In Chicken, dbind for lists could look as follows

  (define-syntax dbind
    (ir-macro-transformer
      (lambda (form inject compare?)
        (letrec (
          (mappend
            (lambda (fn lists)
              (apply append (map fn lists))))
          (destruc
            (lambda (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))))
                  (if (null? pat)
                    '()
                    `((,pat (list-tail ,seq ,n))))))))
          (dbind-ex
            (lambda (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)))))
          )         
          (let ((pat (cadr form))
                (seq (caddr form))
                (body (cdddr form))
                (gseq 'seq))
            `(let ((,gseq ,seq))
               ,(dbind-ex (destruc pat gseq) body)))))))

This code works as follows: First, destruc traverses the pattern and
groups each symbol with some list accessing code, 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

  (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))
 
Note, that the destructuring procedures are local to this macro. This is
necessary in Chicken for the macro to work, in particular in compiled
code, unless you import them for-syntax. But since they are of no
interest outside of the macro, local procedrues are preferable.

Note further, that ir-macro-transformer does all the necessary renaming
transparently behind the scene, even if the helpers where defined in
another module. In particular, gseq needn't be a gensym.

And note, that Graham's code didn't check for seq's length, i.e. 
(dbind (a b) '(1 2 3) (list a b) would happily return '(1 2).

Graham's original code works on the sequence datatype, so vectors and
strings are destructured as well. Sequences don't exist in Scheme,
unless you import-for-syntax Felix' sequences egg. To make this module
self-contained, I prefer to supply access-routines closed over a table,
which provides sequence versions of list-ref and list-tail, the only
sequence routines used by destruc above, as well as a sequence version
of length, which is needed to do the length checks.

There are some features, which I would like to have and which are
implemented as well. First wildcards, represented by the underscore
symbol. It matches everything, but binds nothing. So it can appear
multiple times in the same macro. Wildcard symbols are simply not
collected in the destruc routine.

Second, non-symbol literals, which don't bind anything, of course, but
match only themselves. This and the length checks are treated simply by
pairing them as well with check-routines in destruc but separating the
pairs with leading symbol from those with leading nil or literal in
dbind-ex. The former are bound with lets as in Graham's code, the
latter's cadrs being evaluated before the recursive call to dbind-ex.

The last feature missing is fenders, which is important in particular
for bind-case 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 in bind-case or a bind-exception is signalled in
bind.

]|#

(require-library procedural-macros)

(module bind-sequences
  (bind-table-show bind-table-add! range-exception
   bind-seq-length bind-seq-ref bind-seq-tail
   symbol-dispatcher list-of pseudo-list-of vector-of bind-sequences)

  (import scheme
          (only data-structures conjoin list-of?)
          (only chicken
                case-lambda define-values
                signal make-property-condition make-composite-condition
                error print subvector))

#|[ 
The following three routines maintain the lookup table for the needed
sequence primitives. Instead of bind-table-lookup the three sequence
primitives below are exported.
If you prefer, you can use the sequence primitives size, elt and sub of
the sequences egg, provided you rename them bind-seq-length,
bind-seq-ref and bind-seq-tail respectively.
]|#

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

;;; (bind-table-lookup obj)
;;; -----------------------
;;; returns an association list of predicates and associated vectors
;;; with length, ref and tail primitives
;;;
;;; (bind-table-show)
;;; -----------------
;;; prints the contents of the table
;;;
;;; (bind-table-add! type? len ref tail)
;;; ------------------------------------
;;; adds a new list to the top of the table
(define-values (bind-table-lookup bind-table-show bind-table-add!)
  (let (
    (tbl
      (list (cons pair?
                  (vector
                    (lambda (obj)
                      (let loop ((obj obj) (len 0))
                        (if (pair? obj)
                          (loop (cdr obj) (+ len 1))
                          len)))
                    list-ref
                    list-tail))
            (cons vector?
                  (vector vector-length vector-ref subvector))
            (cons string?
                  (vector string-length string-ref substring))
            ;; atoms catch all
            (cons (lambda (obj) (not (pair? obj)))
                  (vector
                    (lambda (obj) 0) ; len
                    (lambda (obj pos) ; ref
                      (signal
                        (range-exception
                          'bind-table-lookup
                             "out of range"
                             obj
                             pos)))
                    (lambda (obj pos) ; tail
                      (if (zero? pos)
                        obj
                        (signal
                          (range-exception
                            'bind-table-lookup
                               "out of range"
                               obj))))))
            ))
    )
    (values
      (lambda (obj)
        (let loop ((tbl tbl))
          ;; note, that we have a catch-all predicate in the table
          (if ((caar tbl) obj)
            (cdar tbl)
            (loop (cdr tbl)))))
      (lambda () (print tbl))
      (lambda (type? len ref tail)
        (set! tbl (cons (cons type?
                              (vector len ref tail))
                        tbl))))
      ))

;;; (bind-seq-length seq)
;;; ---------------------
;;; returns the length of the sequence argument
(define (bind-seq-length obj)
  ((vector-ref (bind-table-lookup obj) 0) obj))

;;; (bind-seq-ref seq pos)
;;; ----------------------
;;; returns the item of the sequence argument at index pos
(define (bind-seq-ref obj pos)
  ((vector-ref (bind-table-lookup obj) 1) obj pos))

;;; (bind-seq-tail seq pos)
;;; -----------------------
;;; returns the tail of the sequence argument starting at index pos
(define (bind-seq-tail obj pos)
  ((vector-ref (bind-table-lookup obj) 2) obj pos))

#|[
At last some helper functions, which sometimes make life easier
]|#

;;; (list-of ok? ....)
;;; ------------------
;;; returns a list predicate which checks all ok? arguments
(define (list-of . oks?) (list-of? (apply conjoin oks?)))

;;; (pseudo-list-of ok? ....)
;;; ------------------
;;; returns a pseudo-list predicate which checks all ok? arguments
(define (pseudo-list-of . oks?)
  (letrec
    ((pseudo-list-of?
       (lambda (ok?)
         (lambda (xpr)
           (or (ok? xpr)
               (and (pair? xpr)
                    (ok? (car xpr))
                    ((pseudo-list-of? ok?) (cdr xpr))))))))
    (pseudo-list-of? (apply conjoin oks?))))

;;; (vector-of ok? ....)
;;; --------------------
;;; returns a list predicate which checks all ok? arguments
(define (vector-of . oks?)
  (let (
    (vector-of?
      (lambda (ok?)
        (lambda (vec)
          (and (vector? vec)
               (let loop ((n 0))
                 (cond
                   ((= n (vector-length vec))
                    #t)
                   ((ok? (vector-ref vec n))
                    (loop (+ n 1)))
                   (else #f)))))))
    )
    (vector-of? (apply conjoin oks?))))

;;; (symbol-dispatcher alist)
;;; -------------------------
;;; returns a procedure of zero or one argument, which shows all cars
;;; or the cdr of the alist item with car symbol
(define (symbol-dispatcher alist)
  (case-lambda
    (()
     (map car alist))
    ((sym)
     (let ((pair (assq sym alist)))
       (if pair
         (for-each print (cdr pair))
         (error "Not in list"
                sym
                (map car alist)))))))

(define bind-sequences
  (symbol-dispatcher '(
    (bind-seq-length
      procedure:
      (bind-seq-length seq)
      "redurns the length of a sequence")
    (bind-seq-ref
      procedure:
      (bind-seq-ref seq pos)
      "returns the item at position pos of a sequence")
    (bind-seq-tail
      procedure:
      (bind-seq-ref seq pos)
      "returns the tail starting at position pos of a sequence")
    (bind-table-show
      procedure:
      (bind-table-show)
      "pretty prints the sequence table")
    (bind-table-add!
      procedure:
      (bind-table-add! type? len ref tail)
      "adds a new table item to the front of the sequence table")
    (list-of
      procedure:
      (list-of ok? ...)
      "generates a list predicate which checks all of its arguments")
    (pseudo-list-of
      procedure:
      (pseudo-list-of ok? ...)
      "generates a pseudo-list predicate which checks all of its arguments")
    (vector-of
      procedure:
      (vector-of ok? ...)
      "generates a vector predicate which checks all of its arguments")
    (symbol-dispatcher
      procedure:
      (symbol-dispatcher alist)
      "generates a procedure of zero or one argument showing all"
      "cars or the cdr or the alist item with symbol as car")
    )))

) ; module bind-sequences

;(module bindings
(functor (bind-functor (M (len ref tail)))
  (bind bind-case bind-lambda bind-lambda* bind-case-lambda
   bind-case-lambda* bind* bind-let bind-let* bind-letrec bindrec
   bindable? bind-define bind-set! bind/cc 
   ;bind-exception-handler
   signal-bind-exception bind-exception
   bindings)
  (import scheme
          bind-sequences
          (only chicken case-lambda condition-case define-values
                error subvector define-for-syntax
                current-exception-handler condition-predicate
                get-condition-property make-property-condition
                make-composite-condition signal abort print)
          (only procedural-macros define-macro)
          M
          )
  (reexport (only bind-sequences
                  bind-table-add! bind-table-show
                  symbol-dispatcher list-of pseudo-list-of vector-of))

  (import-for-syntax
    (only procedural-macros macro-rules)
    (only data-structures compress))

#|[
Let's start with defining bind-exceptions, a corresponding exception-handler,
and registering this handler
]|#

;;; (bind-exception loc msg arg ...)
;;; --------------------------------
;;; composite condition, to allow for (exn bind) in condition-case
(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)))

;;; (signal-bind-exception loc msg arg ...)
;;; ---------------------------------------
;;; signals a bind-exception, can be used instead of error
(define (signal-bind-exception loc msg . args)
  (signal
    (apply bind-exception loc msg args)))

;;;; (bind-exception-handler var)
;;;; ----------------------------
;;;; exception-handler to be passed to the parameter
;;;; current-exception-handler
;(define bind-exception-handler
;  (let ((old-handler (current-exception-handler)))
;    (lambda (var)
;      (if ((condition-predicate 'bind) var)
;        (begin
;          (display "Bind error: ")
;          (print (get-condition-property var 'bind 'location))
;          (print (get-condition-property var 'bind 'message))
;          (for-each print (get-condition-property var 'bind 'arguments))
;          (abort (make-property-condition 'exn
;                   'message "exception-handler returned")))
;        (old-handler var)))))
;
;;;; set current-exception-handler
;(current-exception-handler bind-exception-handler)

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

  (bind (x (y z)) '(1 #(2 3)) (where (x integer?)) (list x y z))

will result in '(1 2 3) while

  (bind (_ ("y" z)) '(1 #("y" z)) z)

will produce 3

]|#

;;; (bind pat (where . fenders) .. seq xpr ....)
;;; ---------------------------------------------
;;; binds pattern variables of pat to corresponding subexpressions of
;;; seq and executes body xpr .... in this context, provided all
;;; fenders pass
(define-syntax bind
  (macro-rules _ (where)
    ((bind pat (where . fenders) seq xpr . xprs)
     (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))))
       (fenders->tests
         (lambda (fenders)
           (apply append
                  (map (lambda (pair)
                         (map (lambda (p?)
                                `(,p?  ,(car pair)))
                              (cdr pair)))
                       fenders))))
       (destruc
         (lambda (pat seq)
           (let loop ((pat pat) (seq seq) (n 0))
             (if (pair? pat)
               (let ((p (car pat))
                     (recu (loop (cdr pat) seq (+ n 1))))
                 (cond
                   ((pair? p)
                    (let ((g (gensym)))
                      `(((,g (ref ,seq ,n)) ,@(loop p g 0))
                        ,@recu)))
                   ((symbol? p)
                    (if (eq? p _)
                      ;; skip
                      recu
                      `((,p (ref ,seq ,n)) ,@recu)))
                   (else ; other atom
                     `((,p (equal? ',p (ref ,seq ,n)))
                       ,@recu))
                   ))
               ;; atom
               (cond
                 ((symbol? pat)
                  (if (eq? pat _) ; skip
                    (loop '() seq `(len ,seq))
                    `((,pat (tail ,seq ,n))))
                  )
                 ((null? pat)
                  `((,pat (zero? (len (tail ,seq ,n))))))
                 (else ; other atom
                   `((,pat (equal? ,pat (tail ,seq ,n)))))))
               )))
       (dbind-ex
         (lambda (binds body)
           (if (null? binds)
             `(begin ,@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)
                    ;(print "YYYYY " `(and ,@(map cadr checks)))
                 `(let ,defs
                    (if (and ,@(map cadr checks))
                      ,(dbind-ex
                         (mappend (lambda (b) (if (pair? (car b)) (cdr b) '()))
                                  binds)
                         `((if (or ,(null? fenders)
                                   ,(cons 'and (fenders->tests
                                                 fenders)))
                             (begin ,@body)
                             (signal-bind-exception
                               'bind
                               "fenders not passed"
                               ,seq
                               ',pat
                               ',(cons 'where fenders)))))
                      (signal-bind-exception
                        'bind
                        "match error"
                        ,seq
                        ',pat
                        ',(cons 'and (map cadr checks))))))
             ))))
       )         
       (let ((gseq 'seq))
         `(let ((,gseq ,seq))
            ,(dbind-ex ;(condition-case
                       ;  (destruc pat gseq)
                       ;  ((exn) (signal-bind-exception
                       ;           'bind
                       ;           "match error"
                       ;           gseq
                       ;           ',pat)))
                       (destruc pat gseq)
                       (cons xpr xprs)))
           )))
    ((bind pat seq xpr . xprs)
     `(bind ,pat (where) ,seq ,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 (y list?)) (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)))))

To improve error messages, we wrap it around an inner version,
bind-case-inner, which does all of the work.
]|#

;;; inner version, not exported
(define-syntax bind-case-inner
  (macro-rules (where)
    ((_ seq (pat (where . fenders) xpr . xprs))
     `(bind ,pat (where ,@fenders) ,seq ,xpr ,@xprs))
    ((_ seq (pat xpr . xprs))
     `(bind ,pat (where) ,seq ,xpr ,@xprs))
    ((_ seq clause . clauses)
     `(condition-case (bind-case-inner ,seq ,clause)
        ((exn type)
         (bind-case-inner ,seq ,@clauses))
        ((exn bind)
         (bind-case-inner ,seq ,@clauses))))))

;;; (bind-case seq (pat (where fender ...) .. xpr ....) ....)
;;; ---------------------------------------------------------
;;; Checks if seq matches pattern pat [satisfying fender ...] ....
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; corresponding body xpr ....
(define-macro (bind-case seq clause . clauses)
  `(condition-case
     (bind-case-inner ,seq ,clause ,@clauses)
     ((exn bind)
      (signal-bind-exception
        'bind-case
        "no match for"
        ,seq
        'in
        ',(map (lambda (cl)
                 (list (car cl) (cadr cl)))
               (cons clause clauses))))))

#|[
The next macro, bindable?, can be used to check, if a
sequence-expression matches a pattern and passes all fenders.
]|#

;;; (bindable? pat (where fender ...) ..)
;;; -------------------------------------
;;; returns a unary predicate which checks, if its argument matches pat
;;; and fulfills the predicates in the list fender ...
;;; Mostly used in fenders of macro-rules and define-macro, but must
;;; then be imported for-syntax.
(define-syntax bindable?
  (macro-rules (where)
    ((_ pat (where . fenders))
     `(lambda (seq)
        (condition-case (bind ,pat (where ,@fenders) seq #t)
          ((exn bind) #f)
          ((exn range) #f))))
    ((_ pat)
     `(bindable? ,pat (where)))))

#|[ 
The following two macros, bind-define and bind-set!, destructure their
sequence arguments with respect to their pattern argument and define or
set! the pattern variables correspondingly.  For example, one can define
multiple procedures operating on a common state

  (bind-define (push top pop)
    (let ((state '()))
      (list
        (lambda (arg) (set! state (cons arg state)))
        (lambda () (car state))
        (lambda () (set! state (cdr state))))))

]|#

;; helper macro for bind-define and bind-set!
(define-syntax bind-def-set!
  (macro-rules _ (where)
    ((bind-def-set! pat (where . fenders) seq def?)
     (let ((sym? (lambda (p)
                   (and (symbol? p)
                        (not (eq? p _))))))
        (let ((aux (let copy ((pat pat))
                     (cond
                       ((sym? pat) (gensym))
                       ((pair? pat)
                        (cons (copy (car pat)) (copy (cdr pat))))
                       (else pat))))
              (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))))))
              (filter
                (lambda (ok? lst)
                  (compress (map ok? lst) lst))))
          (if def?
            `(if ((bindable? ,pat (where ,@fenders)) ,seq)
               (begin
                 ,@(map (lambda (p) `(define ,p ',p))
                        (filter sym? (flatten* pat)))
                 (bind ,aux ,seq
                   ,@(map (lambda (p a) `(set! ,p ,a))
                          (filter sym? (flatten* pat))
                          (filter sym? (flatten* aux)))))
               (signal-bind-exception 'bind-define
                                      "fenders not passed"
                                      ',seq
                                      ',pat
                                      '(where ,@fenders)))
            `(if ((bindable? ,pat (where ,@fenders)) ,seq)
               (bind ,aux ,seq
                 ,@(map (lambda (p a) `(set! ,p ,a))
                        (filter sym? (flatten* pat))
                        (filter sym? (flatten* aux))))
               (signal-bind-exception 'bind-set!
                                      "fenders not passed"
                                      ',seq
                                      ',pat
                                      '(where ,@fenders)))))))
    ))


;;; (bind-define pat (where fender ...) .. seq)
;;; -------------------------------------------
;;; destructures the sequence seq according to the pattern pat and sets
;;; pattern variables with values corresponding to subexpressions of
;;; seq, provided the fenders are satisfied
(define-syntax bind-define
  (macro-rules (where)
    ((_ pat (where . fenders) seq)
     `(bind-def-set! ,pat (where ,@fenders) ,seq #t))
    ((_ pat seq)
     `(bind-def-set! ,pat (where) ,seq #t))))

;;; (bind-set! pat (where fender ...) .. seq)
;;; -----------------------------------------
;;; sets pattern variables of pat to corresponding sub-expressins of
;;; seq, provided the fenders are satisfied
(define-syntax bind-set!
  (macro-rules (where)
    ((_ pat (where . fenders) seq)
     `(bind-def-set! ,pat (where ,@fenders) ,seq #f))
    ((_ pat seq)
     `(bind-def-set! ,pat (where) ,seq #f))))

#|[
Now we can define two macros, which simply combine lambda with
bind, the first destructures simply one argument, the second a
whole list. An example of a call and its result is

  ((bind-lambda (a (b . c) . d) (list a b c d))
   '(1 #(20 30 40) 2 3))
  -> '(1 20 #(30 40) (2 3)))))

  ((bind-lambda* ((a (b . c) . d) (e . f))
     (list a b c d e f))
   '(1 #(20 30 40) 2 3) '#(4 5 6))
  -> '(1 20 #(30 40) (2 3) 4 #(5 6)))
]|#

;;; (bind-lambda pat (where fender ...) .. xpr ....)
;;; ------------------------------------------------
;;; combination of lambda and bind, one pattern argument
(define-syntax bind-lambda
  (macro-rules (where)
    ((_ pat (where . fenders) xpr . xprs)
     `(lambda (x) (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
    ((_ pat xpr . xprs)
     `(bind-lambda ,pat (where) ,xpr ,@xprs))))

;;; (bind-lambda* pat (where fender ...) .. xpr ....)
;;; -------------------------------------------------
;;; combination of lambda and bind, multiple pattern arguments
(define-syntax bind-lambda*
  (macro-rules (where)
    ((_ pat (where . fenders) xpr . xprs)
     `(lambda x (bind ,pat (where ,@fenders) x ,xpr ,@xprs)))
    ((_ pat xpr . xprs)
     `(bind-lambda* ,pat (where) ,xpr ,@xprs))))

#|[ 
The next two macros combine lambda and bind-case and do more or less the
same as match-lambda and match-lambda* in the matchable package. The
first destructures one argument, the second a list of arguments.
Here is an example together with its result:

  ((bind-case-lambda
     ((a (b . c) . d) (list a b c d))
     ((e . f) (where (e zero?)) e)
     ((e . f) (list e f)))
   '(1 2 3 4 5))
  -> '(1 (2 3 4 5))

  ((bind-case-lambda*
     (((a (b . c) . d) (e . f))
      (list a b c d e f)))
   '(1 #(20 30 40) 2 3) '(4 5 6))
  -> '(1 20 #(30 40) (2 3) 4 (5 6))
]|#

;;; (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
;;; ------------------------------------------------------------
;;; combination of lambda and bind-case, one pattern argument
(define-syntax bind-case-lambda
  (macro-rules (where)
    ((_ (pat (where . fenders) xpr . xprs))
     `(lambda (x)
        (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
    ((_ (pat xpr . xprs))
     `(lambda (x)
        (bind-case x (,pat ,xpr ,@xprs))))
    ((_ clause . clauses)
     `(lambda (x)
        (bind-case x ,clause ,@clauses)))))

;;; (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
;;; -------------------------------------------------------------
;;; combination of lambda and bind-case, multiple pattern arguments
(define-syntax bind-case-lambda*
  (macro-rules (where)
    ((_ (pat (where . fenders) xpr . xprs))
     `(lambda x
        (bind-case x (,pat (where ,@fenders) ,xpr ,@xprs))))
    ((_ (pat xpr . xprs))
     `(lambda x
        (bind-case x (,pat ,xpr ,@xprs))))
    ((_ clause . clauses)
     `(lambda x
        (bind-case x ,clause ,@clauses)))))

#|[
The following macro, bind*, is a named version of bind. It takes an
additional argument besides those of bind, which is bound to a
recursive procedure, which can be called in bind's body. The pattern
variables are initialised with the corresponding subexpressions in seq.
For example

  (bind* loop (x y) '(5 0)
    (if (zero? x)
      (list x y)
      (loop (list (sub1 x) (add1 y)))))
  -> '(0 5)
]|#

;;; (bind* name pat seq (where fender ...) .. xpr ....)
;;; ---------------------------------------------------
;;; named version of bind
(define-syntax bind*
  (macro-rules (where)
    ((_ name pat (where . fenders) seq xpr . xprs)
     `((letrec ((,name 
                  (bind-lambda ,pat (where ,@fenders) ,xpr ,@xprs)))
         ,name)
       ,seq))
    ((_ name pat seq xpr . xprs)
     `(bind* ,name ,pat (where) ,seq ,xpr ,@xprs))))

#|[
Now the implementation of a nested version of let, named and unnamed,
is easy: Simply combine bind and bind*. For example

  (bind-let (
     (((x y) z) '((1 2) 3))
     (u (+ 2 2))
     ((v w) '(5 6))
     )
     (list x y z u v w))
  -> '(1 2 3 4 5 6)

  (bind-let loop (((a b) '(5 0)))
    (if (zero? a)
      (list a b)
      (loop (list (sub1 a) (add1 b)))))
  -> '(0 5)
]|#

;;; (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
;;; -----------------------------------------------------------------
;;; nested version of let, named and unnamed
(define-syntax bind-let
  (let ((last (lambda (lst)
                (let loop ((lst lst))
                  (if (null? (cdr lst))
                    (car lst)
                    (loop (cdr lst))))))
        (extract-fenders
          (lambda (pairs)
            (apply append
                   (map cdadr
                        (compress
                          (map (lambda (pair)
                                 (= (length pair) 3))
                               pairs)
                          pairs))))))
    (macro-rules (where)
      ((_ loop () xpr . xprs)
       `(let ,loop () ,xpr ,@xprs))
      ((_ loop ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
       `(bind* ,loop
          ,(cons pat0 (map car pat-seq-pairs))
          (where ,@(append fenders
                           (extract-fenders pat-seq-pairs)))
          (list ,seq0 ,@(map last pat-seq-pairs))
          ,xpr ,@xprs))
      ((_ loop ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
       `(bind* ,loop
          ,(cons pat0 (map car pat-seq-pairs))
          (where ,@(extract-fenders pat-seq-pairs))
          (list ,seq0 ,@(map last pat-seq-pairs))
          ,xpr ,@xprs))
      ((_ () xpr . xprs)
       `(let () ,xpr ,@xprs))
      ((_ ((pat0 (where . fenders) seq0) . pat-seq-pairs) xpr . xprs)
       `(bind
          ,(cons pat0 (map car pat-seq-pairs))
          (where ,@(append fenders
                           (extract-fenders pat-seq-pairs)))
          (list ,seq0 ,@(map last pat-seq-pairs))
          ,xpr ,@xprs))
      ((_ ((pat0 seq0) . pat-seq-pairs) xpr . xprs)
       `(bind
          ,(cons pat0 (map car pat-seq-pairs))
          (where ,@(extract-fenders pat-seq-pairs))
          (list ,seq0 ,@(map last pat-seq-pairs))
          ,xpr ,@xprs))
    )))

#|[
The sequential version of bind-let should work as follows

  (bind-let* (
     (((x y) z) '((1 2) 3))
     (u (+ 1 2 x))
     ((v w) (list (+ z 2) 6))
     )
     (list x y z u v w))
  -> '(1 2 3 4 5 6)
]|#

;;; (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
;;; ----------------------------------------------------------
;;; sequential version of bind-let
(define-syntax bind-let*
  (macro-rules (where)
    ((_ () xpr . xprs)
     `(let () ,xpr ,@xprs))
    ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
     `(bind ,pat (where ,@fenders) ,seq
        (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))
    ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
     `(bind ,pat ,seq
        (bind-let* ,pat-seq-pairs ,xpr ,@xprs)))))

#|[
And here is the recursive version of bind, which is used in bind-letrec.

  (bindrec ((o?) e?)
    (list (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
    (list (o? 95) (e? 95)))
  -> '(#t #f)
]|#

;;; (bindrec pat (where fender ...) .. seq xpr ....)
;;; ------------------------------------------------
;;; recursive version of bind
(define-syntax bindrec
  (macro-rules (where)
    ((_ pat (where . fenders) seq xpr . xprs)
     `(if ((bindable? ,pat) ,seq)
        (bind ,pat ',pat
          ; bind pattern variables to auxiliary values
          ; so that they are in scope
          (bind-set! ,pat (where ,@fenders) ,seq)
          ; set! the real values
          ,xpr ,@xprs)
        (signal-bind-exception 'bindrec
                               "fenders not passed"
                               ',seq
                               ',pat
                               '(where ,@fenders))))
    ((_ pat seq xpr . xprs)
     `(bindrec ,pat (where) ,seq ,xpr ,@xprs))))

#|[
The recursive version of bind-let works as follows
  
  (bind-letrec (
    ((o? (e?))
     (list (lambda (m) (if (zero? m) #f (e? (- m 1))))
           (vector (lambda (n) (if (zero? n) #t (o? (- n 1)))))))
    )
    (list (o? 95) (e? 95)))
  -> '(#t #f)
]|#

;;; (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
;;; ------------------------------------------------------------
;;; recursive version of bind-let
(define-syntax bind-letrec
  (let ((last (lambda (lst)
                (let loop ((lst lst))
                  (if (null? (cdr lst))
                    (car lst)
                    (loop (cdr lst))))))
        (extract-fenders
          (lambda (pairs)
            (apply append
                   (map cdadr
                        (compress
                          (map (lambda (pair)
                                 (= (length pair) 3))
                               pairs)
                          pairs))))))
    (macro-rules (where)
      ((_ ((pat (where . fenders) seq) . pat-seq-pairs) xpr . xprs)
       `(bindrec ,(cons pat (map car pat-seq-pairs))
          (where ,@(append fenders
                           (extract-fenders pat-seq-pairs)))
          (list ,seq ,@(map last pat-seq-pairs))
          ,xpr ,@xprs))
      ((_ ((pat seq) . pat-seq-pairs) xpr . xprs)
       `(bindrec ,(cons pat (map car pat-seq-pairs))
          (where ,@(extract-fenders pat-seq-pairs))
          (list ,seq ,@(map last pat-seq-pairs))
          ,xpr ,@xprs))
      ((_ () xpr . xprs)
       `(let () ,xpr ,@xprs))
    )))

#|[ 
The following macro is sometimes named let/cc or let-cc
]|#

;;; (bind/cc cc xpr ....)
;;; ---------------------
;;; captures the current continuation, binds it to cc and executes
;;; xpr .... in this context
(define-macro (bind/cc cc xpr . xprs)
  `(call-with-current-continuation
     (lambda (,cc) ,xpr ,@xprs)))

;;; (bindings sym ..)
;;; ----------------------
;;; documentation procedure
(define bindings
  (symbol-dispatcher '(
    (bind
      macro:
      (bind pat (where fender ...) .. seq xpr ....)
      "a variant of Common Lisp's destructuring-bind")
    (bind-case
      macro:
      (bind-case seq (pat (where fender ...) .. xpr ....) ....)
      "matches seq against pat with optional fenders in a case regime")
    (bindable?
      macro:
      (bindable? pat (where fender ...) ..)
      "returns a unary predicate, which checks"
      "if its argument matches pat and passes all fenders")
    (bind-set!
      macro:
      (bind-set! pat (where fender ...) .. seq)
      "sets multiple variables by destructuring its sequence argument")
    (bind-define
      macro:
      (bind-define pat (where fender ...) .. seq)
      "defines multiple variables by destructuring its sequence argument")
    (bind-lambda
      macro:
      (bind-lambda pat (where fender ...) .. xpr ....)
      "combination of lambda and bind, one pattern argument")
    (bind-lambda*
      macro:
      (bind-lambda* pat (where fender ...) .. xpr ....)
      "combination of lambda and bind, multiple pattern arguments")
    (bind*
      macro:
      (bind* loop pat (where fender ...) .. seq xpr ....)
      "named version of bind")
    (bind-let
      macro:
      (bind-let loop .. ((pat (where fender ...) .. seq) ...) xpr ....)
      "nested version of let, named and unnamed")
    (bind-let*
      macro:
      (bind-let* ((pat (where fender ...) .. seq) ...) xpr ....)
      "nested version of let*")
    (bindrec
      macro:
      (bindrec pat (where fender ...) .. seq xpr ....)
      "recursive version of bind")
    (bind-letrec
      macro:
      (bind-letrec ((pat (where fender ...) .. seq) ...) xpr ....)
      "recursive version of bind-let")
    (bind-case-lambda
      macro:
      (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)
      "combination of lambda and bind-case with one pattern argument")
    (bind-case-lambda*
      macro:
      (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)
      "combination of lambda and bind-case with multiple pattern arguments")
    (bind/cc
      macro:
      (bind/cc cc xpr ....)
      "binds cc to the current contiunation"
      "and execute xpr ... in this context")
    (bind-exception
      procedure:
      (bind-exception loc msg arg ...)
      "generates a composite condition with location symbol, string message"
      "and passible additional arguments arg ...")
    (signal-bind-exception
      procedure:
      (bind-exception loc msg arg ...)
      "signals a composite condition with location symbol, string message"
      "and passible additional arguments arg ...")
    (bind-exception-handler
      procedure:
      (bind-exception-handler var)
      "to be passed to the parameter current-exception-handler")
    (bind-table-show
      procedure:
      (bind-table-show)
      "pretty prints the sequence table")
    (bind-table-add!
      procedure:
      (bind-table-add! type? len ref tail)
      "adds a new table item to the front of the sequence table")
    (list-of
      procedure:
      (list-of ok? ...)
      "generates a list predicate which checks all of its arguments")
    (pseudo-list-of
      procedure:
      (pseudo-list-of ok? ...)
      "generates a pseudo-list predicate which checks all of its arguments")
    (vector-of
      procedure:
      (vector-of ok? ...)
      "generates a vector predicate which checks all of its arguments")
    (symbol-dispatcher
      procedure:
      (symbol-dispatcher alist)
      "generates a procedure of zero or one argument showing all"
      "cars or the cdr or the alist item with symbol as car")
    )))
  ) ; bind-functor

(module bindings = bind-functor
  (import scheme
          (only bind-sequences
                bind-seq-length bind-seq-ref bind-seq-tail))
  (define len bind-seq-length)
  (define ref bind-seq-ref)
  (define tail bind-seq-tail))

(module list-bindings = bind-functor
  (import scheme)
  (define len length)
  (define ref list-ref)
  (define tail list-tail))

;(use sequences)
;;; uses matchable, which bindings can replace
;(module sequence-bindings = bind-functor
;  (import scheme sequences)
;  (define len size)
;  (define ref elt)
;  (define tail sub))