;;;; File: bindings.scm
;;;; Author: Juergen Lorenz
;;;; ju (at) jugilo (dot) de
;;;; Date: Oct 24, 2010
;;;;       Oct 28, 2010
;;;;       Nov 02, 2010
;;;;       Nov 04, 2010
;;;;       Nov 09, 2010
;;;;       Nov 26, 2010
;;;;       Nov 28, 2010
;;;;       Jan 19, 2011
;;;;       Jan 25, 2011
;;;;       Jan 31, 2011
;;;;       Feb 04, 2011
;;;;       Feb 12, 2011
;;;;       Aug 01, 2011
;;;;       Aug 31, 2011


;Binding pattern variables to subsequences
;=========================================
;
;In this module, you'll find macros, which all operate on patterns, that
;is, nested pseudolists of symbols. To be more precise, here is a formal
;definition, which is motivated by the definition of a lambda-list,
;which is the type of the arguments of a lambda expression: A
;lambda-list is either a symbol, the empty list or a pair consisting of
;a symbol and a lambda-list, or - more formally -
;
;lambda-list? :=
;  symbol? | null? | (cons symbol? lambda-list?)
;
;The arguments of macros on the other hand can be more general, namely
;they can be nested. Let's call the appropriate type a pattern, whose
;formal definition is
;
;pattern? :=
;  symbol? | null? | (cons (and pattern? (not null?)) pattern?)
;
;We'll define a list of operators, most of them binding constructs and
;hence macros, which bind pattern variables, i.e. the symbols of a
;pattern, to corresponding subexpressions of an expression and execute
;some body in this scope. The most fundamental of this operators is
;bind, which is roughly the same as destructuring-bind in Common Lisp.
;For example
;
;  (bind (u (v (w . x) y) . z) '(1 (2 (3) 4) 5 6) (list u v w x y z))
;
;will return (1 2 3 () 4 (5 6)). In this example the expression to be
;destructured is a nested list '(1 (2 (3) 4) 5 6) and this is the most
;important case, the one we have used in the contracts module. But as
;Paul Graham in his classic "On Lisp" notes, there is no need to
;restrict oneself to nested lists, arbitrary nested sequences should do
;as well. Unfortunately, standard Scheme doesn't have a sequence
;datatype but Chicken has a corresponding egg. This could be used, but
;this would be sort of overkill, since we need only three sequence
;operators, ref, tail and empty?. Moreover, we want pseudo-lists to be
;considered sequences as well.

(module bindings
    (bindings bind-matches? bind-let bind-let* bind-letrec
    bindrec bind-lambda bind-lambda* bind-loop bind-set! syms->vars
    bind bind-case bind-define bind-case-lambda bind-case-lambda*)

(import scheme 
        (only extras sprintf)
        (only chicken condition-case case-lambda print error gensym))

;We begin with the implementation of bind, following Graham, p.232,
;closely. Since Graham's code doesn't check, if the sequence's length
;matches the length of a list pattern, we add such a check, by simply
;collecting the sequence's tail with index the pattern's length in a
;separate list, checks, and checking each of its items against empty?
;Since all the other macros in this module use bind, we can package the
;needed sequence operators as local procedures in bind itself. So they
;are available at compile-time.
;
;;; (bind pat seq xpr . xprs)
;;; -----------------------------
(define-syntax bind
  (ir-macro-transformer
    (lambda (form inject compare?)
      (letrec (
        (vector-tail
          (lambda (vec from)
            (let* (
              (len (vector-length vec))
              (new-len (- len from))
              (result (make-vector new-len #f))
              )
              (let loop ((k 0))
                (if (= k new-len)
                  result
                  (begin
                    (vector-set! result k (vector-ref vec (+ k from)))
                    (loop (+ k 1))))))))
        ;The sentinel of a pseudo-list can not be referenced with pseudo-ref!
        (pseudo-ref
          (lambda (plst k)
            ;; the extra loop is for a better error message
            (let loop ((pl plst) (n k))
              (if (pair? pl)
                (if (zero? n)
                  (car pl)
                  (loop (cdr pl) (- n 1)))
                ;; the sentinel is not accessed
                (error 'pseudo-ref
                       (sprintf "index ~A out of range for ~A" k plst))))))
        (pseudo-tail
          (lambda (plst k)
            ;; the extra loop is for a better error message
            (let loop ((pl plst) (n k))
              (if (zero? n)
                pl
                (if (pair? pl)
                  (loop (cdr pl) (- n 1))
                  (error 'pseudo-tail
                         (sprintf "index ~A out of range for ~A" k plst)))))))
        (tail
          (lambda (seq from)
            (cond
              ((vector? seq) (vector-tail seq from))
              ((string? seq) (substring seq from))
              ((list? seq) (list-tail seq from))
              (else (pseudo-tail seq from)))))
        (ref
          (lambda (seq k)
            (cond
              ((vector? seq) (vector-ref seq k))
              ((string? seq) (string-ref seq k))
              ((list? seq) (list-ref seq k))
              (else (pseudo-ref seq k)))))
        (empty?
          (lambda (seq)
            (cond
              ((vector? seq) (equal? seq '#()))
              ((string? seq) (equal? seq ""))
              ((list? seq) (null? seq))
              (else (not (pair? seq))))))
        (checks '()) ; to be populated by destruc
        (destruc
          (lambda (pat seq n)
            (if (null? pat)
              (begin
                (set! checks (cons `(',tail ,seq ,n) checks))
                '())
              (let ((rest (if (symbol? pat) pat #f)))
                (if rest
                  `((,rest (',tail ,seq ,n)))
                  (let (
                    (p (car pat))
                    (rec (destruc (cdr pat) seq (+ n 1)))
                    )
                    (if (symbol? p)
                      (cons `(,p (',ref ,seq ,n)) rec)
                      (let ((g (gensym)))
                      ;; (gensym) needn't be renamed, but it doesn't harm
                      ;(let ((g (inject (gensym))))
                        (cons (cons `(,g (',ref ,seq ,n))
                                    (destruc p g 0))
                              rec)))))))))
        (bind-ex
          (lambda (binds body)
            (if (null? binds)
              body
              `(let ,(map (lambda (b) (if (pair? (car b)) (car b) b))
                          binds)
                 ,(bind-ex (apply append
                                   (map (lambda (b)
                                          (if (pair? (car b)) (cdr b) '()))
                                        binds))
                            body)))))
        )
        (let ((pat (cadr form)) (seq (caddr form)) (body (cdddr form)))
          (let ((binds (destruc pat seq 0)))
            (bind-ex binds
                      `(if (and ,@(map (lambda (x) `(',empty? ,x)) checks))
                         (begin ,@body)
                         (error 'bind
                                (sprintf
               "(sub)sequence in ~A too long to match (sub)pattern in ~A~%"
                                ,seq ',pat))))))))))

;The following two macros simply run bind within condition-case and
;handles the case of an exception properly.

;;;(bind-matches? seq pat [ok?])
;;;-----------------------------
;;; checks it a nested sequence expression seq matches a pattern pat.
;;; If a thunk ok? is given, (ok?) must be true as well.
(define-syntax bind-matches?
  (syntax-rules ()
    ((_ seq pat ok?)
     (and (bind-matches? seq pat) (ok?)))
    ((_ seq pat)
     (condition-case
       (bind pat seq #t)
       ((exn) #f)))))

;;; (bind-case seq (pat0 [=> test0] . body0)
;;;                (pat1 [=> test1] . body1)
;;;                ...)
;;; -----------------------------------------
;;; Checks if seq matches patterns pat0 [test0] pat1 [test1] ... 
;;; in sequence, binds the pattern variables of the first matching
;;; pattern to corresponding subexpressions of seq and executes
;;; corresponding body in this context
(define-syntax bind-case
  (syntax-rules (=>)
    ((_ seq (pat => ok? xpr . xprs))
     (bind pat seq
       (if (ok?)
         (begin xpr . xprs)
         (error 'bind-case
                (sprintf "fender ~A rejects sequence ~A matching ~A~%"
                         ok? seq 'pat)))))
    ((_ seq (pat xpr . xprs))
     (bind pat seq xpr . xprs))
    ((_ seq clause0 clause1 ...)
     (condition-case
       (bind-case seq clause0)
       ((exn)
        (bind-case seq clause1 ...))))))

;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 pat xpr . xprs)
;;; --------------------------------
;;; 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 . xprs)
;;; ---------------------------------
;;; 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:
;((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 clause clause1 ...)
;;; -------------------------------------
;;; where each clause is either of the form (pat xpr . xprs)
;;; or (pat => ok? xpr . xprs) with ok? a thunk, which can be used to
;;; reject an otherwise matching pattern.
(define-syntax bind-case-lambda
  (syntax-rules (=>)
    ((_ (pat xpr . xprs))
     (lambda (x) (bind pat x xpr . xprs)))
    ((_ (pat => ok? xpr . xprs))
     (lambda (x) (bind-case x pat => ok? xpr . xprs)))
    ((_ clause clause1 ...)
     (lambda (x)
       (bind-case x clause clause1 ...)))))

;;; (bind-case-lambda* clause clause1 ...)
;;; --------------------------------------
;;; where each clause is either of the form (pat xpr . xprs)
;;; or (pat => ok? xpr . xprs) with ok? a thunk, which can be used to
;;; reject an otherwise matching pattern.
(define-syntax bind-case-lambda*
  (syntax-rules (=>)
    ((_ (pat xpr . xprs))
     (lambda x (bind pat x xpr . xprs)))
    ((_ (pat => ok? xpr . xprs))
     (lambda x (bind-case x pat => ok? xpr . xprs)))
    ((_ clause clause1 ...)
     (lambda x
       (bind-case x clause clause1 ...)))))

;The macro bind-loop 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 proc (x y) '(5 0)
;  (if (zero? x)
;    (list x y)
;    (proc (sub1 x) (add1 y))))
;-> '(0 5)

;The implementation is a combination of letrec and bind-lambda.

;;; (bind-loop loop pat seq xpr . xprs)
;;; ---------------------------------------
;;; named version of bind
(define-syntax bind-loop
  (syntax-rules ()
    ((_ loop pat seq xpr . xprs)
     ((letrec ((loop (bind-lambda pat xpr . xprs))) loop)
     ;((letrec ((loop (lambda (x) (bind pat x xpr . xprs)))) loop)
      seq))))

;Now the implementation of a nested version of let, named and unnamed,
;is easy: Simply combine bind and bind-loop. 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] ((pat0 seq0) ...) xpr . xprs)
;;; ----------------------------------------------
;;; nested version of let, named and unnamed
(define-syntax bind-let
  (syntax-rules ()
    ((_ () xpr . xprs)
     (begin xpr . xprs))
    ((_ ((pat0 seq0) (pat1 seq1) ...) xpr . xprs)
     (bind (pat0 pat1 ...) (list seq0 seq1 ...) xpr . xprs))
    ((_ loop () xpr . xprs)
     (let loop () xpr . xprs))
    ((_ loop ((pat0 seq0) ...) xpr . xprs)
     (bind-loop loop (pat0 ...) (list seq0 ...) 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* ((pat0 seq0) ...) xpr . xprs)
;;; ----------------------------------------
;;; sequential version of bind-let
(define-syntax bind-let*
  (syntax-rules ()
    ((_ () xpr . xprs)
     (let () xpr . xprs))
    ((_ ((pat0 seq0) decl ...) xpr . xprs)
     (bind pat0 seq0 (bind-let* (decl ...) xpr . xprs)))))

;;; (bind-letrec ((pat0 seq0) ...) xpr . xprs)
;;; ------------------------------------------
;;; recursive version of bind-let
(define-syntax bind-letrec
  (syntax-rules ()
    ((_ ((pat0 seq0) ...) xpr . xprs)
     (bindrec (pat0 ...) (list seq0 ...) xpr . xprs))))

;Now, we'll supply a recursive version of bind. The following is a
;rather contrieved example
;(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)
;
;A simplified implementation could look like this
;
;(define-syntax bindrec
;  (syntax-rules ()
;    ((_ pat seq . body)
;     ;; bind pattern variables temporarily to its names ...
;     (bind pat 'pat
;       ;; ... and  set! them
;       (bind-set! pat seq) . body))))
;
;but in fact we use some additional indirection like in the definition
;of letrec. This indirection is supplied in the let line, where we
;define an auxiliary pattern with gensymed names by means of the helper
;helper macro map-pat.
;
;;; (bindrec pat seq xpr . xprs)
;;; --------------------------------
;;; recursive version of bind
(define-syntax bindrec
  (er-macro-transformer
    (lambda (form rename compare?)
      (letrec (
        (map-pat (lambda (fn pat)
                   (cond
                     ((null? pat) '())
                     ((symbol? pat) (fn pat))
                     (else
                       (cons (map-pat fn (car pat))
                             (map-pat fn (cdr pat)))))))
        )
        (let ((pat (cadr form)) (seq (caddr form)) (body (cdddr form)))
          (let (
            (aux (gensym 'aux));(map-pat gensym pat))
            (%let (rename 'let))
            (%bind (rename 'bind))
            (%bind-set! (rename 'bind-set!))
            )
            `(,%let ((,aux ',(map-pat gensym pat)))
               (,%bind ,pat ',pat
                  (,%bind ,aux ,seq
                    (,%bind-set! ,pat ,aux)
                    ,@body)))))))))
;;  (syntax-rules ()
;;    ((_ pat seq xpr . xprs)
;;     (let ((aux (map-pat gensym pat)))
;;       (bind-let* ((pat 'pat) (aux seq))
;;         (bind-set! pat aux) xpr . xprs)))))
;
;;;; (map-pat proc pat)
;;;; ------------------
;;;; This is a helper macro, which is implemented as a macro instead of a
;;;; function, so that it is visible at compile time. It uses the canonical
;;;; depth-first traversal of patterns.
;(define-syntax map-pat
;  (syntax-rules ()
;    ((_ fn (a . b))
;     (cons (map-pat fn a) (map-pat fn b)))
;    ((_ fn ()) '())
;    ((_ fn a) (fn 'a))))

;The next 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. But the real advantage of this is, that
;we can define several functions which rely on the same state. Consider
;
;  (bind-set! (stack push! pop!)
;    (let ((lst '()))
;      (list
;        (lambda () lst)
;        (lambda (seq) (set! lst (cons seq lst)))
;        (lambda () (set! lst (cdr lst))))))
;
;but be sure not to import miscmacros, which defines push! and pop! as
;macros, which would take precedence over identically named procedures.
;Now we have three procedures, which all rely on the encapsulated list
;lst. The same effect could be achieved with
;
;  (bind-set! (stack (push! pop!))
;    (list
;      '()
;      (list
;        (lambda (seq) (set! stack (cons seq stack)))
;        (lambda () (set! stack (cdr stack))))))
;
;but now, stack is not read-only: It could be changed from outside by set!
;
;The implementation uses the bind macro. The idea is simply to
;map the pattern to a new pattern with gensyms as pattern variables,
;then bind these new pattern variables to subexpressions of seq via bind
;and then export a series of (set! var new-var) expressions in bind's
;body. For this to work we need local helper-functions map-pat and
;flatten-pat. The use of local helpers guarantees, that this
;procedures are available at compile time. Otherwise we had to use
;define-for-syntax, which would export these names behind the scene or
;define them in a helper module and use import-for-syntax.
;
;By the way, the choice of local functions which are called outside
;backquotes or inside unquotes guarantees, that the code is evaluated at
;compile-time, thus improving runtime behaviour. Since bind-set! will do
;almost all of the work of the other exported macros as well, it pays
;when most of that work is done at compile-time!

;;; (bind-set! pat seq)
;;; -------------------
;;; destructures seq according to pat and defines pattern variables
;;; with values corresponding to subexpressions of seq
(define-syntax bind-set!
  (er-macro-transformer
    (lambda (form rename compare?)
      (let ((pat (cadr form)) (seq (caddr form)))
        (letrec (
          (map-pat (lambda (fn pat)
                     (cond
                       ((null? pat) '())
                       ((symbol? pat) (fn pat))
                       (else
                         (cons (map-pat fn (car pat))
                               (map-pat fn (cdr pat)))))))
          (flatten-pat (lambda (pat)
                         (cond
                           ((null? pat) '())
                           ((symbol? pat) (list pat))
                           (else
                             (append (flatten-pat (car pat))
                                     (flatten-pat (cdr pat)))))))
          )
          (let (
            (gpat (map-pat gensym pat))
            (%set! (rename 'set!))
            (%bind-lambda (rename 'bind-lambda))
            )
            `((,%bind-lambda ,gpat
                ,@(map (lambda (p g) `(,%set! ,p ,g))
                       (flatten-pat pat) (flatten-pat gpat)))
              ,seq)))))))

;;; (bind-define pat seq)
;;; ---------------------
;;; destructures seq according to pat and sets pattern variables
;;; with values corresponding to subexpressions of seq
(define-syntax bind-define
  (er-macro-transformer
    (lambda (form rename compare?)
      (let (
        (pat (cadr form))
        (seq (caddr form))
        (%bind-set! (rename 'bind-set!))
        (%begin (rename 'begin))
        (%syms->vars (rename 'syms->vars))
        )
        (letrec (
          (flatten-pat (lambda (pat)
                         (cond
                           ((null? pat) '())
                           ((symbol? pat) (list pat))
                           (else
                             (append (flatten-pat (car pat))
                                     (flatten-pat (cdr pat)))))))
          )
          `(,%begin
             (,%syms->vars ,@(flatten-pat pat))
             (,%bind-set! ,pat ,seq)))))))

;This is the needed helper macro, but it may be useful, so it's exported
;;; (syms->vars sym0 sym1 ...)
;;; --------------------------
;;; transforms its argument symbols to variables with their own names as
;;; values
(define-syntax syms->vars
  (syntax-rules ()
    ((_ sym0 sym1 ...)
     (begin
       (define sym0 'sym0)
       (define sym1 'sym1)
       ...))))

(define bindings
  (let (
    (alist '(
      (bind
        "a variant of Common Lisp's destructuring-bind macro"
        (bind pat seq . body)
"Destructures the sequence expression seq according to the pattern pat,
binds pattern variables of pat to corresponding subexpressions of seq
and executes xpr . xprs in this context")
      (bind-set!
        "sets multiple variables by destructuring its sequence argument"
        (bind-set! pat seq)
    "destructures seq according to pat and sets pattern variables
with values corresponding to subexpressions of seq")
      (bind-define
        "defines multiple variables by destructuring its sequence argument"
        (bind-define pat seq)
    "destructures seq according to pat and defines pattern variables
with values corresponding to subexpressions of seq")
      (bind-matches?
        "sequence version of contact's matches?"
        (bind-matches? seq pat)
"checks it a nested sequence expression seq matches a pattern pat.
If a thunk ok? is given, (ok?) must be true as well")
      (bind-case
        "a variant of matchable's match macro."
        (bind-case seq (pat0 [=> test0] . body0)
                       (pat1 [=> test1] . body1) ...)
"Checks if seq matches patterns pat0 [test0] pat1 [test1] ... in sequence,
binds the pattern variables of the first matching pattern to
corresponding subexpressions of seq and executes corresponding body
in this context")
      (bind-lambda
        "combination of lambda and bind, one pattern argument"
        (bind-lambda pat xpr . xprs))
      (bind-lambda*
        "combination of lambda and bind, multiple pattern arguments"
        (bind-lambda* pat xpr . xprs))
      (bind-case-lambda
        "combination of lambda and bind-case with one pattern argument"
        (bind-case-lambda clause clause1 ...)
"where each clause is either of the form (pat xpr . xprs)
or (pat => ok? xpr . xprs) with ok? a thunk, which can be used to
reject an otherwise matching pattern")
      (bind-case-lambda*
        "combination of lambda and bind-case with multiple pattern arguments"
        (bind-case-lambda* clause clause1 ...)
"where each clause is either of the form (pat xpr . xprs)
or (pat => ok? xpr . xprs) with ok? a thunk, which can be used to
reject an otherwise matching pattern")
      (bind-loop
        "named version of bind"
        (bind-loop loop pat seq xpr . xprs)
"where loop evaluates to a one-parameter procedure to be used in xpr . xprs")
      (bind-let
        "nested version of let, named and unnamed"
        (bind-let [loop] ((pat0 seq0) ...) xpr . xprs)
"binds pattern variables of pat0 ... to matching positions of seq0 ...
in parallel and executes body ... in this context. If loop is provided,
it evaluates to a one-parameter procedure available in the body xpr . xprs")
      (bind-let*
        "sequential version of let"
        (bind-let ((pat0 seq0) ...) xpr . xprs)
"binds pattern variables of pat0 ... to matching positions of seq0 ...
sequentially and executes body ... in this context")
      (bind-letrec
        "recursive version of bind-let"
        (bind-letrec ((pat0 seq0) ...) xpr . xprs)
"binds pattern variables of pat0 ... to matching positions of seq0 ...
recursively and executes body ... in this context")
      (bindrec
        "recursive version of bind"
        (bindrec pat seq . body)
"like bind, but seq can contain references to pattern variables in pat")
      (syms->vars
        (syms->vars sym0 sym1 ...)
"transforms its symbol arguments to variables initialized with their names")
      )))
    (case-lambda
      (() (map car alist))
      ((sym)
       (let ((pair (assq sym alist)))
         (if pair
           (cdr pair)
           (print "Choose one of " (map car alist))))))))

) ; module bindings