From 71856adc5ff5d64c7be1b37854fc8a205d55e482 Mon Sep 17 00:00:00 2001 From: Marcos Magueta Date: Sat, 31 Oct 2026 02:28:17 -0300 Subject: update tests and add beam tests --- test/integration/Karuta.ml | 182 +++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 182 insertions(+) create mode 100644 test/integration/Karuta.ml (limited to 'test/integration/Karuta.ml') diff --git a/test/integration/Karuta.ml b/test/integration/Karuta.ml new file mode 100644 index 0000000..2b02e69 --- /dev/null +++ b/test/integration/Karuta.ml @@ -0,0 +1,182 @@ +open Alcotest +open Rnt +module Beam = Subsystem.Karuta.Beam + +let fixtures = "integration/beam" + +(* rnt and shelf boot with the node; library is only ever loaded from + the images that carry it. *) +let booted = ["rnt"; "shelf"] +let carried = ["library"] + +type node = {root: Protocols.Handle.t; image: string -> string} + +let term image module_ function_ heading = + let buffer = Buffer.create 64 in + let binary s = + Buffer.add_uint8 buffer 109; + Buffer.add_int32_be buffer (Int32.of_int (String.length s)); + Buffer.add_string buffer s + in + Buffer.add_uint8 buffer 131; + Buffer.add_uint8 buffer 104; + Buffer.add_uint8 buffer 4; + binary module_; + binary function_; + binary (image module_); + Buffer.add_uint8 buffer 116; + Buffer.add_int32_be buffer (Int32.of_int (List.length heading)); + List.iter (fun name -> binary name; binary "string") heading; + Buffer.contents buffer + +(* \system\evaluator\fol, so the node can define FOL programs. *) +let mount_fol root = + let open Utilities.Result in + let evaluators = Kernel.Namespace.make () in + let 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 () + +let with_node test () = + if Sys.command "command -v erl > /dev/null 2>&1 && command -v erlc > /dev/null 2>&1" <> 0 then + skip (); + Sys.set_signal Sys.sigpipe Sys.Signal_ignore; + Helpers.with_temporary_directory "beam" (fun directory -> + let boot = Filename.concat directory "boot" and images = Filename.concat directory "images" in + let compile into modules = + Unix.mkdir into 0o755; + let sources = List.map (fun m -> Filename.concat fixtures (m ^ ".erl")) modules in + if Sys.command (Filename.quote_command "erlc" (["-o"; into] @ sources)) <> 0 then + fail "the fixtures did not compile" + in + compile boot booted; + compile images carried; + let image module_ = + let at = if List.mem module_ booted then boot else images in + In_channel.with_open_bin (Filename.concat at (module_ ^ ".beam")) In_channel.input_all + in + let root = Kernel.Namespace.make () in + Fun.protect + ~finally:(fun () -> Protocols.Handle.release root) + (fun () -> + Helpers.condition_as_failure (mount_fol root); + Helpers.condition_as_failure (Beam.register root [boot]); + test {root; image} ) ) + +let run {root; image} module_ function_ heading = + let open Utilities.Result in + let* program = + Kernel.Program.load root ~evaluator:"karuta:beam" ~source:(term image module_ function_ heading) + in + let* executable = Protocols.Executable.require program in + Protocols.Executable.invoke executable [] ~within:root + +let titles batch = + BatFingerTree.to_list batch.Protocols.Cursor.tuples + |> List.map (fun {Concepts.Tuple.attributes; _} -> + Concepts.Value.to_string (BatMap.String.find "title" attributes) ) + +let fails_with name = function + | Ok _ -> fail ("expected " ^ name) + | Error c -> + check bool name true (BatString.starts_with (Concepts.Condition.to_string_hum c) name) + +let reads_in_batches node = + let batches = + begin + let open Utilities.Result in + let* relation = run node "library" "books" ["title"; "author"] in + Protocols.Handle.releasing relation (fun () -> + let* heading = Protocols.Relation.heading relation in + check (list string) "the heading the term declares" ["author"; "title"] + (BatMap.String.bindings heading |> List.map fst); + Protocols.Enumerable.scan relation (fun scan -> + let rec pull read = + let* batch = Protocols.Cursor.fetch scan 4 in + let read = (titles batch, batch.exhausted) :: read in + if batch.exhausted then Ok (List.rev read) else pull read + in + pull [] ) ) + end + |> Helpers.condition_as_failure + in + check + (list (pair (list string) bool)) + "four, then the rest" + [ ( [ "Structure and Interpretation of Computer Programs"; + "The Art of Computer Programming"; + "An Introduction to Database Systems"; + "Less Than Words Can Say" ], + false ); + ["The Graves of Academe"; "The Leaning Tower of Babel"; "The Gift of Fire"], true ] + batches + +let reads_back_through_the_kernel ({root; image} as node) = + begin + let open Utilities.Result in + let* books = + Kernel.Program.load root ~evaluator:"karuta:beam" + ~source:(term image "library" "books" ["title"; "author"]) + in + let* bound = + Kernel.Path.update root Kernel.Path.("karuta" @/ "program" @/ this) "books" None (Some books) + in + check bool "the books are defined beside what the node defined" true bound; + let* relation = run node "shelf" "titles" ["title"] in + Protocols.Handle.releasing relation (fun () -> Helpers.titles relation) + end + |> Helpers.condition_as_failure + |> check (list Helpers.value) "the node read its FOL program over the books" + (List.map + (fun title -> Concepts.Value.String title) + [ "An Introduction to Database Systems"; + "Less Than Words Can Say"; + "Structure and Interpretation of Computer Programs"; + "The Art of Computer Programming"; + "The Gift of Fire"; + "The Graves of Academe"; + "The Leaning Tower of Babel" ] ) + +let reads_a_program_of_no_path ({root; image} as node) = + begin + let open Utilities.Result in + let* books = + Kernel.Program.load root ~evaluator:"karuta:beam" + ~source:(term image "library" "books" ["title"; "author"]) + in + let* _ = + Kernel.Path.update root Kernel.Path.("karuta" @/ "program" @/ this) "books" None (Some books) + in + let* relation = run node "shelf" "authors" ["author"] in + Protocols.Handle.releasing relation (fun () -> Protocols.Relation.read relation) + end + |> Helpers.condition_as_failure + |> snd + |> List.map (fun {Concepts.Tuple.attributes; _} -> BatMap.String.find "author" attributes) + |> List.sort compare + |> check (list Helpers.value) "each author once" + (List.map + (fun author -> Concepts.Value.String author) + ["C. J. Date"; "Donald Knuth"; "Harold Abelson"; "Richard Mitchell"] ) + +let a_missing_function_fails node = + fails_with "beam-failed" + (Result.bind (run node "library" "nope" ["title"]) (fun relation -> + Protocols.Handle.releasing relation (fun () -> Protocols.Relation.read relation) ) ) + +let a_malformed_term_is_refused {root; _} = + fails_with "malformed-beam-program" + (Kernel.Program.load root ~evaluator:"karuta:beam" ~source:"not a term") + +let suites () = + [ ( "integration/karuta", + [ test_case "reads-in-batches" `Quick (with_node reads_in_batches); + test_case "reads-back-through-the-kernel" `Quick (with_node reads_back_through_the_kernel); + test_case "reads-a-program-of-no-path" `Quick (with_node reads_a_program_of_no_path); + test_case "a-missing-function-fails" `Quick (with_node a_missing_function_fails); + test_case "a-malformed-term-is-refused" `Quick (with_node a_malformed_term_is_refused) ] ) + ] -- cgit v1.2.3