bound queries from sakurasakura-karuta-contract

1 files changed, 65 insertions, 0 deletions

diff --git a/tools/run/main.ml b/tools/run/main.ml
new file mode 100644
index 0000000..d4bbf56
--- /dev/null
+++ b/tools/run/main.ml
@@ -0,0 +1,65 @@
+(* 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