#|[
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.
]|#

(require-library low-level-macros)

#|[
The bindings module below should demonstrate the power of destructuring
and low-level-macros. It exports a lot of binding constructs, which are
all implemented as low-level macros, albeit most of them could be
implemented as syntax-rules macros as well. The most fundamental macro,
bind, is a version of Common Lisp's destructuring-bind, but it can
destructure arbitrary sequences, accepts an optional where-clause and
even non-symbol literals. The latter is important only for bind-case and
friends, which are alternatives to corrensponding macros of the
matchable package.
]|#

(module bindings
  (export bindings
          bindable?  bind-case bind-let bind-let* bind-letrec
          bindrec bind-lambda bind-lambda* bind* bind-set!
          bind bind-define bind-case-lambda bind-case-lambda*)


  (import scheme
          (only macro-helpers
                seq-length seq-ref seq-tail
                bind-exception
                symbol-dispatcher)
          (only chicken
                condition-case 
                print gensym
                current-exception-handler
                make-property-condition
                condition-predicate
                get-condition-property
                signal abort))
  (reexport (only macro-helpers
                  bind-exception
                  seq-length
                  seq-ref
                  seq-tail
                  seq-length-ref-tail!))
  (import-for-syntax (only macro-helpers
                           flatten-map*
                           map*
                           seq-destruc
                           dbind-ex
                           dbind-lit
                           dbind-len
                           dbind-def)
                     (only low-level-macros
                           macro-rules)
                     (only chicken
                           receive))
  
#|[
Documentation dispatcher
]|#
(define bindings
  (symbol-dispatcher '(
    (bind-set!
      macro;
      (bind-set! pat seq)
      "sets multiple variables by destructuring its sequence argument")
    (bind-define
      macro:
      (bind-define pat seq)
      "defines multiple variables by destructuring its sequence argument")
    (bind
      macro:
      (bind pat seq (where . fenders) .. xpr ....)
      "a variant of Common Lisp's destructuring-bind")
    (bindable?
      macro:
      (bindable? pat . fenders)
      "returns a unary predicate, which checks"
      "if its argument matches pat and passes all fenders")
    (bind-lambda
      macro:
      (bind-lambda pat (where . fenders) .. xpr ....)
      "combination of lambda and bind, one pattern argument")
    (bind-lambda*
      macro:
      (bind-lambda* pat (where . fenders) .. xpr ....)
      "combination of lambda and bind, multiple pattern arguments")
    (bindrec
      macro:
      (bindrec pat seq (where . fenders) .. xpr ....)
      "recursive version of bind")
    (bind*
      macro:
      (bind* loop pat seq (where . fenders) .. xpr ....)
      "named version of bind")
    (bind-let
      macro:
      (bind-let loop .. ((pat seq) ...) xpr ....)
      "nested version of let, named and unnamed")
    (bind-let*
      macro:
      (bind-let* ((pat seq) ...) xpr ....)
      "nested version of let*")
    (bind-letrec
      macro:
      (bind-letrec ((pat seq) ...) xpr ....)
      "recursive version of bind-let")
    (bind-case
      macro:
      (bind-case seq (pat (where . fenders) .. xpr ....) ....)
      "matches seq against pat with optional fenders in a case regime")
    (bind-case-lambda
      macro:
      (bind-case-lambda (pat (where . fenders) .. xpr ....) ....)
      "combination of lambda and bind-case with one pattern argument")
    (bind-case-lambda*
      macro:
      (bind-case-lambda* (pat (where . fenders) .. xpr ....) ....)
      "combination of lambda and bind-case with multiple pattern arguments")
    )))

#|[
Let's start with a new exception-handler, which is able to cope with
bind exceptions
]|#

