Outdated egg!

This is an egg for CHICKEN 4, the unsupported old release. You're almost certainly looking for the CHICKEN 5 version of this egg, if it exists.

If it does not exist, there may be equivalent functionality provided by another egg; have a look at the egg index. Otherwise, please consider porting this egg to the current version of CHICKEN.

Destructuring sequence expressions with bindings

Automatic destructuring of expressions is a handy feature, which can be successfully used in writing procedural macros, for example. Some programming languages use it extensively, in particular ML and its descendents Haskell and Miranda. And Chicken offers an egg called matchable, which does it as well.

This library provides an alternative to matchable, a bunch of macros, all starting with the bind prefix, and all being derived from bind and related macros. They all destructure arbitrary mixtures of (pseudo-) lists, vectors and strings, which match a pattern, and can be easily enhanced, to accept other sequence types as well, arrays, for example. For this to be possible, seq-db from the basic-sequences egg is reexported.

The syntax of the fundamental bind macro is as follows

[syntax] (bind pat seq (where fender ...) .. xpr ....)

Here, a pattern, pat, is a nested psudolist of (mostly) symbols, seq a sequencce expression, i.e. a mixture of pseudolists, vectors and strings, fender a check expression on pattern variables, var, of the form (var ok? ...) and xpr .... constitute the body of the macro. Note the special use of dots here and below: Three dots repeat the expression to the left zero or many times, two dots zero or one times and four dots one or many times.

This macro binds pattern variables, i.e. symbols of pat, to corresponding sequenceds of seq, checks, if the fenders succeed and exectutes the body in this context.

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 internal destructure routine.

Second, non-symbol literals, which don't bind anything, of course, but match only expressions evaluating to themselves.

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 checks as well as the fenders are satisfied. If the where clause doesn't pass, the next pattern is tried in bind-case or a seq-exception is signalled in bind.

This version of the library is a complete rewrite. The code no longer uses Graham's dbind implementation. Instead, a direct implementation of bind is given, which doesn't need gensyms. The internal destructure routine transforms the pattern and sequence arguments into three lists, pairs, literals and tails. Pairs is a list of pattern-variable and corresponding sequence-accesscode pairs to be used in a let at runtime, literals and tails check for equality of literals and their corresponding sequence values, and the emptyness of sequence tails corresponding to null patterns respectively. So, contrary to Graham's dbind, an exception is raised if the lengths of a pattern and its corresponding sequence don't match. Fenders are supplied in a where clause at the very beginning of the macro body: A list of pattern-variable predicates pairs is internally transformed into a list of predicate calls.

The latest addition to the library are algebraic types, to be accessed via the binding macros, thus making e.g. define-concrete-type obsolete.

Documentation

bindings

[procedure] (bindings sym ..)

documentation procedure. Shows the exported symbols and the syntax of such an exported symbol, respectively.

seq-db

reexport from the basic-sequences egg

[procedure] (seq-db)

shows the sequence database

[procedure] (seq-db type? ref: ref tail: tail maker: maker ra?: random-access?)

adds a new custom sequence type with predicate type? and keyword arguments ref: tail: maker: ra?: naming procedures to be later accessed as seq-ref, seq-tail, seq-maker and seq-randoam-access? respectively.

Binding macros

bind

[syntax] (bind pat seq (where fender ...) .. xpr ....)

binds pattern variables of pat to subexpressions of seq and executes xpr .... in this context, provided all fenders return #t, if supplied.

bindable?

[syntax] (bindable? pat (where fender ...) ..)

returns a unary predicate which checks, if its sequence argument matches the pattern argument, pat, of bindable? and passes all of its fenders (the syntax is slightly changed for consistency).

bind-case

[syntax] (bind-case seq (pat (where fender ...) .. xpr ....) ....)

Matches seq against a series of patterns and executes the body of the first matching pattern satisfying fenders (if given).

bind-define

[syntax] (bind-define pat seq pat1 seq1 ... (where fender ...) ..)

defines pattern variables of pat pat1 ... with values matching subexpressions of seq seq1 ... in one go

bind-set!

[syntax] (bind-set! pat seq pat1 seq1 ... (where fender ...) ..)

sets symbols of pat pat1 ... to corresponding subexpressions of seq seq1 ...

bind-lambda

[syntax] (bind-lambda pat (where fender ...) .. xpr ....)

combination of lambda and bind, one pattern argument

bind-lambda*

[syntax] (bind-lambda* pat (where fender ...) .. xpr ....)

combination of lambda and bind, multiple pattern arguments

bind-case-lambda

[syntax] (bind-case-lambda (pat (where fender ...) .. xpr ....) ....)

Combination of bind-case and lambda with one pattern argument

bind-case-lambda*

[syntax] (bind-case-lambda* (pat (where fender ...) .. xpr ....) ....)

Combination of bind-case and lambda with multiple pattern arguments

bind-named

