Destructuring sequence expressions with bindings (historical revision 38806)

You are looking at historical revision 38806 of this page. It may differ significantly from its current revision.

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 destructure nested pseudolists which match a pattern and can be easily enhanced to accept other sequence types as well, vectors, strings, arrays, or what have you. All this sequence types can be nested and mixed as you need it. This flexibility is made possible by one generic function, bind-listify*, which can add three (or four) procedures, seq?, seq-car, seq-cdr (and possibly seq-null?) to its local database and thus supplying support for a new sequence type.

The fundamental bind macro is given in two forms, whith and without a body. The former is a variant of Common Lisp's destructuring-bind, the latter simply set!s pattern variables to the corresponding sequence values.

[syntax] (bind pat seq xpr . xprs)
[syntax] (bind pat seq)

Here, a pattern, pat, is either

a symbol,
a literal (char, string, keyword, boolean or number)
a dotted list
a pair of patterns.

where dotted lists (i.e patterns followed by two, tree or four dots) are new in version 4.0.

seq is a nested sequence expression, i.e. a mixture of pseudolists, vectors and strings (after having added string and vector support to a generic transformer procedure, bind-listify*). This transformer procedure is used to transform seq into a nested list.

Patterns are used to control the destructuring of sequences, bind pattern variables (i.e. symbols in pat except the wildcard, _, which matches everything, but binds nothing) to matching subexpressions of seq and check if literals in pat are equal to matching subexpressions in seq. Since the wildcard binds nothing, it can appear multiple times in the same macro.

Dots might not only follow patterns but also expressions in documentation. Their meaning is

two dots: the expression to the left appears zero or one times,
three dots: zero or many times,
four dots: one or many times.

Documentation

bindings

[procedure] (bindings sym ..)

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

Procedures

bind-listify*

This is a generic procedure. It is closed over a local database which contains the necessary sequence versions of car and cdr and possibly null?

[procedure] (bind-listify*)

resets the internal database for lists only.

[procedure] (bind-listify* seq)

returns the car-cdr-(respectivley car-cdr-null?)-list corresponding to seq's type.

[procedure] (bind-listify* pat seq)

transforms a nested pseudolist with possible wildcard, literals and dotted lists to a an ordinary nested list without.

[procedure] (bind-listify* seq? seq-car seq-cdr)

adds support for a new sequence type with predicate seq? and sequence variants of car and cdr to the internal database.

[procedure] (bind-listify* seq? seq-car seq-cdr seq-null?)

the same as before but with a null?-variant of seq.

vector-car

[procedure] (vector-car vec)

vector-variant of car.

vector-cdr

[procedure] (vector-cdr vec)

vector-variant of cdr.

vector-null?

[procedure] (vector-null? vec)

vector-variant of null?.

string-car

[procedure] (string-car vec)

string-variant of car.

string-cdr

[procedure] (string-cdr vec)

string-variant of cdr.

string-null?

[procedure] (string-null? vec)

string-variant of null?.

Binding macros

bind-list

[syntax] (bind-list pat lst . body)

with body: binds pattern variables of of a nested list patern without wildcard, literals and dotted ends, pat, to corresponding values of a nested list and executes the body in this context.

withoud body: set!s pattern variables of a nested list patern without wildcard, literals and dotted ends, pat, to corresponding values of a nested list.

bind-list!

[syntax] (bind-list! pat lst)
[syntax] (bind-list! pat)