(current-exception-handler
  (let ((old-handler (current-exception-handler)))
    (lambda (var)
      (if ((condition-predicate 'bind) var)
        (begin
          (display "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)))))

#|[ 
The first two macros are nested versions of set! and define. They allow
the simultaneous definition of procedures which have access to common
state. In fact, it suffices to implement bind-set! since Chicken
reduces define to set! anyway: try (expand '(define a 1)) to convince
yourself.  So we could implement bind-define as an alias to bind-set!
But according to the standard, set! changes existing variables, while
define defines new ones. So our definition will reflect this.

bind-set! replaces the values of symbols in a nested lambda-list in one
go with the corresponding subeseqessions of its second argument. So,
after (bind-set! (a (b (c . d))) '(1 (2 (3 4 5)))) d should have the
value (4 5), b the value 2 etc.
bind-define does the same, but defines the pattern variables before
setting them. The real advantage of this is, that we can define several
functions which rely on the same encapsulated state. Consider

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

Now we have three procedures, which all operate on the encapsulated
list.

The implementation uses the fourth procedure, dbind-def, which operates
on the return values of seq-destruc.
]|#

;;; (bind-define pat seq)
;;; ---------------------
;;; destructures seq according to pat and sets pattern variables
;;; with values corresponding to subexpressions of seq
(define-syntax bind-define
  (macro-rules ()
    ((_ pat seq)
     (let ((gseq 'seq))
       `(begin (define ,gseq ,seq)
               ,(dbind-def 'define (seq-destruc pat gseq)))))))
;(define-macro (bind-define pat seq)
;  (let ((gseq 'seq))
;    `(begin (define ,gseq ,seq)
;            ,(dbind-def 'define (seq-destruc pat gseq)))))

;;; (bind-set! pat seq)
;;; -------------------
;;; destructures seq according to pat and defines pattern variables
;;; with values corresponding to subexpressions of seq
(define-syntax bind-set!
  (macro-rules ()
    ((_ pat seq)
     (let ((gseq 'seq))
       `(begin (set! ,gseq ,seq)
               ,(dbind-def 'set! (seq-destruc pat gseq)))))))
;(define-macro (bind-set! pat seq)
;  (let ((gseq 'seq))
;    `(begin (set! ,gseq ,seq)
;            ,(dbind-def 'set! (seq-destruc pat gseq)))))


#|[
The next macro, bind, is the work-horse for all what follows.  It is a
variant of Common Lisp's destructuring-bind, whence destructures
arbitrary sequences, but also accepts non-symbol literals and allows for
a where clause with fenders.
]|#

;;; (bind pat seq (where . fenders) .. xpr . xprs)
;;; ----------------------------------------------
;;; binds pattern variables of pat to corresponding subexpressions of
;;; seq and executes tthe body xpr . xprs in this context. If a where
;;; expression is supplied, all fenders must return #t for seq to be
;;; successfully bound.
(define-syntax bind
  (macro-rules (where)
    ((_ pat seq (where . fenders) xpr . xprs)
     (let ((gseq 'seq))
        `(let ((,gseq ,seq))
           ,(receive (symbols literals checks)
              (seq-destruc pat gseq)
              `(if ,(dbind-len checks)
                 (if ,(dbind-lit literals)
                   ,(dbind-ex symbols
                              `((and ,@fenders) ,xpr ,@xprs))
                   (signal
                     (bind-exception 'bind
                                     "literals don't match"
                                     ',literals)))
                 (signal (bind-exception 'bind
                                         "not matchable"
                                         ',pat ,gseq)))))))
    ((_ pat seq xpr . xprs)
     `(bind ,pat ,seq (where) ,xpr ,@xprs))))

;;; (bindable? pat . fenders)
;;; -------------------------
;;; returns a unary predicate which checks, if its argument matches pat
;;; and fulfills the predicates in the list fenders
(define-syntax bindable?
  (macro-rules ()
    ((_ pat . fenders)
     `(lambda (seq)
        (condition-case
          (bind ,pat seq (and ,@fenders))
          ((exn bind) #f))))))
;(define-macro (bindable? pat . fenders)
;  `(lambda (seq)
;     (condition-case
;       (bind ,pat seq (and ,@fenders))
;       ((exn bind) #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 xpr . xprs)
;;; --------------------------------
;;; combination of lambda and bind, one pattern argument
(define-syntax bind-lambda
  (macro-rules (where)
    ((_ pat (where . fenders) xpr . xprs)
     `(lambda (x) (bind ,pat x (where ,@fenders) ,xpr ,@xprs)))
    ((_ pat xpr . xprs)
     `(lambda (x) (bind ,pat x ,xpr ,@xprs)))))

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

#|[
And here is the recursive version of bind.

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

It's definition is patterned after a procedural definition of letrec:

  (define-macro (my-letrec pairs . body)
    (let ((vars (map car pairs))
          (vals (map cadr pairs))
          (aux (map (lambda (x) (gensym)) pairs)))
      `(let ,(map (lambda (var) `(,var #f)) vars)
         (let ,(map (lambda (a v) `(,a ,v)) aux vals)
           ,@(map (lambda (v e) `(set! ,v ,e)) vars vals)
           ,@body))))

Note, how simple this is, compared with the syntax-rules definition in
R5RS
]|#

;;; (bindrec pat seq xpr . xprs)
;;; ----------------------------
;;; recursive version of bind
(define-syntax bindrec
  (macro-rules (where)
    ((_ pat seq (where . fenders) xpr . xprs)
     (let ((aux (map* gensym pat)))
       `(let ,(flatten-map* (lambda (v) `(,v #f)) pat)
          (bind ,aux ,seq
            #t ; fenders belong to pat, not aux
            ,@(flatten-map* (lambda (x y) `(set! ,x ,y))
                            pat aux)
            (if (and ,@fenders)
              (begin ,xpr ,@xprs)
              (signal (bind-exception 'bindrec
                                      "fenders not passed"
                                      ',fenders)))))))
    ((_ pat seq xpr . xprs)
     `(bindrec ,pat ,seq (where) ,xpr ,@xprs))))

#|[
The macro bind* is to bind what named let is to let. 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 subexpressins
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 . fenders) .. xpr . xprs)
;;; ----------------------------------------------------
;;; named version of bind
(define-syntax bind*
  (macro-rules (where)
    ((_ loop pat seq (where . fenders) xpr . xprs)
     `((letrec ((,loop 
                  (bind-lambda ,pat (where ,@fenders) ,xpr ,@xprs)))
        ,loop)
      ,seq))
    ((_ loop pat seq xpr . xprs)
     `((letrec ((,loop
                  (bind-lambda ,pat ,xpr ,@xprs)))
        ,loop)
      ,seq))))

#|[
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 seq) ...) xpr . xprs)
;;; ---------------------------------------------
;;; nested version of let, named and unnamed
(define-syntax bind-let
  (macro-rules ()
    ((_ loop () xpr . xprs)
     `(let ,loop () ,xpr ,@xprs))
    ((_ loop ((pat seq) . pairs) xpr . xprs)
     `(bind* ,loop (,pat ,@(map car pairs))
        (list ,seq ,@(map cadr pairs)) ,xpr ,@xprs))
    ((_ () xpr . xprs)
     `(begin ,xpr ,@xprs))
    ((_ ((pat seq) . pairs) xpr . xprs)
     `(bind (,pat ,@(map car pairs)) (list ,seq ,@(map cadr 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 seq) ...) xpr . xprs)
;;; --------------------------------------
;;; sequential version of bind-let
(define-syntax bind-let*
  (macro-rules ()
    ((_ () xpr . xprs)
     `(let () ,xpr ,@xprs))
    ((_ ((pat seq) . pairs) xpr . xprs)
     `(bind ,pat ,seq (bind-let* ,pairs ,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 seq) ...) xpr . xprs)
;;; ----------------------------------------
;;; recursive version of bind-let
;(define-macro (bind-letrec pairs xpr . xprs)
;  `(bindrec ,(map car pairs) (list ,@(map cadr pairs))
;     ,xpr ,@xprs))
(define-syntax bind-letrec
  (macro-rules ()
    ((_ pairs xpr . xprs)
     `(bindrec ,(map car pairs) (list ,@(map cadr pairs))
        ,xpr ,@xprs))))

#|[
The next macro, bindable?, can be used to check, if a
sequence-expression matches a pattern and passes all fenders. It's used
in bind-case below.
The implementation relies on bind, which must be protected against exceptions.
]|#

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

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

or, to give a more realistic example, mapping:

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

;;; (bind-case seq (pat (where . fenders) .. xpr . xprs) ....)
;;; ----------------------------------------------------------
;;; Checks if seq matches pattern pat [satisfying fenders] ....
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; corresponding body xpr . xprs
(define-syntax bind-case
  (macro-rules (where)
    ((_ seq (pat (where . fenders) xpr . xprs) . clauses)
     `(condition-case (bind ,pat ,seq (where ,@fenders) ,xpr ,@xprs)
       ((exn bind) (bind-case ,seq ,@clauses))))
    ((_ seq (pat xpr . xprs) . clauses)
     `(condition-case (bind ,pat ,seq ,xpr ,@xprs)
       ((exn bind) (bind-case ,seq ,@clauses))))
    ((_ seq)
     `(signal (bind-exception 'bind-case
                             "no rule matches"
                             ,seq)))
    ))

#|[ 
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 (zero? e)) 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 . fenders) .. xpr . xprs) ....)
;;; -------------------------------------------------------------
;;; 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 ,pat x (where ,@fenders) ,xpr ,@xprs)))
    ((_ (pat xpr . xprs))
     `(lambda (x) (bind ,pat x ,xpr ,@xprs)))
    ((_ clause . clauses)
     `(lambda (x)
       (bind-case x ,clause ,@clauses)))))

;;; (bind-case-lambda* (pat (where . fenders) .. xpr . xprs) ....)
;;; --------------------------------------------------------------
;;; 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 ,pat x (where ,@fenders) ,xpr ,@xprs)))
    ((_ (pat xpr . xprs))
     `(lambda x (bind ,pat x ,xpr ,@xprs)))
    ((_ clause . clauses)
     `(lambda x
       (bind-case x ,clause ,@clauses)))))

) ; module bindings