[syntax] (bind-named loop pat seq (where fender ...) .. xpr ....)

named version of bind. loop is bound to a procedure, which can be used in the body xpr ....

bindrec

[syntax] (bindrec pat seq (where fender ...) .. xpr ....)

bind pattern variables of pat to subsequences of seq recursively

bind-let

[syntax] (bind-let loop .. ((pat seq) ...) (where fender ...) .. xpr ....)

like let, named and unnamed, but binds patterns to sequence templates. In the named case loop is bound to a one-parameter-procedure accessible in the body xpr ....

bind-let*

[syntax] (bind-let* ((pat seq) ...) (where fender ...) .. xpr ....)

like let*, but binds patterns to sequence templates

bind-letrec

[syntax] (bind-letrec ((patseq) ...) (where fender ...) .. xpr ....)

like letrec, but binds patterns to sequence templates

bind/cc

[syntax] (bind/cc cc xpr ....)

captures the current continuation in cc and executes xpr .... in this context.

define-algebraic-type

[syntax] (define-algebraic-type NAME Name? Constructors ....)

where each Constructor, Name, is one of

 (Name (arg arg? ...) ...)
 (Name (arg arg? ...) ... args args?  ...)

The generated type, NAME, can be destructured with bind, bind-case etc. as tagged vectors with #:Name as tag.

Requirements

simple-exceptions basic-sequences>=2.0

Usage

(use bindings)

Examples


(use bindings)

