open Rnt

module Make (S : Abstract.Storage.STORAGE) (C : Helpers.Storage.CONFIGURATOR) = struct
  open Alcotest
  module H = Helpers.Storage.Make (S) (C)
  module SR = Rnt.Kernel.SubstantialRelation.Make (S)

  let alaric = Helpers.employee "Alaric" 42

  let contains relation tuple =
    let open Utilities.Result in
    let* relation = Protocols.Relation.require relation in
    Protocols.Relation.contains relation tuple

  let enumerate relation =
    let open Utilities.Result in
    let* enumerated =
      Protocols.Enumerable.scan relation (fun scan -> Protocols.Cursor.drain scan ())
    in
    Ok (BatFingerTree.to_list enumerated)

  let contain_and_enumerate conn =
    let absent, present, enumerated =
      begin
        let open Utilities.Result in
        let* schematics =
          H.SI.with_transaction conn (fun tx -> H.store_schema tx ["name"; "age"])
        in
        let* empty = SR.instantiate conn ~schematics in
        let* absent = contains empty alaric in
        let* holding = H.relation conn ["name"; "age"] [alaric] in
        let* present = contains holding alaric in
        let* enumerated = enumerate holding in
        Ok (absent, present, enumerated)
      end
      |> Helpers.condition_as_failure
    in
    check bool "absent from an empty relation" false absent;
    check bool "present in a relation holding it" true present;
    check int "one tuple enumerated" 1 (List.length enumerated);
    check bool "the tuple that was asserted" true
      (List.for_all
         (fun tuple ->
           Concepts.Hash.hash_equals (Concepts.Tuple.hash tuple) (Concepts.Tuple.hash alaric) )
         enumerated )

  let refuse_a_tuple_off_its_heading conn =
    let refused message name attributes =
      Helpers.refuses message name (H.relation conn ["name"; "age"] [{alaric with attributes}])
    in
    refused "a tuple lacking an attribute is refused" "missing-attribute"
      (BatMap.String.remove "name" alaric.attributes);
    refused "a tuple with an attribute too many is refused" "unexpected-attribute"
      (BatMap.String.add "salary" (Concepts.Value.Integer 1) alaric.attributes)

  let look_up_by_one_attribute conn =
    let names relation attribute value =
      let open Utilities.Result in
      let* indexed = Protocols.Indexed.require relation in
      let* cursor = Protocols.Indexed.lookup indexed attribute value in
      let* found = Protocols.Cursor.consuming cursor (fun scan -> Protocols.Cursor.drain scan ()) in
      Ok
        ( BatFingerTree.to_list found
        |> List.map (fun tuple -> BatMap.String.find "name" tuple.Concepts.Tuple.attributes)
        |> List.sort compare )
    in
    let indexes, aged, named, unaged, prefixed, unindexed =
      begin
        let open Utilities.Result in
        let* relation =
          H.relation conn ["name"; "age"]
            Helpers.[employee "Alaric" 42; employee "Brunhild" 30; employee "Gunther" 42]
        in
        let* indexed = Protocols.Indexed.require relation in
        let* aged = names relation "age" (Concepts.Value.Integer 42) in
        let* named = names relation "name" (Concepts.Value.String "Brunhild") in
        let* unaged = names relation "age" (Concepts.Value.Integer 4) in
        let* prefixed = names relation "name" (Concepts.Value.String "Al") in
        let unindexed = names relation "salary" (Concepts.Value.Integer 1) in
        Ok (Protocols.Indexed.indexes indexed, aged, named, unaged, prefixed, unindexed)
      end
      |> Helpers.condition_as_failure
    in
    let s v = Concepts.Value.String v in
    check (list string) "every attribute is indexed" ["age"; "name"] indexes;
    check (list Helpers.value) "an integer finds every tuple holding it"
      [s "Alaric"; s "Gunther"]
      aged;
    check (list Helpers.value) "a string finds the tuple holding it" [s "Brunhild"] named;
    check (list Helpers.value) "an integer finds nothing under a longer one" [] unaged;
    check (list Helpers.value) "a string finds nothing under a longer one" [] prefixed;
    Helpers.refuses "an attribute without an index is refused" "unindexed-attribute" unindexed

  let suite =
    ( "kernel/substantial-relation",
      [ test_case "contain-and-enumerate" `Quick
          (H.with_connection contain_and_enumerate "substantial-relation-test");
        test_case "refuse-a-tuple-off-its-heading" `Quick
          (H.with_connection refuse_a_tuple_off_its_heading "substantial-relation-test");
        test_case "look-up-by-one-attribute" `Quick
          (H.with_connection look_up_by_one_attribute "substantial-relation-test") ] )
end

module LMDB = Make (Rnt.Backend.Storage.LMDB) (Helpers.Storage.LMDB_Configurator)

let suites () = [LMDB.suite]