#+title: GENSHOU: Extensible Effects in Scheme

* Introduction
:PROPERTIES:
:CUSTOM_ID: intro
:END:

This is a literate code file written for the Guile 2021 Potluck.  It describes a system for embedding effectful programs in Scheme, based on a post by Oleg Kiselyov called [[http://okmij.org/ftp/Computation/having-effect.html][Having an Effect]].  Most of the ideas described below are Oleg's; the few original ones arose in the process of translating the original Haskell code to Guile Scheme.  Like any translation, it presented many interesting problems, and the goal was to design a system which played to strengths of Scheme rather than clumsily reproduce Haskell idioms.  The idea of a "reified abort" described in [[#part2][part 2]], for example, was helpful in relating concepts to the Guile ecosystem.

All accompanying code is considered an experiment and is released into the public domain.

To install matching indentation rules in Emacs:

#+begin_src emacs-lisp
(put '%handle 'scheme-indent-function 1)
(put 'handle 'scheme-indent-function 1)
(put 'extend 'scheme-indent-function 1)
(put 'state 'scheme-indent-function 1)
(put 'maybe 'scheme-indent-function 1)
(put 'function 'scheme-indent-function 1)
#+end_src

* Part 1: Simulating Effects
:PROPERTIES:
:CUSTOM_ID: part1
:END:

Consider the following library, which uses the delimited control operators =abort-to-prompt= and =call-with-prompt= to simulate a global state:

#+begin_src scheme
(define state-prompt-tag (make-prompt-tag 'state))

(define (get-state)
  (abort-to-prompt state-prompt-tag 'get))

(define (put-state st)
  (abort-to-prompt state-prompt-tag 'put st))

(define (handle-state st thunk)
  (call-with-prompt state-prompt-tag
    thunk
    (lambda (cont . sig)
      (match sig
        (('get)
         (handle-state st (lambda () (cont st))))
        (('put st)
         (handle-state st (lambda () (cont st))))))))
#+end_src

We can use this library to perform stateful computations without incurring the penalties of actual mutation:

#+begin_src scheme :results replace
(define (fresh)
  (let ((n (get-state)))
    (put-state (1+ n))
    n))

(define (label x)
  (cons x (fresh)))

(handle-state 0 (lambda () (map label '(a b c d e))))
#+end_src

#+RESULTS:
#+begin_example
((a . 0) (b . 1) (c . 2) (d . 3) (e . 4))
#+end_example

The interface above is structured around two /effects/, which submit requests to read or write the state, and a /handler/, which receives these requests and delegates access to it.  It relies on a well-known transformation from continuation-passing style, in which the state is threaded through the program as an additional argument, to direct style using delimited control operators.

Of course, the same effect could be achieved using Guile's support for fluids and dynamic state.  Below, we describe a small system for extending Scheme with arbitrary effects without explicit use of continuations or other language-specific features.  We then see how far we can push it, and achieve some results which may be surprising.

* Part 2: Reifying Control
:PROPERTIES:
:CUSTOM_ID: part2
:END:

In the state example described in [[#part1][part 1]], invoking an effectful function like =get-state= or =put-state= immediately aborts the current continuation.  When this happens, control is transferred to a handler like =handle-state=, and the effect is "run" by plugging the continuation with a value from the context.  As we saw, this process of "trampolining" between a running computation and its context is driven by the control operators =abort-to-prompt= and =call-with-prompt=.  In [[#part2][part 2]], we describe an alternate way of simulating effects which /reifies/ this control pattern onto a data structure.

#+begin_src scheme
(use-modules (ice-9 match)
             (srfi srfi-9))
#+end_src

First, we define a record type which encapsulates the data communicated to the handler of =call-with-prompt=.  Manually destructuring it violates the protocol we establish next, so consider these functions private.

#+begin_src scheme
(define-record-type <request>
  (%make-request cont sig)
  request?
  (sig %request-signature)
  (cont %request-continuation))
#+end_src

Because we are /embedding/ a new domain of values (effects) into Scheme, we need a way to distinguish these from "pure" values. Pure values can freely move between the two domains, while "impure" requests can only be modified by the proper handlers.

#+begin_src scheme
(define (pure x)
  (%make-request #f x))

(define (lower req)
  (if (%request-continuation req)
      (error "Attempt to lower an impure request")
      (%request-signature req)))
#+end_src

Next, we establish a protocol for effects and handlers to communicate with each other.

=Request=, analogous to =abort-to-prompt=, sends a new effect request along a tagged channel.

#+begin_src scheme
(define (request tag . sig)
  (%make-request pure (cons tag sig)))
#+end_src

=Handle=, analogous to =call-with-prompt=, receives effect requests on a channel and attempts to handle them.  Unlike =call-with-prompt=, handling a request object requires routing it through one of two procedures, based on its purity.  The first procedure "lifts" Scheme values into the domain of the effect being handled.  This is simply =pure= in the standard case; sometimes, however, a handler packages up its results in a non-standard way, as we'll see later.  The second procedure is the "handler" proper, analogous to one in =call-with-prompt=: it receives the continuation and a signature describing the effect.

#+begin_src scheme
(define (handle tag req lift handler)
  (let loop ((req req))
    (let ((cont (%request-continuation req))
          (sig (%request-signature req)))
      (if (not cont)
          (lift sig)
          (if (eq? tag (car sig))
              (apply handler cont (cdr sig))
              (%make-request (compose loop cont) sig))))))
#+end_src

This establishes the interface for introducing and eliminating effect requests.  Lastly, we define an interface extending existing requests.  A request is extended by composing it with a continuation; this continuation "waits" for the request to be handled, then constructs a second request from the value returned by the handler.

#+begin_src scheme
(define (extend req cont)
  (let loop ((req req))
    (let ((cont0 (%request-continuation req))
          (sig (%request-signature req)))
      (if (not cont0)
          (cont sig)
          (%make-request (compose loop cont0) sig)))))
#+end_src

Those familiar with monads will recognize =extend= as monadic =bind=.  One way to describe what is meant by extensible effects is to say that we only need to implement one monad.  The request serves as a kind of "meta effect"; all other effects are defined in terms of =pure= and =extend=.

We also specify a dedicated request to serve as the unit of sequential composition[fn:1].  It will be used by effects which do not return a value.

#+begin_src scheme
(define (unit) (pure unit))
#+end_src

This completes the infrastructure necessary for writing effects and handlers.  [[#part3][Part 3]] constructs, piece by piece, an embedded language of effects.  By the end, we hope that the reader will be left with a sense for how it all works and why it may be useful.

* Part 3: Effectful Metalanguage
:PROPERTIES:
:CUSTOM_ID: part3
:END:

** Boolean logic
:PROPERTIES:
:CUSTOM_ID: bools
:END:

To demonstrate how effects communicate with handlers via requests, we start with a toy language which models boolean logic.  This language will then be used to test our language as we go.

Although boolean logic isn't typically considered an effect, treating it as one is a useful exercise.  Besides, we might find other benefits to relaxing our view on what constitutes an effect.

#+begin_src scheme
(define bool-tag '(bool))
#+end_src

Our boolean language has four primitive operations: the values true and false, logical negation and logical conjunction.  =True= and =false= simply send requests for operations of the same name:

#+begin_src scheme
(define (true) (request bool-tag 'true))
(define (false) (request bool-tag 'false))
#+end_src

The negation function =neg= performs a similar request, except that it is parameterized by an input request; the disjunction function =disj= is parameterized by two input requests:

#+begin_src scheme
(define (neg bool)
  (extend bool
    (lambda (p)
      (request bool-tag 'neg p))))

(define (conj bool1 bool2)
  (extend bool1
    (lambda (p)
      (extend bool2
        (lambda (q)
          (request bool-tag 'conj p q))))))
#+end_src

Using =extend=, we bind on the value returned by a request's handler /before that handler is run/, then continue the computation /as if/ it were already handled.

Taking a look at how Guile displays requests such as the one returned by =true= can be instructive:

#+begin_src scheme :results replace
(true)
#+end_src

#+RESULTS:
#+begin_example
#<<request> sig: ((bool) true) cont: #<procedure pure (x)>>
#+end_example

Unlike the effects in [[#part1][part 1]], ours can be passed around, examined and manipulated outside the presence of a handler.

The handler for booleans matches on effect signatures sent along the =bool-tag= channel.  The operation requested is then performed in Scheme, and its return value passed to the continuation.  Like =handle-state= from [[#part1][part 1]], =bool-logic= is recursive, handling further requests raised by the continuation.

#+begin_src scheme
(define (bool-logic req)
  (handle bool-tag
    req
    pure
    (lambda (cont . sig)
      (bool-logic
       (cont
        (match sig
          (('true) #t)
          (('false) #f)
          (('neg p) (not p))
          (('conj p q) (and p q))))))))
#+end_src

Having defined the primitives effects and handler of our boolean language, we can use them to derive new effects for logical disjunction and implication:

#+begin_src scheme
(define (impl bool1 bool2)
  (neg (conj bool1 (neg bool2))))

(define (disj bool1 bool2)
  (impl (neg bool1) bool2))
#+end_src

And run some tests:

#+begin_src scheme
(lower (bool-logic (neg (true))))
#+end_src

#+RESULTS:
#+begin_example
#f
#+end_example

#+begin_src scheme :results replace
(lower (bool-logic
        (disj (false)
              (neg (false)))))
#+end_src

#+RESULTS:
#+begin_example
#t
#+end_example

At any point in the computation, we can inject Scheme booleans using =pure=:

#+begin_src scheme :results replace
(lower (bool-logic
        (impl (neg (pure #f))
              (false))))
#+end_src

#+RESULTS:
#+begin_example
#f
#+end_example

** Errors
:PROPERTIES:
:CUSTOM_ID: errors
:END:

The first "proper" effect we'll implement simulates raising an error.  A program which encounters an error has to abort the current continuation and proceed from an earlier point.

#+begin_src scheme
(define error-tag '(error))

(define (fail)
  (request error-tag))
#+end_src

The =maybe= handler marks the point at which a computation should return on encountering an exception and provides an alternative, encoded lazily as a thunk:

#+begin_src scheme
(define (maybe thunk req)
  (handle error-tag
    req
    pure
    (lambda (_) (thunk))))
#+end_src

The derived effect =satisfy= returns the value returned by a request if it satisfies a predicate and fails otherwise:

#+begin_src scheme
(define (satisfy test req)
  (extend req
    (lambda (x)
      (if (test x) (pure x) (fail)))))
#+end_src

With errors implemented, we can write "safe" versions of the boolean operations defined earlier:

#+begin_src scheme
(define (safe-neg bool)
  (neg (satisfy boolean? bool)))

(define (safe-conj bool1 bool2)
  (conj (satisfy boolean? bool1) (satisfy boolean? bool2)))

(define (safe-disj bool1 bool2)
  (disj (satisfy boolean? bool1) (satisfy boolean? bool2)))

(define (safe-impl bool1 bool2)
  (impl (satisfy boolean? bool1) (satisfy boolean? bool2)))
#+end_src

A test shows how our system automatically propagates errors through an arbitrarily complex computation:

#+begin_src scheme :results replace
(maybe (lambda () "error")
  (bool-logic
   (safe-impl
    (safe-neg (pure 'oops))
    (safe-neg (true)))))
#+end_src

#+RESULTS:
#+begin_example
error
#+end_example

** Dynamic state
:PROPERTIES:
:CUSTOM_ID: state
:END:

Now we briefly return to the state example of [[#part1][part 1]], this time implemented in terms of requests.  The syntax is almost exactly the same, with two exceptions.  =Put= now has to be aware of effects, and =state= now has to decide what to do when it returns.  Usually, we want to do something with the final state, so we package it up with the return value as a pair.

#+begin_src scheme
(define state-tag '(state))

(define (get)
  (request state-tag 'get))

(define (put req)
  (extend req
    (lambda (st)
      (request state-tag 'put st))))

(define (state st req)
  (handle state-tag
    req
    (lambda (x)
      (pure (cons x st)))
    (lambda (cont . sig)
      (match sig
        (('get) (state st (cont st)))
        (('put st) (state st (cont st)))))))
#+end_src

At this point we can write and interpret pretty convoluted computations without worrying about how they compose:

#+begin_src scheme :results replace
(lower
 (maybe (lambda () (pure "error"))
   (state #f
     (bool-logic
      (conj (put (neg (get)))
            (satisfy identity
                     (disj (get)
                           (false))))))))
#+end_src

#+RESULTS:
#+begin_example
'(#t . #t)
#+end_example

** Higher-order Effects

Now that we've built a language capable of running computations involving complex interactions of effects, it may be a good idea to step back.  We've already shown that the system is extensible in one sense: introducing new effects and handlers does not require rewriting earlier ones.  On the other hand, we've lost some of the abstraction available in scheme.

For example, our example demonstrating the state implementation in [[#part1][part 1]] can no longer be written in this language.  Our language is first-order---although we have access to variables and functions by embedding it in Scheme, the effects system itself lacks these powerful means of abstraction.  The question is, can we implement /higher-order effects/?

Surprisingly, we can.  Oleg Kiselyov demonstrates how in the [[http://okmij.org/ftp/Computation/having-effect.html][Having an Effect]] post mentioned above.  We translate it to Scheme below:

#+begin_src scheme
(define higher-order-tag '(higher-order))

(define (variable sym)
  (request higher-order-tag 'var sym))

(define (function sym body)
  (request higher-order-tag 'fun sym body))

(define (higher-order req)
  (let loop ((env '()) (req req))
    (handle higher-order-tag
      req
      pure
      (lambda (cont . sig)
        (loop env
              (match sig
                (('var sym)
                 (match (assq sym env)
                   (#f (fail))
                   ((_ . x) (cont x))))
                (('fun sym body)
                 (cont (lambda (x)
                         (loop (cons (cons sym x) env)
                               body))))))))))
#+end_src

Now all we need is an effectful application function:

#+begin_src scheme
(define (ap fun val)
  (extend (satisfy procedure? fun)
    (lambda (f)
      (extend val f))))
#+end_src

And we can talk about higher-order effects and an effectful lambda calculus!

#+begin_src scheme :results replace
(define id (function 'x (variable 'x)))

(lower (higher-order (ap id (pure 0))))
#+end_src

#+RESULTS:
#+begin_example
0
#+end_example

#+begin_src scheme :results replace
(define inv
  (function 'f
    (function 'p
      (ap (variable 'f)
          (neg (variable 'p))))))
#+end_src

#+begin_src scheme :results replace
(lower
 (higher-order
  (bool-logic
   (ap (ap inv id)
       (false)))))
#+end_src

#+RESULTS:
#+begin_example
#t
#+end_example

That's it, folks.  Happy birthday, Guile! :)

* Footnotes

[fn:1] This representation of the unit type as a "self-referential set" is also taken from [[http://okmij.org/ftp/Scheme/misc.html#unitary-type][Oleg's site]].
[fn:1] This representation of the unit type as a "self-referential set" is also taken from [[http://okmij.org/ftp/Scheme/misc.html#unitary-type][Oleg's site]].