(let ((stack #f) (push! #f) (pop! #f))
  (bind-set! (stack (push! pop!))
    (list
      '()
      (vector
        (lambda (xpr) (set! stack (cons xpr stack)))
        (lambda () (set! stack (cdr stack))))))
  (push! 1)
  (push! 0)
  stack)
; -> '(0 1)

(begin
  (bind-define (top push! pop!)
    (let ((lst '()))
      (vector
        (lambda () (car lst))
        (lambda (xpr) (set! lst (cons xpr lst)))
        (lambda () (set! lst (cdr lst))))))
  (push! 0)
  (push! 1)
  (pop!)
  (top))
; -> 0

(bind a 1 a)
; -> 1

(bind (x y z w) '(1 2 3 4) (list x y z w))
; -> '(1 2 3 4)

(bind (x . y) '#(1 2 3 4) (list x y))
; -> '(1 #(2 3 4))

(bind (x (y (z u . v)) w) '(1 #(2 "foo") 4)
  (list x y z u v w))
; -> '(1 2 #\f #\o "o" 4)

(bind (x (y (z . u)) v . w) (vector 1 (list 2 (cons 3 4)) 5 6)
  (list x y z u v w))
; -> '(1 2 3 4 5 #(6))

((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-named loop (x (a . b) y) '(5 #(1) 0)
  (where (x integer?))
  (if (zero? x)
    (list x a b y)
    (loop (list (- x 1) (cons a (cons a b)) (+ y 1)))))
; -> '(0 1 (1 1 1 1 1 . #()) 5)

(bind-named loop (x y) '(5 0)
  (if (zero? x)
    (vector x y)
    (loop (vector (- x 1) (+ y 1)))))
; -> '#(0 5)

(bind-let (((x y (z . w)) '(1 2 #(3 4 5))))
  (list x y z w))
; -> '(1 2 3 #(4 5))

(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)))
  (where (a integer?))
  (if (zero? a)
    (list a b)
    (loop (list (- a 1) (+ b 1)))))
; -> '(0 5)

(bind-let loop (
  ((x . y) '(1 2 3))
  ((z) '#(10))
  )
  (where (x integer?) (y (list-of? integer?)) (z integer?))
  (if (zero? z)
    (list x y z)
    (loop (cons (+ x 1) (map add1 y)) (list (- z 1)))))
; -> '(11 (12 13) 0)

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

(bindrec ((o?) e?)
  (vector (list (lambda (m) (if (zero? m) #f (e? (- m 1)))))
          (lambda (n) (if (zero? n) #t (o? (- n 1)))))
  (where (o? procedure?) (e? procedure?))
  (list (o? 95) (e? 95)))
; -> '(#t #f)

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

((bindable? ()) '())
; -> #t

((bindable? (a (b C) . d)) '(1 (2 3) . 4))
; -> #t

((bindable? (a (b C) . d)) '(1 #(2 3) 4 5))
; -> #t

((bindable? (a (b . C) . d)) '(1 (2 3) 4))
; -> #t

((bindable? (a (b . C) . d)) '#(1 2 3 4 5))
; -> #f

((bindable? (a (b C) d)) '(1 (2 3) 4 5))
; -> #f

((bindable? (a b) (even? a)) '#(1 2))
; -> #f 

(bind-case '#(1 2)
  (() '())
  ((a) (list a))
  ((a b) (list a b))
  ((a b C) (list a b C)))
; -> '(1 2))

(define (my-map fn lst)
  (bind-case lst
    (() '())
    ((x . xs) (cons (fn x) (my-map fn xs)))))
(my-map add1 '(1 2 3)))
; -> '(2 3 4)

(define (vector-reverse vec)
  (let ((result (make-vector (vector-length vec) #f)))
    (let loop ((vec vec))
      (bind-case vec
        (() result)
        ((x . xs)
         (vector-set! result
                      (vector-length xs)
                      x)
         (loop (subvector vec 1)))))))
(vector-reverse #(0 1 2 3))
; -> #(3 2 1 0)

((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
   ((e . f) (where (e zero?)) f)
   ((e . f) (list e f)))
 '#(0 2 3 4 5))
;-> '#(2 3 4 5))

((bind-case-lambda
   ((a (b . C) . d) (list a b C d))
   ((e . f) (list e f)))
 '(1 #(2 3 4) 5 6))
; -> '(1 2 #(3 4) (5 6))

((bind-case-lambda*
   (((a b C . d) (e . f))
    (list a b C d e f)))
 '(1 2 3) '#(4 5 6))
; -> '(1 2 3 () 4 #(5 6))

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

;;adding arrays to generic sequence table
(seq-db array?  ref: array-ref tail: array-tail maker: array ra?: #t)

(bind (x y z) (array 1 2 3) (list x y z))
;-> '(1 2 3)

(bind (x (y z)) (vector 0 (array 1 2)) (list x y z))
;-> '(0 1 2)

(bind (x (y . z)) (vector 0 (array 1 2 3 4)) (list x y z))
;-> '(0 1 @(2 3 4))

;; lists as algebraic type
(define-algebraic-type LIST List? (Nil) (Cons (x) (xs List?)))
(define (List->list lst)
  (bind-case (<< lst List?)
    ((#:Nil) '())
    ((#:Cons x xs)
     (cons x (List->list xs)))))
(define three (Cons 0 (Cons 1 (Cons 2 (Nil)))))
(List->list three) ; -> '(0 1 2)

;; typed vectors as algebraic type
(define-algebraic-type VEC Vec? (Vec (x integer?) xs integer?))
(define (Vec->list vec)
  (bind (#:Vec x . xs) (<< vec Vec?)
    (cons x (vector->list (subvector xs 1)))))
(define four (Vec 0 1 2 3))
(Vec->list four) ; -> '(0 1 2 3)

;; typed trees as algebraic type
(define-algebraic-type TREE Tree?
  (Leaf (b number?))
  (Node (left Tree?) (t number?) (right Tree?)))
(define (leaf-sum tr)
  (bind-case (<< tr Tree?)
    ((#:Leaf b) b)
    ((#:Node left middle right)
     (+ (leaf-sum left) middle (leaf-sum right)))))
(define tree (Node (Leaf 1) 2 (Leaf 3)))
(leaf-sum tree) ; -> 6

Copyright (c) 2011-2018, 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.

Version History

7.2: bug with null subpattern fixed
7.1: bind-case now procedural to improve error message
7.0.4: dependency on simple-exceptions updated
7.0: algebraic types added
6.0: complete rewrite, sequences outsourced
5.0: functor implementation, literal rest parameter bug fixed
4.1: macro-rules and friends moved to procedural-macros, where clauses now follow patterns
4.0: code completely rewritten,simplified and reorganized, some small syntax changes
3.5.2: code reorganized again to fix compile problems
3.5.1: code reorganized
3.5: let-macro and letrec-macro added, list-of? replaced by list-of to accept zero to many predicates
3.4: where and key clauses now work together in macro-rules, moreover, macro-rules can be used in define-macro, so it needn't be imported for-syntax
3.3: bindings library split in two; fixed a compile-time bug, thanks to John Foerch and Moritz Heidkamp
3.2: wild-card processing added
3.1: support for once formal parameters, rename-prefix clause moved to parameter, let-macro and letrec-macro changed to er-macro and renamed
3.0.1: bugfix in define-er-macro, bind/cc added, three macros moved to macro-helpers
3.0: library now includes low-level-macros
2.5: all macros are low-level. Module depends on low-level-macros
2.4.1: documentation procedure beautified
2.4: generic functions rewritten, records removed from tests
2.3.4: internal generic-pair? added again bugfixed
2.3.3: exception-handler added, internal generic-pair? removed
2.3.2: bind-case improved, format replaced by print
2.3: code partially rewritten, syntax of bindable? changed, matching records outsourced to the tests
2.2: renamed bind? to bindable?, bind/cc moved to list-bindings
2.1: generics (and hence bind and friends) now accept records, bind/cc added
2.0: bind-matches? and bind-loop changed to bindable? and bind*, where clauses and generic functions added, syms->vars removed
1.0: all binding macros can now destructure arbitrary nested sequences, i.e mixtures of lists, pseudo-lists, vectors and strings; dependency on contracts removed.
0.1: initial import