; Author: Juergen Lorenz, ju (at) jugilo (dot) de
;
; Copyright (c) 2013-2019, Juergen Lorenz
; All rights reserved.
; 
; Redistribution and use in source and binary forms, with or without
; modification, are permitted provided that the following conditions are
; met:
; 
; Redistributions of source code must retain the above copyright
; notice, this list of conditions and the following dispasser.
; 
; Redistributions in binary form must reproduce the above copyright
; notice, this list of conditions and the following dispasser in the
; documentation and/or other materials provided with the distribution.
; 
; Neither the name of the author nor the names of its contributors may be
; used to endorse or promote products derived from this software without
; specific prior written permission. 
; 
; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
; IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
; TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
; PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
; HOLDERS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

(module bindings (
  bind
  bind-set!
  bindrec
  bind-case
  bindable?
  bind-lambda
  bind-lambda*
  bind-case-lambda
  bind-case-lambda*
  bind*
  bind-let*
  bind-let
  bind-letrec
  bind-define
  bind/cc
  bind-seq->list
  bind-pvars
  bindings
  )

(import scheme
        (only (chicken condition) condition-case)
        (only (chicken base) void receive identity print case-lambda error)
        (only (chicken keyword) keyword?)
        (only (chicken format) format)
        )

(import-for-syntax (only (chicken keyword) keyword?))

(define (split-along pat lst) ; internal
  (let loop ((pat pat) (tail lst) (head '()))
    (if (pair? pat)
      (if (pair? tail)
        (loop (cdr pat) (cdr tail) (cons (car tail) head))
        (error 'bind-set!
               (format #f "template ~s doesn't match pattern ~s~%"
                       tail pat)))
      (values (reverse head) tail))))

;;; (bind-seq->list)
;;; (bind-seq->list seq)
;;; (bind-seq->list pat seq)
;;; (bind-seq->list seq? seq->list list->seq)
;;; -----------------------------------------
;;; the first version resets the internal database,
;;; the second the two transformers corresponding to seq,
;;; the third the transformed list, where the value of the possible
;;; dotted pattern variable is retransformed to the type of seq,
;;; and the last adds support for a new sequence type.
(define bind-seq->list
  (let ((db (list (cons (lambda (x) #t)
                        (cons identity
                              identity)))))
    (case-lambda
      (() (set! db ; reset
            (list (cons (lambda (x) #t)
                        (cons identity identity)))))
      ((seq)
       (let loop ((db db))
         (if ((caar db) seq)
           (cdar db)
           (loop (cdr db)))))
      ((pat seq)
       (let ((transformers
               (bind-seq->list seq)))
         (receive (head tail)
           (split-along pat ((car transformers) seq))
           (append head ((cdr transformers) tail)))))
      ((seq? seq->list list->seq)
       (set! db (cons (cons seq?
                            (cons seq->list list->seq)) db)))
      )))

;;; (bind-pvars pat)
;;; ----------------
;;; returns the list of pattern variables of the pattern
;;; or error in case of duplicates
(define (bind-pvars pat)
  (let ((result '()))
    (let loop ((pat pat))
      (cond
        ((pair? pat)
         (loop (car pat))
         (loop (cdr pat)))
        ((and (symbol? pat)
              (not (eq? pat '_)))
         (if (memq pat result)
             (error 'bind-pvars
                    (format #f "duplicates: ~s already in ~s~%"
                            pat result))
             (set! result (cons pat result))))
        (else (void))))
    (reverse result)))

;#|[
;bind-set! is the macro, which does all the dirty work. It destructures
;the pattern and the template in parallel, checks if literals match and
;if length' are equal, checks for duplicate pattern variables, and
;handles the wildcard, which matches everything but binds nothing.
;Because of the wildcard, _, the macro will be unhygienic, hence must
;be implemented procedurally. This has the additional advantage, that
;some the branching code can be evaluated at compile time. 

;]|#

;;; (bind-set! pat seq)
;;; -------------------
;;; sets pattern variables of pat to the corresponding subexpression of
;;; seq, which might be arbitrary nested sequences, if bind-seq->list is
;;; prepared accordingly
(define-syntax bind-set!
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((pat (cadr form))
            (seq (caddr form))
            (%_ (rename '_))
            (%if (rename 'if))
            (%pair? (rename 'pair?))
            (%bind-set! (rename 'bind-set!))
            (%error (rename 'error))
            (%format (rename 'format))
            (%null? (rename 'null?))
            (%let (rename 'let))
            (%begin (rename 'begin))
            (%seq (rename 'seq))
            (%pat (rename 'pat))
            (%car (rename 'car))
            (%cdr (rename 'cdr))
            (%void (rename 'void))
            (%set! (rename 'set!))
            (%char=? (rename 'char=?))
            (%string=? (rename 'string=?))
            (%= (rename '=))
            (%eq? (rename 'eq?))
            (%bind-pvars (rename 'bind-pvars))
            (%bind-seq->list (rename 'bind-seq->list))
            )
        `(,%let ((,%pat ',pat) (,%seq ,seq))
           (,%bind-pvars ,%pat) ;check for duplicates
           ,(cond
              ((pair? pat)
               `(,%let ((,%seq (,%bind-seq->list ,%pat ,%seq)))
                        ; transform seq to pseudolist
                  (,%if (,%pair? ,%seq)
                    (,%begin
                      (,%bind-set! ,(car pat) (,%car ,%seq))
                      (,%bind-set! ,(cdr pat) (,%cdr ,%seq)))
                    (,%error 'bind-set!
                             (,%format
                               #f
                               "template ~s doesn't match pattern ~s\n"
                               ;,seq ',pat)))))
                               ,seq ,%pat)))))
              ((null? pat)
               `(,%if (,%null?
                        ((,%car (,%bind-seq->list ,%seq)) ,%seq))
                 (,%void)
                 (,%error 'bind-set!
                        (,%format #f
                                "template ~s doesn't match pattern ~s"
                                ,seq '()))))
              ;; symbols
              ((symbol? pat)
               (if (compare? pat %_) ; wildcard
                 `(,%void)
                 `(,%set! ,pat ,%seq)))
              ;; literals
              ((char? pat)
               `(,%if (,%char=? ',pat ,%seq)
                  (,%if #f #f) ;(,%void)
                  (,%error 'bind-set!
                        (,%format #f "strings ~s and ~s not char=?~%"
                                ',pat ,%seq))))
              ((string? pat)
               `(,%if (,%string=? ',pat ,%seq)
                  (,%if #f #f) ;(,%void)
                  (,%error 'bind-set!
                        (,%format #f "strings ~s and ~s not string=?~%"
                                ',pat ,%seq))))
              ((number? pat)
               `(if (,%= ',pat ,%seq)
                  (,%if #f #f) ;(,%void)
                  (,%error 'bind-set!
                        (,%format #f "numbers ~s and ~s not =~%"
                                ',pat ,%seq))))
              ((boolean? pat)
               `(,%if (,%eq? ',pat ,%seq)
                 (,%if #f #f) ;(,%void)
                 (,%error 'bind-set!
                        (,%format #f "booleans ~s and ~s not eq?~%"
                                ',pat ,%seq))))
              ((keyword? pat)
               `(,%if (,%eq? ',pat ,%seq)
                  (,%if #f #f) ;(,%void)
                  (,%error 'bind-set!
                        (,%format #f "keywords ~s and ~s not eq?~%"
                                ',pat ,%seq))))
              ))))))

#|[
bind-define is simply an alias to bind-set!
]|#

;;; (bind-define pat seq)
;;; ---------------------
;;; destructures the sequence seq according to the pattern
;;; pat and sets pattern variables with values
;;; to corresponding subexpressions of seq
(define-syntax bind-define
  (syntax-rules ()
    ((_ pat seq)
     (bind-set! pat seq))))

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

For example

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

will result in '(1 2 3) while

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

will produce 3.

After adding vector and string support

  (bind-seq->list string? string->list list->string)
  (bind-seq->list vector? vector->list list->vector)

it will destructure vectors and strings as well:

  (bind (x (y z)) '(1 #(2 3)) (list x y z))
  (bind (x (y z)) '(1 "12") (list x y z))

]|#

;;; (bind pat seq xpr ....)
;;; -----------------------
;;; binds pattern variables of pat to corresponding subexpressions of
;;; lst and executes body xpr .... in this context.
;;; Fenders are implemented in client code by the >> macro of the
;;; checks egg.
(define-syntax bind
  (syntax-rules ()
    ((_ pat seq xpr . xprs)
     (begin
       (bind-set! pat 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) (>> 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)))))
]|#

;;; (bind-case seq (pat xpr ....) ....)
;;; -----------------------------------
;;; Checks if seq matches patterns pat  ....
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; body expressions xpr .... in this context
(define-syntax bind-case
  (syntax-rules ()
    ((_ seq)
     (error 'bind-case "no match for" seq))
    ((_ seq (pat xpr . xprs))
     (condition-case (bind pat seq xpr . xprs)
       ((exn) (bind-case seq))))
    ((_ seq clause . clauses)
     (condition-case (bind-case seq clause)
       ((exn) (bind-case seq . clauses))))
    ))

;;; (bindable? pat)
;;; ---------------
;;; returns a unary predicate which checks, if its arguments match pat
(define-syntax bindable?
  (syntax-rules ()
    ((_ pat)
     (lambda (seq)
        (condition-case (bind pat seq #t)
          ((exn) #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 ....)
;;; --------------------------
;;; combination of lambda and bind, one pattern argument
(define-syntax bind-lambda
  (syntax-rules ()
    ((_ pat xpr . xprs)
     (lambda (x) (bind pat x xpr . xprs)))
    ))

;;; (bind-lambda* pat xpr ....)
;;; ---------------------------
;;; combination of lambda and bind, multiple pattern arguments
(define-syntax bind-lambda*
  (syntax-rules ()
    ((_ pat xpr . xprs)
     (lambda x (bind pat x 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 (note the >> fender):

  ((bind-case-lambda
     ((a (b . c) . d) (list a b c d))
     ((e . f) (>> 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 xpr ....) ....)
;;; --------------------------------------
;;; combination of lambda and bind-case, one pattern argument
(define-syntax bind-case-lambda
  (syntax-rules ()
    ((_ (pat xpr . xprs))
     (lambda (x)
       (bind-case x (pat xpr . xprs))))
    ((_ clause . clauses)
     (lambda (x)
       (bind-case x clause . clauses)))
    ))

;;; (bind-case-lambda* (pat xpr ....) ....)
;;; ---------------------------------------
;;; combination of lambda and bind-case, multiple pattern arguments
(define-syntax bind-case-lambda*
  (syntax-rules ()
    ((_ (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 xpr ....)
;;; ---- -----------------------------
;;; named version of bind
(define-syntax bind*
  (syntax-rules ()
    ((_ name pat seq xpr . xprs)
     ((letrec ((name (bind-lambda pat xpr . xprs)))
        name)
      seq))))

#|[
The following three macros are analoga of the standard base macros let,
let* and letrec, the first named or unnamed. For example

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

A recursive version of bind follows
]|#

;;; (bind-let* ((pat seq) ...) xpr . xprs)
;;; --------------------------------------
;;; sequentually binding patterns to sequences
(define-syntax bind-let*
  (syntax-rules ()
    ((_ () xpr . xprs)
     (let () xpr . xprs))
    ((_ ((pat seq)) xpr . xprs)
     (bind pat seq xpr . xprs))
    ((_ ((pat seq) (pat1 seq1) ...) xpr . xprs)
     (bind pat seq (bind-let* ((pat1 seq1) ...) xpr . xprs)))
     ))

;;; (bind-let name .. ((pat seq) ...) xpr . xprs)
;;; ---------------------------------------------
;;; binding patterns to sequences in parallel, whith or without a
;;; recursive name procedure
(define-syntax bind-let
  (syntax-rules ()
    ((_ ((pat seq) ...) xpr . xprs)
     (bind (pat ...) (list seq ...) xpr . xprs))
    ((_ name ((pat seq) ...) xpr . xprs)
     ((letrec ((name (bind-lambda* (pat ...) xpr . xprs)))
        name)
      seq ...))
    ))

;;; (bind-letrec ((pat seq) ...) xpr . xprs)
;;; ----------------------------------------
;;; binding patterns to sequences recursively
(define-syntax bind-letrec
  (syntax-rules ()
    ((_ ((pat seq) ...) xpr . xprs)
     (bind-let ((pat 'pat) ...)
       (bind-set! (pat ...) (list seq ...))
       xpr . xprs))))
    
;;; (bindrec pat seq xpr . xprs)
;;; ----------------------------
;;; recursive version of bind
(define-syntax bindrec
  (syntax-rules ()
    ((_ pat seq xpr . xprs)
     (bind pat 'pat
       (bind-set! pat seq)
       xpr . xprs))))

#|[
I don't like the let/cc syntax, because it differs from let syntax,
here is bind/cc, which does the same.
]|#

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

(define (symbol-dispatcher alist) ; internal
  (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)))))))

;;; (bindings sym ..)
;;; -----------------
;;; documentation procedure
(define bindings
  (symbol-dispatcher '(
    (bindings
      procedure:
      (bindings sym ..)
      "documentation procedure")
    (bind-seq->list
      generic procedure:
      (bind-seq->list)
      "resets the internal database for lists only"
      (bind-seq->list seq)
      "returns the pair of transformers corresponding to seq"
      (bind-seq->list pat seq)
      "returns a list where the value of the possible dotted"
      "argument is retransformed to the type of seq"
      (bind-seq->list seq? seq->list list->seq)
      "adds support for a new sequence type to the"
      "internal database")
    (bind-pvars
      procedure:
      (bind-pvars pat)
      "checks if a pattern contains duplicate pattern variables,"
      "if so calls error, otherwise returns the list of pvars.")
    (bind
      macro:
      (bind pat seq xpr ....)
      "a variant of Common Lisp's destructuring-bind")
    (bind-case
      macro:
      (bind-case seq (pat xpr ....) ....)
      "matches seq against pat with optional fenders in a case regime")
    (bindable?
      macro:
      (bindable? pat)
      "returns a unary predicate, which checks"
      "if its argument matches pat and passes all fenders")
    (bind-set!
      macro:
      (bind-set! pat seq)
      "sets multiple variables by destructuring its sequence arguments")
    (bind-define
      macro:
      (bind-define pat seq)
      "defines multiple variables by destructuring its sequence arguments")
    (bind-lambda
      macro:
      (bind-lambda pat xpr ....)
      "combination of lambda and bind, one pattern argument")
    (bind-lambda*
      macro:
      (bind-lambda* pat xpr ....)
      "combination of lambda and bind, multiple pattern arguments")
    (bind*
      macro:
      (bind* loop pat seq 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*")
    (bindrec
      macro:
      (bindrec pat seq xpr ....)
      "recursive version of bind")
    (bind-letrec
      macro:
      (bind-letrec ((pat seq) ...) xpr ....)
      "recursive version of bind-let")
    (bind-case-lambda
      macro:
      (bind-case-lambda (pat xpr ....) ....)
      "combination of lambda and bind-case with one pattern argument")
    (bind-case-lambda*
      macro:
      (bind-case-lambda* (pat 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")
    )))

) ; module