Experiments in using multicore OCaml effects to simulate dynamically created local effects.

localization.ml

(** * General support for creation of dynamic effects *)

(** We show how to use the multicore Ocaml effects to dynamically generate local
   effects. Such effects are akin to the Eff resources, and they can be used to
   implement ML references.

   The code is based on "Eff directly in OCaml" by Oleg Kiselyov and KC
   Sivaramakrishnan (http://kcsrk.info/papers/caml-eff17.pdf). It was written by
   Andrej Bauer, Oleg Kiselyov, and Stephen Dolan at the Dagstuhl seminar
   "Algebraic Effect Handlers go Mainstream". *)

(** A _resource_ is an instance of an effect that is handled at the top level in
   a specific fashion. It looks a lot like an effect with a "default" handler,
   although it is not (for reasons explained in some talk). Resources can be
   dynamically created at will, with no bound on their number (so they are _not_
   the lift/inject thing).

   We show here how to simulate resources in multicore OCaml, using the
   generative features of first-class modules. *)

(** A resource handler takes a computation [unit -> 'a] and handles it, without
   changing its type. *)

type resource_handler = { hand : 'a . ((unit -> 'a) -> 'a) }

(** An effect for installing a new resource handler. *)

effect Install : resource_handler -> unit

(** The handler for [Install]. Multicore OCaml does not have first-class
   handlers (why?), so we simulate it as a function which accepts a thunked
   computation and handles it. The handler is a lot like the delimited-control
   reset handler. *)

let handle_new computation =
  try
    computation ()
  with
  | effect (Install {hand}) k -> hand (fun x -> continue k x)

(** This completes the generalities. Below we will install the [handle_new] just
   once, on the outside of the main program. (That is, we need _not_ install any
   new handlers when we introduce new local effects.)

   We demonstrate two examples: ML-style references and clocks.

   Both of these are state-like effects that behave like Eff resources. Thus
   they are well-behaved. It's possible to also implement other kinds of local
   effects (because unlike Eff resources we have access to the continuation
   here), for instance backtracking. That sounds pretty scary.
*)

(** ** Example: local state *)

(** Our first example is ML-style references. In order to avoid naming conflicts
   with OCaml, we call them "cells". *)

(** The signature which describes what it means to have state. The handler is
   parametrized by the initial value of the state. *)

module type STATE = sig
  type t
  effect Get : t
  effect Put : t -> unit
  val handler : t -> resource_handler
end

(** We implement state in the standard way. *)

module State (T : sig type t end) : STATE with type t = T.t =
struct
  type t = T.t

  effect Get : t

  effect Put : t -> unit

  let handler x =
    { hand = (fun computation ->
        (match computation () with
         | v -> (fun _ -> v)
         | effect Get k -> (fun (s : t) -> (continue k s) s)
         | effect (Put s) k -> (fun _ -> (continue k ()) s)
        ) x)
    }
end

(** Now we *localize* the state effect. First we define _instances_ of the local
   state effect, which we call _cells_ to avoid naming conflicts with OCaml. *)

(** An instance of an effect is just the module for that effect *)

type 'a cell = (module STATE with type t = 'a)

(** Convenience access functions *)

let get (type a) ((module C) : a cell) = (perform C.Get)
let put (type a) ((module C) : a cell) x = (perform (C.Put x))

(** The function [new_cell x] creates a new instance of state initialized to
   [x], and installs a handler for it. Notice that it is polymorphic in the type
   of the state. *)

let new_cell (type a) (x : a) : a cell =
  let module Local = State (struct type t = a end) in
  perform (Install (Local.handler x)) ;
  (module Local)

(** ** Example: clock *)

(** The second example is just a simple clock which starts at [0]. The clock
   keeps [Time] and progresses with every [Tick]. *)

module type CLOCK =
sig
  effect Tick : unit
  effect Time : int
  val handler : resource_handler
end

(** A functor which creates a clock effect *)

module WatchMaker () : CLOCK =
struct
  effect Tick : unit
  effect Time : int

  let handler =
    { hand = (fun computation ->
        (match computation () with
         | v -> (fun _ -> v)
         | effect Tick k -> (fun c -> (continue k ()) (c + 1))
         | effect Time k -> (fun c -> (continue k c) c)
        ) 0)
    }
end

(** Again, instance of an effect is just the module for that effect *)

type clock = (module CLOCK)

(** Convenience access functions *)

let tick (type a) ((module C) : clock) = (perform C.Tick)
let time (type a) ((module C) : clock) = (perform C.Time)

(** The function [new_clock] creates a new instance of a clock. It is essentially
    the same as the one for cells, except that it is not polymorphic. *)

let new_clock () : clock =
  let module Local = WatchMaker () in
  perform (Install Local.handler) ;
  (module Local)

(** ** Demo *)

(** The main demonstrates demonstrates the use of cells and clock. *)

let main =

(** We only ever need one handle_new at the top level. It takes care of all
    resources of all types. If somehow an instance escapes this handler, it
    will go unhandled. *)

handle_new begin fun () ->

  (** Testing cells: *)

  begin
    let x = new_cell 10 in
    put x (4 + get x) ;
    let y = new_cell 3 in
    put y (get x * get y) ;
    Format.printf "y = %d@." (get y)
  end ;

  (** We can create any number of cells: *)

  begin
    let rec many_cells = function
      | 0 -> []
      | n -> (new_cell n) :: many_cells (n - 1)
    in
    (** A list of 100 cells *)
    let xs = many_cells 100 in
    (** Double every cell *)
    List.iter (fun r -> put r (2 * get r)) xs ;
    (** Sum them up *)
    let s = List.fold_left (fun a r -> a + get r) 0 xs in
    Format.printf "s = %d@." s
  end ;

  (** The cells are and higher-order: *)

  begin
    let x = new_cell 42 in
    let y = new_cell "foo" in
    let z = new_cell (fun x -> let r = new_cell [x] in get r @ get r) in
    let w = new_cell [] in (* of type '_a list cell *)
    let _ = (get x, get y, get z [2], get w) in
    Format.printf "something happened@."
  end ;

  (** Do we get a polymorphic function in the following case? *)
  begin
    let f x = get (new_cell x) in
    let a = f 42 in
    let b = f "foo" in
    Format.printf "a = %d, b = %s@." a b
  end ;

  (** By performing a little dance around the OCaml module system,
      we can handle resources. They can be intercepted! *)

  begin
    (** A handler which intercepts [Get]. *)
    let always_42 (module S : STATE with type t = int) computation =
      try
        computation ()
      with
      | effect S.Get k -> continue k 42
    in
    let x = new_cell 10 in
    Format.printf "1. non-intercepted x = %d@." (get x) ;
    (** Now we handle the instance [x] with the [always_42] handler *)
    always_42 x (fun () ->
        Format.printf "1. intercepted x = %d@." (get x) ;
        put x 17 ; (** Did it _really_ change? *)
        Format.printf "2. intercepted x = %d@." (get x)
      ) ;
    (** Puzzle: what is the value of [x]? *)
    Format.printf "2. non-intercepted x = %d@." (get x)
  end ;

  (** And finally, here are some clocks. To make life interesting we count how
      many recursive calls are performed when we compute a Fibonacci number the
      wrong way. *)
  begin
    let leonardo = new_clock () in
    let rec fibonacci n =
      tick leonardo ;
      match n with
      | 0 -> 0
      | 1 -> 1
      | n -> fibonacci (n - 1) + fibonacci (n - 2)
    in

    let x = fibonacci 8 in
    let t = time leonardo in
    Format.printf "fibonacci 8 = %d (with %d recursive calls so far)@." x t ;

    (** the clock is cummulative *)
    let x = fibonacci 8 in
    let t = time leonardo in
    Format.printf "fibonacci 8 = %d (with %d recursive calls so far)@." x t
  end

end (* main *)

with.ml

(** * Resource management with guaranteed finalization *)

(**
  Multicore OCaml requires that an effect continuation be used exactly once.
  A second activation of a continuation is a run-time error.
  If a handler wants to dicard a continuation, it must do so explicitly
  with the [discontinue k exn] construction which reactivates [k] by
  triggering the exception [exn] in it. This way the continuation [k]
  gets a chance to clean up its resources.

  Using this discipline, we can create a generic [with] handler that
  guarantees finalization of all resources.
*)

(** We consider handlers that do not change the type of the computation. *)
type with_handler = { wither : 'a . (unit -> 'a) -> 'a }

(** A finalizing effect is one that has a [Finalize] operation. *)
module type FINALIZING =
sig
  effect Finalize : unit
  val handler : with_handler
end

(** A handler for handling a finalizing resource that makes sure that
    the resource will be finalized. *)
let with_resource (module R : FINALIZING) computation =
  R.handler.wither
    (fun () ->
      try
        computation ()
      with
      | exn -> perform R.Finalize ; raise exn)

(** As an example we show how to implement buffered output channels. *)
module type CHANNEL =
sig
  include FINALIZING
  effect Write : string -> unit
  effect Flush : unit
end

(** A channel value is just a channel module *)
type channel = (module CHANNEL)

(** Convenience functions for channels *)
let write (module C : CHANNEL) msg = perform (C.Write msg)
let flush (module C : CHANNEL) = perform C.Flush
let close (module C : CHANNEL) = perform C.Finalize

(** A buffered string printer *)
module BufferedPrinter () : CHANNEL =
struct
  effect Write : string -> unit
  effect Flush : unit
  effect Finalize : unit

  type buffer =
    | Closed
    | Buffered of string list

  let rec flush = function
    | [] -> ()
    | msg :: msgs -> flush msgs ; Format.printf "%s@." msg

  let handler =
    { wither = fun computation ->
               (match
                  computation ()
                with
                | v ->
                   (function
                    | Closed -> v
                    | Buffered msgs -> flush msgs ; v)

                | effect (Write msg) k ->
                   (function
                    | Closed -> discontinue k (Failure "cannot write on a closed channel") Closed
                    | Buffered msgs -> continue k () (Buffered (msg :: msgs)))

                | effect Flush k ->
                   (function
                    | Closed -> discontinue k (Failure "cannot flush a closed channel") Closed
                    | Buffered msgs -> flush msgs ; continue k () (Buffered []))

                | effect Finalize k ->
                   (function
                    | Closed -> discontinue k (Failure "cannot close a closed channel") Closed
                    | Buffered msgs -> flush msgs ; continue k () Closed)
               ) (Buffered [])
    }
end

let new_printer () : channel =
  let module Local = BufferedPrinter () in
  (module Local : CHANNEL)

let main =
  (** Here we have a minor OCaml ugliness, it would be better if we could
      use only the value [p] throughout. The [with_resource] will make sure
      that everything up to the exception is printed out, even though it
      has not been explicitly flushed. *)
  let ((module P) as p) = new_printer () in

  with_resource (module P)
    begin fun () ->

    write p "1 Od nékdej lepé so Ljubljanke slovele," ;
    write p "2 al lepši od Urške bilo ni nobene," ;
    flush p ; (** flush lines 1 and 2 *)
    write p "3 nobene očem bilo bolj zaželene" ;
    write p "4 ob času nje cvetja dekleta ne žene. -" ;
    write p "5 Ko nárbolj iz zvezd je danica svetla," ;
    raise Not_found ; (** lines 3, 4, 5 are not flushed, but will be finalized *)
    write p "6 narlepši iz deklic je Urška bila." (** we never get here, not printed *)
    end

Hi, how about putting these examples into the rosetta stone?