The (aux category) modules

Monads: list, maybe, probability, ziplist, difference lists and state

 Posted on October 21, 2026  |   25 min  |   Massimo Nocentini

(aux category list): the list monad

Introduction

This section tests the list monad, which is a monad that represents non-deterministic computations. A value of type (list a) represents a non-deterministic computation that can produce any of the values in the list. The monad operations allow us to combine these computations in various ways, such as sequencing them with >>= or combining them with ⊕/monad.

Implementation

The list monad is implemented as follows, which defines the monad operations for lists. The return operation creates a singleton list, and the >>= operation uses append-map to apply a function to each element of the list and concatenate the results. The ⊕/monad operation is defined as append, which combines two lists of computations.

(module
  (aux category list)
  *
  (import scheme (chicken base) (only srfi-1 append-map) (aux base))
  (define (return v) (list v))
  (define (>>= m f) (append-map f m))
  (define (fail . args) '())
  (define mempty '())
  (define (mappend l1 l2) (append l1 l2))
  (define (mlog x) (list x))
  (define map/functor map)
  (define (map/applicative flst lst) (append-map (λ (f) (map f lst)) flst))
  (define ⊕₀/monad '())
  (define (⊕/monad m1 m2) (append m1 m2)))

test/empty: pass

Empty list is the identity of list monad.
(define (test/empty _) (⊦= '() (do/monad)))

((eta 0.0) (memory #(12582912 2180256 1048576)) (stdout "") (stderr ""))

test/return: pass

Return lifts a value into the list monad, which creates a singleton list.
(define (test/return _) (⊦= '(4) (do/monad ,4)))

((eta 0.0) (memory #(12582912 2181568 1048576)) (stdout "") (stderr ""))

test/two-returns: pass

Multiple return statements in a do/monad block are implicitly combined with >>=, so the above is equivalent to (return 1) >>= (λ x (let y x) (return (+ x y))).
(define (test/two-returns _) (⊦= '(2) (do/monad (← x ,1) (let y x) ,(+ x y))))

((eta 0.0) (memory #(12582912 2183048 1048576)) (stdout "") (stderr ""))

test/let-pattern: pass

A let clause may destructure a pure value with a pattern, binding its variables for the rest of the block.
(define (test/let-pattern _)
  (⊦= '(3 12)
      (do/monad
        (← x (return/⊕ 1 4))
        (let (,a unquote b) (cons x (* 2 x)))
        ,(+ a b))))

((eta 0.0) (memory #(12582912 2184824 1048576)) (stdout "") (stderr ""))

test/let-unquote: pass

As in ← clauses, the right-hand side of a let clause may be written ,expr; since let binds a pure value, ,expr is the same as expr.
(define (test/let-unquote _)
  (⊦= '((3 1 2))
      (do/monad (let a ,1) (let (,b unquote c) ,(cons 2 3)) ,(list c a b))))

((eta 0.0) (memory #(12582912 2186400 1048576)) (stdout "") (stderr ""))

test/trailing-binding: pass

A ← or let clause binds variables for the clauses that follow it, so ending a block with one is rejected when the block is expanded; a trailing ordinary let form is still just an expression.
(define (test/trailing-binding _)
  (let ((rejected?
          (λ (form)
             (condition-case
               (begin (eval form) #f)
               (e (exn syntax)
                  (and (substring-index
                         "do/monad: a binding clause cannot end the block"
                         ((condition-property-accessor 'exn 'message) e))
                       #t))))))
    (⊨ (rejected? '(do/monad (← x (list 1 2)))))
    (⊨ (rejected? '(do/monad (← (,x) ,1))))
    (⊨ (rejected? '(do/monad (← x ,1) (let y x))))
    (⊨ (rejected? '(do/monad (← x ,1) (let (,a unquote b) (cons x 2)))))
    (⊨ (rejected? '(do/monad (← x ,1) (let (,a ,b) (list x 2)))))
    (⊨ (rejected?
         '(do/monad (← x ,1) (let ((,a ,b) unquote c) (list (list x 2) 3)))))
    (⊨ (rejected? '(do/monad (← x ,1) (let (_ unquote b) (cons x 2)))))
    (⊨ (rejected? '(do/monad (← x ,1) (let (a ,b) (list x 2)))))
    (⊦= '(2) (do/monad (← x ,1) (let ((y x)) (list (+ x y)))))))

((eta 0.002) (memory #(12582912 2207936 1048576)) (stdout "") (stderr ""))

test/pattern-mismatch: pass

A value that does not match the pattern of a ← clause is handed to fail, which is the empty list in the list monad, so non-matching shapes are skipped instead of raising an error.
(define (test/pattern-mismatch _)
  (⊦= '((1 2) (3 4))
      (do/monad (← (,x unquote xs) '((1 2) () (3 4))) ,(cons x xs))))

((eta 0.0) (memory #(12582912 2186216 1048576)) (stdout "") (stderr ""))

test/return/⊕: pass

The return/⊕ function lifts a value into the list monad, but it also allows you to specify multiple values to lift, which are combined with ⊕/monad (which is append for lists). So the above is equivalent to (return/⊕ 1 2 3) >>= (λ x (return/⊕ 4 5 6) >>= (λ y (return/⊕ (+ x y) (- x y)))).
(define (test/return/⊕ _)
  (⊦= '(((1 4) 5 -3)
        ((1 5) 6 -4)
        ((1 6) 7 -5)
        ((2 4) 6 -2)
        ((2 5) 7 -3)
        ((2 6) 8 -4)
        ((3 4) 7 -1)
        ((3 5) 8 -2)
        ((3 6) 9 -3))
      (do/monad
        (← x (return/⊕ 1 2 3))
        (← y (return/⊕ 4 5 6))
        (return/⊕ `((,x ,y) ,(+ x y) ,(- x y))))))

((eta 0.0) (memory #(12582912 2187064 1048576)) (stdout "") (stderr ""))

test/fmap: pass

The map/monad function is the functor operation for the list monad, which applies a function to each value in the list. So the above is equivalent to (map add1 (return/⊕ 1 2 3)).
(define (test/fmap _) (⊦= '(2 3 4) (map/monad add1 (return/⊕ 1 2 3))))

((eta 0.0) (memory #(12582912 2188528 1048576)) (stdout "") (stderr ""))

test/<$>: pass

The <$> function is Haskell's name for map/monad, the functor operation, which maps over the monad with a single bind.
(define (test/<$> _)
  (⊦= '(2 3 4) (<$> add1 (return/⊕ 1 2 3)))
  (⊦= '() (<$> add1 '())))

((eta 0.0) (memory #(12582912 2189960 1048576)) (stdout "") (stderr ""))

test/<*>: pass

The <*> function is the applicative functor operation. It takes a list of functions and a list of values, and applies each function to each value, returning the combined results. So the above is equivalent to
(define (test/<*> _)
  (⊦= '(2 3 4 0 1 2) (<*> (return/⊕ add1 sub1) (return/⊕ 1 2 3))))

((eta 0.0) (memory #(12582912 2191352 1048576)) (stdout "") (stderr ""))

test/kleisli: pass

The o/monad function composes Kleisli arrows right to left, like function composition, while ◇ composes them left to right, so (◇ f g) runs f first; with no arrows both are return.
(define (test/kleisli _)
  (let ((f (λ (x) (list x (* 10 x)))) (g (λ (x) (list (add1 x)))))
    (⊦= '(4 31) ((o/monad g f) 3))
    (⊦= '(4 31) ((◇ f g) 3))
    (⊦= '(3) ((◇) 3))))

((eta 0.0) (memory #(12582912 2190376 1048576)) (stdout "") (stderr ""))

test/list->monad: pass

The monoids->monad function folds a list with a monoid inside the monad; list->monad is its instance at the list monoid ('() , cons).
(define (test/list->monad _)
  (⊦= '((1 2 3)) (list->monad '(1 2 3)))
  (⊦= '(()) (list->monad '()))
  (⊦= '(6) ((monoids->monad 0 +) '(1 2 3))))

((eta 0.0) (memory #(12582912 2192112 1048576)) (stdout "") (stderr ""))

test/lift/monad: pass

The lift/monad function is a convenient way to lift a multi-argument function into the monad. It takes a function and multiple monadic values, and applies the function to the values inside the monad. So the above is equivalent to (return/⊕ 1 2 3) >>= (λ x (return/⊕ 4 5 6) >>= (λ y (return (+ x y))))).
(define (test/lift/monad _)
  (⊦= '(5 6 7 6 7 8 7 8 9) (lift/monad + (return/⊕ 1 2 3) (return/⊕ 4 5 6))))

((eta 0.0) (memory #(12582912 2193904 1048576)) (stdout "") (stderr ""))

test/powerset: pass

The powerset/monad function generates the powerset of a list, which is the set of all subsets of the list. It does this by using filter/monad to filter the list with a predicate that non-deterministically returns true or false for each element, effectively including or excluding each element in the subsets. So the above is equivalent to (filterM (λ (_) (return/⊕ #f #t)) '(1 2 3 4 5)).
(define (test/powerset _)
  (⊦= '(()
        (5)
        (4)
        (4 5)
        (3)
        (3 5)
        (3 4)
        (3 4 5)
        (2)
        (2 5)
        (2 4)
        (2 4 5)
        (2 3)
        (2 3 5)
        (2 3 4)
        (2 3 4 5)
        (1)
        (1 5)
        (1 4)
        (1 4 5)
        (1 3)
        (1 3 5)
        (1 3 4)
        (1 3 4 5)
        (1 2)
        (1 2 5)
        (1 2 4)
        (1 2 4 5)
        (1 2 3)
        (1 2 3 5)
        (1 2 3 4)
        (1 2 3 4 5))
      (powerset/monad '(1 2 3 4 5))))

((eta 0.0) (memory #(12582912 2195344 1048576)) (stdout "") (stderr ""))

(aux category maybe): the maybe monad

Introduction

This section tests the maybe monad, where (just . v) is a computation that succeeded with the value v and the empty list is a computation that failed, short-circuiting every later bind.

Implementation

(module
  (aux category maybe)
  *
  (import scheme (chicken base) (aux base))
  (define (return v) `(just unquote v))
  (define (>>= m f) (match/first m ((just unquote v) (f v)) (else '())))
  (define (fail . args) '()))

test/bind: pass

A failure anywhere in the block makes the whole block fail.
(define (test/bind _)
  (⊦= '(just . 3) (do/monad (← x ,1) (← y (return 2)) ,(+ x y)))
  (⊦= '() (do/monad (← x ,1) (← y (fail)) ,(+ x y))))

((eta 0.0) (memory #(6291456 1875416 1048576)) (stdout "") (stderr ""))

test/return: pass

return takes exactly one value, like in every other monad instance.
(define (test/return _)
  (let ((arity-error?
          (λ args
             (condition-case
               (begin (apply return args) #f)
               (e (exn arity) #t)))))
    (⊨ (arity-error? 1 2 3))
    (⊨ (arity-error?))))

((eta 0.0) (memory #(6291456 1883056 1048576)) (stdout "") (stderr ""))

(aux category prob): the probability monad

Introduction

This section tests the probability monad, where a value of type (Prob a) is a distribution: an association list of outcomes paired with their probabilities. Binding multiplies the probabilities along each path and consolidates outcomes that share the same value by summing their probabilities.

Implementation

(module
  (aux category prob)
  *
  (import
    scheme
    (chicken base)
    (chicken fixnum)
    (only srfi-1 append-map find)
    (only srfi-69
          make-hash-table
          equal?-hash
          hash-table-ref/default
          hash-table-set!)
    (aux base))
  (define (return v) (list (cons v 1)))
  (define (>>= m f)
    (consolidate
      (append-map
        (λ1-match/first
          ((,v unquote p)
           (map (λ1-match/first ((,v* unquote p*) (cons v* (* p p*)))) (f v))))
        m)))
  (define (fail . args) '())
  (define (coin/tf p) (list (cons #t p) (cons #f (- 1 p))))
  (define (consolidate m)
    (let loop ((m m) (acc '()) (n 0) (cells #f))
      (cond ((null? m) (reverse acc))
            ((and (not cells) (fx> n 60))
             (let1 (cells (make-hash-table equal? equal?-hash))
                   (for-each
                     (λ (cell) (hash-table-set! cells (car cell) cell))
                     acc)
                   (loop m acc n cells)))
            (else
             (let* ((vp (car m))
                    (v (car vp))
                    (p (cdr vp))
                    (cell (if cells
                            (hash-table-ref/default cells v #f)
                            (find (λ1-match/first ((,v* . _) (equal? v v*)))
                                  acc))))
               (cond (cell
                      (set-cdr! cell (+ (cdr cell) p))
                      (loop (cdr m) acc n cells))
                     (else
                      (let1 (cell (cons v p))
                            (when cells (hash-table-set! cells v cell))
                            (loop (cdr m) (cons cell acc) (fx+ n 1) cells))))))))))

test/return: pass

Return is the certain distribution, with the exact probability 1 so that the right identity law (>>= m return) = m holds for exact distributions too.
(define (test/return _)
  (⊨ (equal? '((a . 1)) (return 'a)))
  (let ((d '((a . 1/2) (b . 1/2)))) (⊨ (equal? d (>>= d return)))))

((eta 0.0) (memory #(6291456 1885648 1048576)) (stdout "") (stderr ""))

test/exact: pass

Distributions built from exact rationals stay exact through binds, and their total probability is exactly 1.
(define (test/exact _)
  (let ((d (do/monad (← x (coin/tf 1/3)) (← y (coin/tf 1/7)) ,(and x y))))
    (⊨ (equal? '((#t . 1/21) (#f . 20/21)) d))
    (⊨ (exact? (apply + (map cdr d))))))

((eta 0.0) (memory #(6291456 1887264 1048576)) (stdout "") (stderr ""))

test/consolidate: pass

consolidate sums the probabilities of outcomes sharing a value, in first-occurrence order and without mutating its argument; past about 60 distinct values it finds the summed cells through a hash table instead of scanning them.
(define (test/consolidate _)
  (let* ((up (map (λ (i) (cons i 1/300)) (iota 100)))
         (down (map (λ (i) (cons (- 99 i) 1/150)) (iota 100)))
         (m (append up down))
         (m* (map (λ (vp) (cons (car vp) (cdr vp))) m)))
    (⊨ (equal?
         '((#f . 0.5) (#t . 0.5))
         (consolidate '((#f . 0.25) (#t . 0.5) (#f . 0.25)))))
    (⊨ (equal? (map (λ (i) (cons i 1/100)) (iota 100)) (consolidate m)))
    (⊨ (equal? m* m))))

((eta 0.0) (memory #(6291456 1907856 1048576)) (stdout "") (stderr ""))

(aux category ziplist): the ziplist monad

Introduction

This section tests the ziplist monad, whose bind zips rather than nests: the i-th element of (>>= m g) is the i-th element of (g v), where v is the i-th element of m. A pure value is the circular list that repeats it, so it zips with lists of any length.

Implementation

(module
  (aux category ziplist)
  *
  (import scheme (chicken base) (only srfi-1 take every iota) (aux base))
  (define (list-tail/or-false lst i)
    (cond ((null? lst) #f)
          ((zero? i) lst)
          (else (list-tail/or-false (cdr lst) (sub1 i)))))
  (define (list-rho lst)
    (let meet ((t lst) (h lst))
      (cond ((or (null? h) (null? (cdr h))) #f)
            ((eq? (cdr t) (cddr h))
             (let* ((t (cdr t))
                    (start (let S ((a lst) (b t) (n 0))
                             (if (eq? a b) n (S (cdr a) (cdr b) (add1 n)))))
                    (period
                      (let P ((b (cdr t)) (n 1))
                        (if (eq? b t) n (P (cdr b) (add1 n))))))
               (cons start period)))
            (else (meet (cdr t) (cddr h))))))
  (define (>>=/circular m start period g)
    (let* ((images (list->vector (map g (take m (+ start period)))))
           (at (λ (i)
                  (vector-ref
                    images
                    (if (< i start) i (+ start (modulo (- i start) period))))))
           (rhos (map (λ (k) (list-rho (vector-ref images k)))
                      (iota period start)))
           (from (and (every pair? rhos) (apply max start (map car rhos))))
           (cycle (and from (apply lcm period (map cdr rhos))))
           (bound (and from (+ from cycle)))
           (d (let D ((i 0) (acc '()))
                (cond ((eqv? i bound) (reverse acc))
                      ((list-tail/or-false (at i) i)
                       =>
                       (λ (t) (D (add1 i) (cons (car t) acc))))
                      (else (reverse acc))))))
      (when (and bound (= (length d) bound))
            (set-cdr! (list-tail d (sub1 bound)) (list-tail d from)))
      d))
  (define (return x) (list/circular x))
  (define (>>= m g)
    (match/first
      m
      ((,l unquote ,m) (g l))
      (else (match/first
              (list-rho m)
              ((,start unquote period) (>>=/circular m start period g))
              (else (let D ((m* m) (i 0) (acc '()))
                      (cond ((null? m*) (reverse acc))
                            ((list-tail/or-false (g (car m*)) i)
                             =>
                             (λ (t) (D (cdr m*) (add1 i) (cons (car t) acc))))
                            (else (reverse acc)))))))))
  (define (fail . args) '()))

test/pure: pass

A pure value repeats forever as a one-element circular list, so write never returns on it; zipping it with a finite list gives a finite result.
(define (test/pure _)
  (let ((l (do/monad (← x ,3) (← y ,4) (← z ,5) ,(+ x y z))))
    (⊨ (eq? l (cdr l)))
    (⊦= 12 (car l))
    (⊦= '(12 13 14) (do/monad (← x l) (← y '(0 1 2)) ,(+ x y)))))

((eta 0.0) (memory #(6291456 1990504 1048576)) (stdout "") (stderr ""))

test/circular: pass

A circular list of any period zips too: the diagonal is finite as soon as an inner list of the cycle is, otherwise it is circular again, so (>>= m return) gives back m.
(define (test/circular _)
  (⊦= '(1 2) (>>= (list/circular 1 2) (λ (x) (list x x))))
  (⊦= '((1 a) (2 b) (1 c))
      (do/monad (← x (list/circular 1 2)) (← y '(a b c)) ,(list x y)))
  (let ((r (>>= (list/circular 1 2) return)))
    (⊦= '(0 . 2) (list-rho r))
    (⊦= '(1 2) (take r 2)))
  (let ((r (do/monad
             (← x (list/circular 1 2 3))
             (← y (list/circular 'a 'b))
             ,(list x y))))
    (⊦= '(0 . 6) (list-rho r))
    (⊦= '((1 a) (2 b) (3 a) (1 b) (2 a) (3 b) (1 a)) (take r 7)))
  (let ((r (>>= (cons 0 (cons 9 (list/circular 1 2 3)))
                (λ (x) (cons x (cons x (list/circular x 'y)))))))
    (⊦= '(2 . 6) (list-rho r))
    (⊦= '(0 9 1 y 3 y 2 y 1 y) (take r 10))))

((eta 0.0) (memory #(6291456 1992184 1048576)) (stdout "") (stderr ""))

test/diagonal: pass

Binding zips the lists, truncating at the shortest one.
(define (test/diagonal _)
  (⊦= '((1 a) (2 b)) (do/monad (← x '(1 2 3)) (← y '(a b)) ,(list x y)))
  (⊦= '(2 1 2) (<*> (list add1 sub1 sub1) (list 1 2 3))))

((eta 0.0) (memory #(6291456 1993416 1048576)) (stdout "") (stderr ""))

test/false-elements: pass

A #f element is a value like any other, so predicates zip too.
(define (test/false-elements _)
  (⊦= '(#f #t #f) (do/monad (← x '(1 2 3)) ,(even? x)))
  (⊦= '(#f #f) (>>= '(1 2) (λ (v) (list #f #f)))))

((eta 0.0) (memory #(6291456 1994744 1048576)) (stdout "") (stderr ""))

test/truncation: pass

The diagonal stops at the first inner list too short to reach it, rather than skipping it and sliding the later elements out of their index; a value that does not match the pattern of a ← clause goes to fail, the empty list, so the diagonal stops there too.
(define (test/truncation _)
  (⊦= '(x) (>>= '(1 2 3) (λ (v) (if (= v 2) '(a) '(x y z w)))))
  (⊦= '((1 a c d) (2 b c* e))
      (do/monad
        (← x '(1 2 3))
        (← y '(a b))
        (← z '(c c*))
        (← r '(d e f g))
        ,(list x y z r)))
  (⊦= '(1) (do/monad (← (,a unquote b) '((1 . 2) 3 (4 . 5))) ,a)))

((eta 0.0) (memory #(6291456 1996688 1048576)) (stdout "") (stderr ""))

test/associativity: pass

Both sides of the associativity law agree index by index. On ragged inner lists one side may stop earlier: the inner bind on the right truncates at the first index any of its inner lists misses, even when the left side never looks at that index, which is why finite zip lists admit no lawful monad (Haskell's ZipList is only an Applicative).
(define (test/associativity _)
  (let* ((table '#((1 2 0) (2) (0 1 2 1) (3 0 3 2 1)))
         (f (λ (v) (vector-ref table v)))
         (g (λ (v) (reverse (vector-ref table v)))))
    (for-each
      (λ (m)
         (let ((lhs (>>= (>>= m f) g)) (rhs (>>= m (λ (x) (>>= (f x) g)))))
           (⊦= (map (λ (l r) l) lhs rhs) (map (λ (l r) r) lhs rhs))))
      '((0 1 2 3) (2 0 1) (0 2 0 1) (1 0 2) (3 3 3 0) (2 2 2) (3 0)))
    (⊦= '(1 2 3) (>>= (>>= '(3 3 3) f) g))
    (⊦= '(1 2 3) (>>= '(3 3 3) (λ (x) (>>= (f x) g))))))

((eta 0.0) (memory #(6291456 1996040 1048576)) (stdout "") (stderr ""))

(aux category difflist): difference lists

Introduction

This section tests difference lists: a difflist is a function that prepends its content to the list it receives, so appending two of them is function composition, in constant time, and difflist->list applies the result to '().

Implementation

(module
  (aux category difflist)
  *
  (import
    scheme
    (chicken base)
    (chicken pretty-print)
    (only srfi-1 append-map append-reverse)
    (aux base))
  (define-record category-difflist f)
  (set-record-printer!
    category-difflist
    (λ (d port)
       (let ((lst (difflist->list d)) (D (display/port port)))
         (D "⸨")
         (for-each (μ v (D " ") (D v)) lst)
         (D " ⸩"))))
  (define (return x) (make-category-difflist (λ (x*) (cons x x*))))
  (define (>>= m g)
    (let* ((f (category-difflist-f m)) (xs (map g (f '()))))
      (make-category-difflist
        (λ (xs*) (foldr (λ (m* lst) ((category-difflist-f m*) lst)) xs* xs)))))
  (define (fail . args) mempty)
  (define mempty (make-category-difflist (λ (lst) lst)))
  (define (mappend l1 l2)
    (make-category-difflist
      (o (category-difflist-f l1) (category-difflist-f l2))))
  (define (mlog x) (make-category-difflist (λ (xs) (cons x xs))))
  (define (list->difflist l1) (make-category-difflist (λ (l2) (append l1 l2))))
  (define (difflist->list dl) ((category-difflist-f dl) '()))
  (define (reverse/difflist dl)
    (make-category-difflist
      (λ (xs) (append-reverse ((category-difflist-f dl) '()) xs)))))

test/monoid: pass

Appending is composition, and mempty is the identity.
(define (test/monoid _)
  (⊦= '(1 2 3 4 5)
      (difflist->list
        (mappend (list->difflist '(1 2 3)) (list->difflist '(4 5)))))
  (⊦= '(1 2) (difflist->list (mappend mempty (list->difflist '(1 2)))))
  (⊦= '(1 2) (difflist->list (mappend (list->difflist '(1 2)) mempty))))

((eta 0.0) (memory #(6291456 1918504 1048576)) (stdout "") (stderr ""))

test/fail: pass

A failure is the empty difflist, so it drops only its own branch, as '() does in the list monad.
(define (test/fail _)
  (⊦= '() (difflist->list (fail)))
  (⊦= '(1 2) (difflist->list (mappend (fail) (list->difflist '(1 2)))))
  (⊦= '(1 3)
      (difflist->list
        (>>= (list->difflist '(1 2 3))
             (λ (x) (if (= x 2) (fail) (return x))))))
  (⊦= '(1 3 9 9)
      (difflist->list
        (mappend
          (>>= (list->difflist '(1 2 3))
               (λ (x) (if (= x 2) (fail) (return x))))
          (list->difflist '(9 9))))))

((eta 0.0) (memory #(6291456 1920024 1048576)) (stdout "") (stderr ""))

test/reverse: pass

Reversing a difflist reverses its own content only, not the tail it is later given.
(define (test/reverse _)
  (⊦= '(3 2 1) (difflist->list (reverse/difflist (list->difflist '(1 2 3)))))
  (⊦= '(3 2 1 4 5)
      (difflist->list
        (mappend
          (reverse/difflist (list->difflist '(1 2 3)))
          (list->difflist '(4 5)))))
  (⊦= '(4 5 3 2 1)
      (difflist->list
        (mappend
          (list->difflist '(4 5))
          (reverse/difflist (list->difflist '(1 2 3)))))))

((eta 0.0) (memory #(6291456 1921152 1048576)) (stdout "") (stderr ""))

test/mlog: pass

Logging a value appends it as it is, as the list monoid does, so a writer logs the same over both.
(define (test/mlog _)
  (⊦= '(a) (difflist->list (mlog 'a)))
  (⊦= '(1 2)
      (difflist->list
        (W:category-writer-log (W:>>= (W:tell 1) (λ (_) (W:tell 2)))))))

((eta 0.0) (memory #(6291456 1922528 1048576)) (stdout "") (stderr ""))

test/printer: pass

A difflist prints its content, left to right.
(define (test/printer _)
  (⊦= "⸨ 1 2 3 ⸩"
      (with-output-to-string (λ () (display (list->difflist '(1 2 3))))))
  (⊦= "⸨ ⸩" (with-output-to-string (λ () (display mempty)))))

((eta 0.0) (memory #(6291456 1923840 1048576)) (stdout "") (stderr ""))

(aux category state): the state monad

Introduction

This section tests the state monad, Haskell's State s a, where a computation is a transition from a state to the pair of its result and the next state, Haskell's (a, s) tuple; binding threads the state from one computation to the next, strictly, as Haskell's Control.Monad.State.Strict does.

Implementation

A computation is a category-state record around its transition, the image of Haskell's newtype, so that a computation is a type of its own and not any procedure; run-state applies the transition to a state.

(module
  (aux category state)
  *
  (import scheme (chicken base) (aux base))
  (define-record category-state run)
  (set-record-printer! category-state (λ (m port) (display "#<state>" port)))
  (define (run-state m s) ((category-state-run m) s))
  (define (eval-state m s) (car (run-state m s)))
  (define (exec-state m s) (cdr (run-state m s)))
  (define (return v) (make-category-state (λ (s) (cons v s))))
  (define (>>= m f)
    (make-category-state
      (λ (s) (let1 (r (run-state m s)) (run-state (f (car r)) (cdr r))))))
  (define (fail . args)
    (make-category-state
      (λ (s)
         (error "State monad does not support failure"
                `((on ,s) (args unquote args))))))
  (define get (make-category-state (λ (s) (cons s s))))
  (define (put s) (make-category-state (λ (_) (cons (void) s))))
  (define (modify f) (make-category-state (λ (s) (cons (void) (f s)))))
  (define (gets f) (make-category-state (λ (s) (cons (f s) s))))
  (define (state f) (make-category-state f))
  (define (with-state f m) (make-category-state (λ (s) (run-state m (f s))))))

test/return: pass

return answers its value and leaves the state as it is.
(define (test/return _)
  (⊦= '(4 . s) (run-state (return 4) 's))
  (⊦= '(4 . s) (run-state (do/monad ,4) 's)))

((eta 0.0) (memory #(12582912 2230392 1048576)) (stdout "") (stderr ""))

test/get-put: pass

get answers the state, put replaces it, and a later get sees the new one; with-state transforms the state before running a computation.
(define (test/get-put _)
  (⊦= '(3 . 3) (run-state get 3))
  (⊦= (cons (void) 7) (run-state (put 7) 3))
  (⊦= '((3 . 7) . 7)
      (run-state (do/monad (← a get) (put 7) (← b get) ,(cons a b)) 3))
  (⊦= '(10 . 10) (run-state (with-state (λ (s) (* 10 s)) get) 1)))

((eta 0.0) (memory #(12582912 2232216 1048576)) (stdout "") (stderr ""))

test/modify-gets: pass

modify applies a function to the state, gets answers a function of it.
(define (test/modify-gets _)
  (⊦= (cons (void) 6) (run-state (modify (λ (s) (* 2 s))) 3))
  (⊦= '(4 . 3) (run-state (gets add1) 3))
  (⊦= '((a b) b)
      (run-state
        (do/monad
          (modify cdr)
          (← x (gets car))
          (put (list x))
          (gets (λ (s) (cons 'a s))))
        '(z b c))))

((eta 0.0) (memory #(12582912 2233712 1048576)) (stdout "") (stderr ""))

test/state: pass

state embeds a transition that answers the pair of the result and the next state.
(define (test/state _)
  (⊦= '(6 . 4) (run-state (state (λ (s) (cons (* 2 s) (add1 s)))) 3)))

((eta 0.0) (memory #(12582912 2235136 1048576)) (stdout "") (stderr ""))

test/run-eval-exec: pass

run-state answers the pair of the result and the final state, eval-state the result only and exec-state the final state only, as Haskell's runState, evalState and execState.
(define (test/run-eval-exec _)
  (⊦= '(0 . 1) (run-state tick 0))
  (⊦= 0 (eval-state tick 0))
  (⊦= 1 (exec-state tick 0))
  (⊦= 10 (eval-state (with-state (λ (s) (* 10 s)) tick) 1))
  (⊦= 11 (exec-state (with-state (λ (s) (* 10 s)) tick) 1)))

((eta 0.0) (memory #(12582912 2236944 1048576)) (stdout "") (stderr ""))

test/laws: pass

The left identity, right identity and associativity laws hold on every state they are run on.
(define (test/laws _)
  (let ((f (λ (x) (do/monad (modify (λ (s) (cons x s))) ,(* 2 x))))
        (g (λ (y) (do/monad (← s get) (put (list y s)) ,(+ y 1))))
        (m (do/monad (← s get) (put (cons 'm s)) ,(length s))))
    (for-each
      (λ (s0)
         (⊦= (run-state (f 5) s0) (run-state (>>= (return 5) f) s0))
         (⊦= (run-state m s0) (run-state (>>= m return) s0))
         (⊦= (run-state (>>= (>>= m f) g) s0)
             (run-state (>>= m (λ (x) (>>= (f x) g))) s0)))
      '(() (a) (a b c)))))

((eta 0.0) (memory #(12582912 2231432 1048576)) (stdout "") (stderr ""))

test/order: pass

The clauses of a do/monad block run top to bottom, each on the state the previous one left.
(define (test/order _)
  (⊦= '((0 1 2) . 3)
      (run-state (do/monad (← a tick) (← b tick) (← c tick) ,(list a b c)) 0))
  (⊦= '(c b a)
      (exec-state
        (do/monad
          (modify (cut cons 'a <>))
          (modify (cut cons 'b <>))
          (modify (cut cons 'c <>)))
        '())))

((eta 0.0) (memory #(12582912 2232976 1048576)) (stdout "") (stderr ""))

test/when-unless: pass

when/monad and unless/monad run a computation only when a condition holds, or fails, as Haskell's when and unless.
(define (test/when-unless _)
  (⊦= 1 (exec-state (when/monad #t tick) 0))
  (⊦= 0 (exec-state (when/monad #f tick) 0))
  (⊦= 0 (exec-state (unless/monad #t tick) 0))
  (⊦= 1 (exec-state (unless/monad #f tick) 0)))

((eta 0.0) (memory #(12582912 2234352 1048576)) (stdout "") (stderr ""))

test/applicative: pass

<$>, <*> and lift/monad run their computations left to right too, so in (<*> mf mx) the effects of mf come first.
(define (test/applicative _)
  (⊦= '(10 . 2) (run-state (<$> (λ (n) (* 10 n)) tick) 1))
  (⊦= '(1 . 2) (run-state (<*> (do/monad (← n tick) ,(λ (m) (- m n))) tick) 0))
  (⊦= '((0 . 1) . 2) (run-state (lift/monad cons tick tick) 0))
  (⊦= '((0 . 1) . 2) (run-state (zip/monad tick tick) 0)))

((eta 0.0) (memory #(12582912 2236296 1048576)) (stdout "") (stderr ""))

test/strict: pass

Building a computation runs nothing; running (>>= m f) runs m before f is applied to its result, as the strict state monad does.
(define (test/strict _)
  (let* ((log '())
         (m (do/monad
              (← a (state (λ (s) (set! log (cons 'm log)) (cons 1 s))))
              (let _ (set! log (cons 'f log)))
              ,a)))
    (⊦= '() log)
    (⊦= '(1 . s) (run-state m 's))
    (⊦= '(f m) log)))

((eta 0.0) (memory #(12582912 2238264 1048576)) (stdout "") (stderr ""))

test/rerun: pass

A computation is a value: it may be run again, on any state, and it answers the same on the same state.
(define (test/rerun _)
  (let ((m (traverse/monad (λ (x) (do/monad (← n tick) ,(* n x))) '(1 2 3))))
    (⊦= '((0 2 6) . 3) (run-state m 0))
    (⊦= '((10 22 36) . 13) (run-state m 10))
    (⊦= '((0 2 6) . 3) (run-state m 0))))

((eta 0.0) (memory #(12582912 2239440 1048576)) (stdout "") (stderr ""))

test/fail: pass

A value that does not match the pattern of a ← clause goes to fail, which raises an error when the computation runs, as Haskell's fail msg = error msg does, and not when it is built.
(define (test/fail _)
  (let* ((m (do/monad (← (,a unquote b) ,'()) ,a))
         (message
           (condition-case
             (begin (run-state m 's) #f)
             (e (exn) ((condition-property-accessor 'exn 'message) e)))))
    (⊨ (category-state? m))
    (⊨ (and (string? message)
            (substring-index "State monad does not support failure" message)
            #t))
    (⊨ (category-state? (fail 'x)))
    (⊦raises (exn) (run-state (fail 'x) 's))))

((eta 0.0) (memory #(12582912 2247672 1048576)) (stdout "") (stderr ""))

test/long-chain: pass

Chains of a hundred thousand binds run, nested to the right as the traversals build them and to the left as a fold over >>= does.
(define (test/long-chain _)
  (let* ((n 100000)
         (sum (quotient (* n (- n 1)) 2))
         (left (fold (λ (i m) (>>= m (λ (_) (modify (λ (s) (+ s i))))))
                     (return (void))
                     (iota n))))
    (⊦= sum
        (exec-state
          (for-each/monad (λ (i) (modify (λ (s) (+ s i)))) (iota n))
          0))
    (⊦= sum (exec-state left 0))
    (⊦= n (length (eval-state (replicate/monad n tick) 0)))))

((eta 0.393) (memory #(50331648 4642608 1048576)) (stdout "") (stderr ""))

test/representation: pass

A computation is a category-state record, as Haskell's newtype makes State s a a type of its own: a procedure, even one shaped as a transition, is not a computation. run-state does not check its argument, so running a value that is not a computation raises CHICKEN's own error for a record of the wrong type, the cheapest outcome.
(define (test/representation _)
  (⊨ (category-state? (do/monad (← x get) (return x))))
  (⊨ (not (category-state? (λ (s) (cons 1 s)))))
  (⊦raises (exn type) (run-state 42 0)))

((eta 0.0) (memory #(50331648 4648312 1048576)) (stdout "") (stderr ""))

test/traversals: pass

The traversals run their computations left to right, the head first, so effects on the state happen in list order, as Haskell's mapM, sequence, replicateM, mapM_ and foldM do.
(define (test/traversals _)
  (⊦= '(((a . 0) (b . 1) (c . 2)) . 3)
      (run-state
        (traverse/monad (λ (x) (<$> (cut cons x <>) tick)) '(a b c))
        0))
  (⊦= '(() . s) (run-state (traverse/monad (λ (x) tick) '()) 's))
  (⊦= '((0 1 2) . 3) (run-state (replicate/monad 3 tick) 0))
  (⊦= '(() . 0) (run-state (replicate/monad 0 tick) 0))
  (⊦= (cons (list 0 (void) 10) 11)
      (run-state
        (sequence/monad (list tick (modify (λ (s) (* 10 s))) tick))
        0))
  (⊦= '(c b a)
      (exec-state
        (for-each/monad (λ (x) (modify (cut cons x <>))) '(a b c))
        '()))
  (⊦= '(((1 b) (0 a)) . 2)
      (run-state
        (fold/monad
          (λ (acc x) (do/monad (← n tick) ,(cons (list n x) acc)))
          '()
          '(a b))
        0)))

((eta 0.0) (memory #(50331648 4646536 1048576)) (stdout "") (stderr ""))

test/list->monad-is-not-sequence: pass

list->monad is return of the mconcat of a pure list, not Haskell's sequence: given a list of computations it answers that very list, unrun, and leaves the state as it is. To run a list of computations, use sequence/monad.
(define (test/list->monad-is-not-sequence _)
  (⊦= '((1 2) . 0) (run-state (list->monad '(1 2)) 0))
  (⊦= '(1 2) (eval-state (list->monad '(1 2)) 0))
  (let1 (r (run-state (list->monad (list tick tick)) 0))
        (⊦= 0 (cdr r))
        (⊨ (and (= 2 (length (car r))) (every category-state? (car r)))))
  (⊦= '((0 1) . 2) (run-state (sequence/monad (list tick tick)) 0)))

((eta 0.0) (memory #(50331648 4648168 1048576)) (stdout "") (stderr ""))

test/label: pass

The usage example of the module numbers the leaves of a tree left to right: the state is the next number, and the left subtree's effects come before the right one's.
(define (test/label _)
  (⊦= '((((0 . a) 1 . b) 2 . c) . 3) (run-state (label '((a . b) . c)) 0)))

((eta 0.0) (memory #(50331648 4650656 1048576)) (stdout "") (stderr ""))
Categories: scheme 

See also

The (aux anthropic) module The Anthropic Messages API, offline The (aux cml) module Events, threads, synchronous variables, the library and I/O The (aux hakaru10) modules Random sources, distributions, the language, exact inference and examples The (aux kanren) modules Arithmetic, dates, presentation of answers and a union-find miniKanren The (aux games dice-of-doom) module Dice of Doom The (aux machine) modules Environments, the SC machine and the SECD machine The (aux schemer seasoned) module The Seasoned Schemer The (aux continuation) modules Classic operators, escapers, amb and Collatz sequences The (aux timsort) module Sorting and the trace buffer The (aux fds) modules Functional queues and union-find The (aux sxml) module Rendering SXML to HTML The (aux variable) module Logic variables introduced by fresh The (aux tabling) module Memoization and tabled definitions The (aux commons) module Learning tests for CHICKEN Scheme Promises delay and make-promise The Ackermann function On unary numbers, as lists Concurrent ML for CHICKEN Scheme Porting SML/NJ CML as the (aux cml) library CHICKEN Scheme Versions and implementation notes The SBRAL data structure Skew Binary Random-Access Lists Pattern matching Scheme macrology: a generalized pattern matcher The (aux hansei) modules Inference, random sources, lazy lists, logic programming and example models The (aux nondeterministic) module Learning tests for Scheme The (aux stream) modules Streams, streams after SICP, and sequences and power series The (aux unittest) module Bootstrapping a unittest framework Scheme lang: Chez, 48 and Chicken Some docs, refs and containers, respectively. The Reasoned Schemer miniKanren, microKanren and some implementations Aggregation predicates for µkanren Groups, window functions, sets and enumerations miniKanren, live and untagged Quine generation via relational interpreters Pure, declarative, and constructive arithmetic relations A declarative pearl Final shift for call/cc Direct implementation of shift and reset Call with Current Continuation Patterns Cogen in six lines The Seasoned Schemer The Little Schemer Adding generic functions to Scheme Handling control