An attempt at Build systems à la carte using algebraic effects

build_effects.ml

(* inspired by https://github.com/Tobi-3/build-systems-a-la-carte-with-effect-handlers/*)

type key = string
type value = int

type _ Effect.t +=
  | Fetch : key -> value Effect.t
  | NeedInput : key -> value Effect.t
  | GetValue : key -> value option Effect.t
  | SetValue : key * value -> unit Effect.t

let fetch (k : key) : value (* { Fetch } *) = Effect.perform (Fetch k)
let need_input (k : key) : value (* { NeedInput } *) = Effect.perform (NeedInput k)
let get_value (k : key) : value option (* { GetValue } *) = Effect.perform (GetValue k)
let set_value (k : key) (v : value) : unit (* { SetValue } *) = Effect.perform (SetValue (k, v))

(** Run a task fetching dependencies using the given rules *)
let run_task (rules : key -> value (* { Fetch, NeedInput } *)) (task : unit -> 'a (* { Fetch } *)) : 'a (* { Fetch, NeedInput } *) =
  let open Effect.Deep in

  try_with task () {
    effc = fun (type a) (eff : a Effect.t) ->
      match eff with
      | Fetch key ->
        Option.some @@ fun (c : (a, _) continuation) ->
          continue c (rules key)
      | _ -> None
  }

(** Run the task, recording the dependencies in a hashtable. *)
let track (task : unit -> value (* { Fetch } *)) : value * (key, value) Hashtbl.t (* { Fetch } *) =
  let open Effect.Deep in

  let deps = Hashtbl.create 1 in

  let value = try_with task () {
    effc = fun (type a) (eff : a Effect.t) ->
      match eff with
      | Fetch key ->
        Option.some @@ fun (c : (a, _) continuation) ->
          let value = fetch key in
          Hashtbl.add deps key value;
          continue c value
      | _ -> None
  } in

  value, deps

(** A build system that rebuilds every dependency it encounters *)
let busy (rules : key -> value (* { Fetch, NeedInput } *)) : key -> value (* { GetValue, SetValue } *) =
  let open Effect.Deep in

  let run_task (key : key) : value =
    let value = rules key in
    set_value key value;
    value
  in

  let rec fetch (key : key) : value =
    try_with run_task key {
      effc = fun (type a) (eff : a Effect.t) ->
        match eff with
        | Fetch key ->
          Option.some @@ fun (c : (a, _) continuation) ->
            continue c (fetch key)
        | NeedInput key ->
          Option.some @@ fun (_ : (a, _) continuation) ->
            get_value key |> Option.get
        | _ -> None
    }
  in

  fetch

(** A build system that reuses previous build results if they are already
    present in the store *)
let memoize (rules : key -> value (* { Fetch } *)) (key : key) : value (* { Fetch, GetValue, SetValue } *) =
  (* inspired by https://github.com/ollef/rock/blob/04d2245726f4d5f2c4f60dbb85cd746b0563261a/src/Rock/Core.hs#L168-L198 *)
  match get_value key with
  | Some value -> value
  | None ->
    let value = rules key in
    set_value key value;
    value

(** A memoized build system that throws an error if any task depends on itself,
    directly or indirectly. *)
let memoize_with_cycle_detection (_rules : key -> value (* { Fetch } *)) (_key : key) : value (* { Fetch, GetValue, SetValue } *) =
  (* inspired by https://github.com/ollef/rock/blob/04d2245726f4d5f2c4f60dbb85cd746b0563261a/src/Rock/Core.hs#L200-L301 *)
  failwith "TODO"

module Examples = struct

  let run_store (f : unit -> 'a (* { GetValue, SetValue } *)) (store : (key, value) Hashtbl.t) : 'a =
    let open Effect.Deep in

    try_with f () {
      effc = fun (type a) (eff : a Effect.t) ->
        match eff with
        | GetValue key ->
          Option.some @@ fun (c : (a, _) continuation) ->
            continue c (Hashtbl.find_opt store key)
        | SetValue (key, value) ->
          Option.some @@ fun (c : (a, _) continuation) ->
            Hashtbl.add store key value;
            continue c ()
        | _ -> None
    }


  (* Makefile *)

  let makefile : key -> unit (* { Fetch, NeedInput } *) = function
    | "util.o" -> ignore (fetch "util.h"); ignore (fetch "util.c")
    | "main.o" -> ignore (fetch "util.h"); ignore (fetch "main.c")
    | "main.exe" -> ignore (fetch "util.o"); ignore (fetch "main.o")
    | target -> ignore (need_input target)


  (* Spreadsheet 1 *)

  (*
    A1: 10    B1: A1 + A2
    A2: 20    B2: B1 * 2
  *)
  let sprsh1 : key -> value (* { Fetch, NeedInput } *) = function
    | "B1" -> fetch "A1" + fetch "A2"
    | "B2" -> fetch "B1" * 2
    | target -> need_input target

  let () =
    let store : (key, value) Hashtbl.t =
      Hashtbl.create 10 in

    store |> run_store begin fun () ->
      set_value "A1" 10;
      set_value "A2" 20;
      ignore (busy sprsh1 "B2")
    end;

    (* store |> Hashtbl.iter (Format.printf "%s: %i\n"); *)

    assert (Hashtbl.find store "B1" = 30);
    assert (Hashtbl.find store "B2" = 60)


  (* Spreadsheet 2 *)

  (*
    A1: 10    B1: IF(C1=1,B2,A2)    C1: 1
    A2: 20    B2: IF(C1=1,A1,B1)
  *)
  let sprsh2 : key -> value (* { Fetch, NeedInput } *) = function
    | "B1" -> if fetch "C1" = 1 then fetch "B2" else fetch "A2"
    | "B2" -> if fetch "C1" = 1 then fetch "A1" else fetch "B1"
    | target -> need_input target

  let () =
    let store : (key, value) Hashtbl.t =
      Hashtbl.create 10 in

    store |> run_store begin fun () ->
      set_value "A1" 10;
      set_value "A2" 20;
      set_value "C1" 1;
      ignore (busy sprsh2 "B2");
    end;

    (* store |> Hashtbl.iter (Format.printf "%s: %i\n"); *)

    (* assert (Hashtbl.find store "B1" = 10); *)
    assert (Hashtbl.find store "B2" = 10)

  let () =
    let open Effect.Deep in

    let value, deps = try_with (fun () -> track (fun () -> sprsh2 "B1")) () {
      effc = fun (type a) (eff : a Effect.t) ->
        match eff with
        | Fetch "C1" -> Option.some @@ fun (c : (a, _) continuation) -> continue c 1
        | Fetch "B2" -> Option.some @@ fun (c : (a, _) continuation) -> continue c 10
        | Fetch key -> Option.some @@ fun (c : (a, _) continuation) -> continue c (need_input key)
        | _ -> None
    } in

    assert (value = 10);
    assert (deps = Hashtbl.of_seq (List.to_seq ["B2", 10; "C1", 1]))

  let () =
    let open Effect.Deep in

    let value, deps = try_with (fun () -> track (fun () -> sprsh2 "B1")) () {
      effc = fun (type a) (eff : a Effect.t) ->
        match eff with
        | Fetch "C1" -> Option.some @@ fun (c : (a, _) continuation) -> continue c 2
        | Fetch "A2" -> Option.some @@ fun (c : (a, _) continuation) -> continue c 20
        | Fetch key -> Option.some @@ fun (c : (a, _) continuation) -> continue c (need_input key)
        | _ -> None
    } in

    assert (value = 20);
    assert (deps = Hashtbl.of_seq (List.to_seq ["A2", 20; "C1", 2]))

end