feat: custom printers for unhandled effects (#19)

Co-authored-by: favonia <[email protected]>

src/Reader.ml

@@ -10,6 +10,7 @@ sig
   val read : unit -> env
   val scope : (env -> env) -> (unit -> 'a) -> 'a
   val run : env:env -> (unit -> 'a) -> 'a
+  val register_printer : ([`Read] -> string option) -> unit
 end
 
 module Make (P : Param) =
@@ -30,4 +31,8 @@ struct
             | _ -> None }
 
   let scope f c = run ~env:(f @@ read ()) c
+
+  let register_printer f = Printexc.register_printer @@ function
+    | Effect.Unhandled Read -> f `Read
+    | _ -> None
 end

src/Reader.mli

@@ -41,6 +41,9 @@ sig
 
   val run : env:env -> (unit -> 'a) -> 'a
   (** [run t] runs the thunk [t] which may perform reading effects. *)
+
+  (**/**)
+  val register_printer : ([`Read] -> string option) -> unit
 end
 
 module Make (P : Param) : S with type env = P.env

src/Sequencer.ml

@@ -9,6 +9,7 @@ sig
 
   val yield : elt -> unit
   val run : (unit -> unit) -> elt Seq.t
+  val register_printer : ([`Yield of elt] -> string option) -> unit
 end
 
 module Make (P : Param) =
@@ -27,4 +28,8 @@ struct
             | Yield x -> Option.some @@ fun (k : (a, _) continuation) ->
               Seq.Cons (x, continue k)
             | _ -> None }
+
+  let register_printer f = Printexc.register_printer @@ function
+    | Effect.Unhandled (Yield elt) -> f (`Yield elt)
+    | _ -> None
 end

src/Sequencer.mli

@@ -35,6 +35,9 @@ sig
 
   val run : (unit -> unit) -> elt Seq.t
   (** [run t] runs the thunk [t] which may perform sequencing effects. *)
+
+  (**/**)
+  val register_printer : ([`Yield of elt] -> string option) -> unit
 end
 
 module Make (P : Param) : S with type elt = P.elt

src/State.ml

@@ -11,6 +11,7 @@ sig
   val set : state -> unit
   val modify : (state -> state) -> unit
   val run : init:state -> (unit -> 'a) -> 'a
+  val register_printer : ([`Get | `Set of state] -> string option) -> unit
 end
 
 module Make (P : Param) =
@@ -37,4 +38,9 @@ struct
             | _ -> None }
 
   let modify f = set @@ f @@ get ()
+
+  let register_printer f = Printexc.register_printer @@ function
+    | Effect.Unhandled Get -> f `Get
+    | Effect.Unhandled (Set state) -> f (`Set state)
+    | _ -> None
 end

src/State.mli

@@ -40,6 +40,9 @@ sig
 
   val run : init:state -> (unit -> 'a) -> 'a
   (** [run t] runs the thunk [t] which may perform state effects. *)
+
+  (**/**)
+  val register_printer : ([`Get | `Set of state] -> string option) -> unit
 end
 
 module Make (P : Param) : S with type state = P.state

src/UniqueID.ml

@@ -21,6 +21,7 @@ sig
   val retrieve : id -> elt
   val export : unit -> elt Seq.t
   val run : ?init:elt Seq.t -> (unit -> 'a) -> 'a
+  val register_printer : ([`Register of elt | `Retrieve of id | `Export] -> string option) -> unit
 end
 
 module Make (P : Param) =
@@ -66,4 +67,10 @@ struct
             | Export -> Option.some @@ fun (k : (a, _) continuation) ->
               continue k @@ Seq.map snd @@ M.to_seq @@ Eff.get ()
             | _ -> None }
+
+  let register_printer f = Printexc.register_printer @@ function
+    | Effect.Unhandled (Insert elt) -> f (`Register elt)
+    | Effect.Unhandled (Select id) -> f (`Retrieve id)
+    | Effect.Unhandled Export -> f `Export
+    | _ -> None
 end

src/UniqueID.mli

@@ -54,6 +54,9 @@ sig
 
       @param init The initial storage, which should be the output of some previous {!val:export}.
   *)
+
+  (**/**)
+  val register_printer : ([`Register of elt | `Retrieve of id | `Export] -> string option) -> unit
 end
 
 module Make (P : Param) : S with type elt = P.elt

test/TestReader.ml

@@ -18,6 +18,7 @@ struct
   let read () = U.perform ReaderMonad.read
   let scope f m = U.perform @@ ReaderMonad.scope f @@ U.run m
   let run ~env f = U.run f env
+  let register_printer _ = ()
 end
 
 type cmd = ReadAndPrint | Scope of (int -> int) * prog

test/TestSequencer.ml

@@ -26,6 +26,7 @@ struct
   type elt = int
   let yield x = U.perform (SequencerMonad.yield x)
   let run f = output_to_seq @@ snd @@ U.run f
+  let register_printer _ = ()
 end
 
 type cmd = Yield of int

test/TestState.ml

@@ -20,6 +20,7 @@ struct
   let set s = U.perform @@ StateMonad.set s
   let modify f = U.perform @@ StateMonad.modify f
   let run ~init f = fst @@ U.run f init
+  let register_printer _ = ()
 end
 
 type cmd = Set of int | GetAndPrint | Mod of (int -> int)