the former is an alias to bind-list without body, the latter is (bind-list! pat 'pat)

bind

[syntax] (bind pat seq . body)

with body: binds pattern variables of a nested patern, pat, possibly with wildcard, literals and dotted ends to corresponding values of a nested sequence, seq, possibly with literals and dotted ends, and executes the body xpr .... in this context.

without body: set!s pattern variables of a nested patern, pat, possibly with wildcard, literals and dotted ends, to corresponding values of a nested sequences, seq, possibly with literals and dotted ends.


(import bindings checks)

;; reset local database to nested pseudolists only
(bind-listify*)

;; add vector and string support
(bind-listify* vector? vector-car vector-cdr)
(bind-listify* string? string-car string-cdr)

(bind-listify* 'a 1) ; -> '(1)
(bind-listify* '(a . as) #(1 2 3))
;-> '(1 #(2 3)))
(bind-listify* '(a (b #f) c) '(1 #(2 #f) 3))
;-> '(1 (2) 3))
(bind-listify* '(a (b (c _ . cs) d) . es) #(1 (2 (3 30 300) 4) 50))
;-> '(1 (2 (3 (300)) 4) #(50)))
(bind-listify* '(a (_ b _) . c) '(1 #(20 30 40) 5))
;-> '(1 (30) (5)))
(bind-listify* '(x y as ... b c) '(-2 -1 1 2 3 40 50))
;-> '(-2 -1 (1 2 3) 40 50)
(bind-listify* '(x y as .. b c) '(-2 -1 40 50))
;-> '(-2 -1 () 40 50)
(bind-listify* '((as (bs cs)) ... d e) '((1 (2 3)) (10 (20 30)) 4 5))
;-> '(((1 10) ((2 20) (3 30))) 4 5)

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

(let ()
  (bind-list! (u v w))
  (and (eq? u 'u) (eq? v 'v) (eq? w 'w)))
: -> #t

(let ((stack #f) (push! #f) (pop! #f))
  (bind! (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
  (define lst '())
  (bind! (top push! pop!)
    (list
      (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 as .... d e) '(-1 0 1 2 3 4 5) (list x y as d e))
;-> '(-1 0 (1 2 3) 4 5)

(bind (x y as .. d e) '(-1 0 4 5)  (list x y as d e))
;-> '(-1 0 () 4 5)

(bind ((as (bs cs)) ... d e)
      '((1 (2 3)) (10 (20 30)) 4 5)
      (list as bs cs d e))
;-> '((1 10) (2 20) (3 30) 4 5)

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

(let ()
  (bind! (a _ (b #f . bs) c))
  (and (eq? a 'a) (eq? b 'b) (eq? bs 'bs) (eq? c 'c)))
; -> #t

((bind-lambda (a (b cs ...) ds ...)
   (list a b cs ds))
 '(1 #(20 30 40) 2 3))
;-> '(1 20 (30 40) (2 3))

((bind-lambda (a (b (cs ds) ...) . es)
   (list a b cs ds es))
 '(1 #(20 (30 40)) 2 3))
;-> '(1 20 (30) (40) (2 3))

((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-loop (x (a . b) y) '(5 #(1) 0)
  (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* loop (x (a . b) y) '(5 #(1) 0)
  (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-loop (x y) '(5 0)
  (if (zero? x)
    (vector x y)
    (loop (vector (- x 1) (+ y 1)))))
; -> #(0 5)

(bind* 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 ((((x y) (zs ..)) '(#(1 2) ()))
           (((us vs) ...) '((3 4) (30 40) (300 400))))
  (list x y zs us vs))
;-> '(1 2 () (3 30 300) (4 40 400))

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

(bind-let loop (((x . y) '(1 2 3))
                ((z) #(10)))
  (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)))))
  (list (o? 95) (e? 95)))
; -> '(#t #f)

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

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

(bindable? (a (b cs .. d)) '(1 (2 3)))
;-> #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) (where (even? a) (odd? b)) '(2 2))
; -> #f

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

(bind-case #(2 2)
  ((a b) (where (even? a) (odd? b)) #f)
  ((a b) (where (odd? a) (even? b)) #f)
  ((a b) (list a b)))
; -> '(2 2)

(bind-case '(0 4)
  ((a bs .... c) #f)
  ((a bs ... c) (list a bs c)))
;-> '(0 () 4)

(bind-case '(0 1 2 3 4)
  ((a bs .. c) #f)
  ((a bs ... c) (list a bs c)))
;-> '(0 (1 2 3) 4)

(bind-case '(0 #(1 (2 3)) 4)
  ((a (bs (cs (ds))) .. e) #f)
  ((a (bs (cs ds)) .. e) (list a bs cs ds e))) 
;-> '(0 (1) (2) (3) 4)

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

((bind-case-lambda
   ((e . f) (where (zero? e)) 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  d))
   ((e . f) (list e f)))
 '(1 #(2 3 4) 5 6))
; -> '(1 2 #(3 4) (5 6))

((bind-case-lambda*
   (((a b  . d) (e . f))
    (list a b  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))

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

4.0 ; dotted patterns added
3.x ; bind-list* removed, bind-list does its job for nested lists only ;;;;;;
3.2: bindable? now in two forms, bind-case improved, both with optional fenders.
3.1: bind* now deprecated, use bind-loop instead.
3.0.1: bugs in bind and bind-listify* fixed
3.0: bind and relatives in two versions, with and without body, bind-listify* replaces bind-seq->list, bind! replaces bind-set! and bind-define
2.1: bind encapsulated in a let
2.0: complete rewrite, code simplified, where clause removed
1.5: prepared for lazy-pairs
1.4: dependency on checks removed
1.3: dependency of << fixed
1.2: bug with null? pattern fixed
1.1: sequence routines prifixed
1.0: chicken-5 port from chicken-4, version 7.1, with modifications