(* Boots a BEAM node on a directory of images and prints the programs
   named on the command line, read from \karuta\program.

   dune exec ./tools/run/main.exe -- <image directory> <program>... *)

open Rnt
module Beam = Subsystem.Karuta.Beam

let ( let* ) = Result.bind

let mount_fol root =
  let evaluators = Kernel.Namespace.make () and system = Kernel.Namespace.make () in
  let* _ =
    Kernel.Path.update evaluators Kernel.Path.this "fol" None (Some (Evaluators.FOL.make ()))
  in
  let* _ = Kernel.Path.update system Kernel.Path.this "evaluator" None (Some evaluators) in
  let* _ = Kernel.Path.update root Kernel.Path.this "system" None (Some system) in
  Ok ()

(* Where calendar.skr's persisted predicates live, made of plain
   namespaces since this kernel has no branches. *)
let rec directories root prefix = function
  | [] -> Ok ()
  | segment :: rest ->
      let* _ =
        Kernel.Path.update root (Kernel.Path.of_list prefix) segment None
          (Some (Kernel.Namespace.make ()))
      in
      directories root (prefix @ [segment]) rest

let show root name =
  let* handle = Kernel.Path.lookup root Kernel.Path.("karuta" @/ "program" @/ name @/ this) in
  let* relation =
    Protocols.Handle.releasing handle (fun () ->
        let* executable = Protocols.Executable.require handle in
        Protocols.Executable.invoke executable [] ~within:root )
  in
  Protocols.Handle.releasing relation (fun () ->
      let* _, tuples = Protocols.Relation.read relation in
      Printf.printf "\\karuta\\program\\%s:\n" name;
      List.iter
        (fun {Concepts.Tuple.type_; attributes} ->
          Printf.printf "  %s {%s}\n" type_
            ( BatMap.String.bindings attributes
            |> List.map (fun (k, v) -> k ^ " = " ^ Concepts.Value.to_string v)
            |> String.concat ", " ) )
        tuples;
      Ok () )

let run directory names root =
  let* () = mount_fol root in
  let* () =
    directories root ["system"]
      ["branch"; "master"; "multigroup"; "calendar"; "schema"; "public"; "relation"]
  in
  let* () = Beam.register root [directory] in
  List.fold_left (fun acc name -> let* () = acc in show root name) (Ok ()) names

let () =
  Sys.set_signal Sys.sigpipe Sys.Signal_ignore;
  let root = Kernel.Namespace.make () in
  let names = Array.to_list (Array.sub Sys.argv 2 (Array.length Sys.argv - 2)) in
  match Protocols.Handle.releasing root (fun () -> run Sys.argv.(1) names root) with
  | Ok () -> ()
  | Error c -> prerr_endline (Concepts.Condition.to_string_hum c); exit 1