effect.ml

open Effect
open Effect.Deep
open Effect.Shallow

type _ Effect.t += Get: int t
                 | Put: int -> unit t
                 | Exc: string -> unit t

let run_reader (i : int) e =
  try_with e ()
  { effc = fun (type a) (eff: a t) ->
      match eff with
      | Get -> Some (fun (k: (a, _) Deep.continuation) -> continue k i)
      | _ -> None }

let run_state (s : int) (e : unit -> _) =
  let rec loop : type a. int -> (a, _) Shallow.continuation -> a -> (int * _) = fun s k v ->
    continue_with k v
    { retc = (fun (v) -> (s, v));
      exnc = raise;
      effc = fun (type a) (eff: a t) ->
        match eff with
        | Get -> Some (fun (k: (a, _) Shallow.continuation) -> loop s k s)
        | Put s' -> Some (fun (k: (a, _) Shallow.continuation) -> loop s' k ())
        | _ -> None }
  in
  loop s (fiber e) ()

let run_error e =
  match_with e ()
  { retc = (fun (v) -> Either.Right v);
    exnc = raise;
    effc = fun (type a) (eff: a t) ->
      match eff with
      | Exc s -> Some (fun _ -> Either.Left s)
      | _ -> None }

let eval_state (s : int) e = let (_, v) = run_state s e in v

let exec_state (s : int) e = let (s, _) = run_state s e in s

let modify f = perform (Put (f (perform Get)))

let transaction e =
  let (s, v) = run_state (perform Get) e in
    perform (Put s);
    v

let p1 () = (perform Get) + 1

let p2 () =
  modify (fun (v) -> v * 2);
  string_of_int (p1 ())

let p3 () =
  modify (fun (v) -> v + 1);
  perform (Exc "interrupted!")

let () =
  Printf.printf "run_reader: %d\n" (run_reader 0 p1);
  Printf.printf "eval_state: %s\n" (eval_state 1 p2);
  Printf.printf "exec_state: %d\n" (exec_state 1 p2);
  Printf.printf "without transaction: %d\n" (exec_state 0 (fun () -> (run_error p3)));
  Printf.printf "with transaction: %d\n" (exec_state 0 (fun () -> (run_error (fun () -> transaction p3))));