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 =
    { Concepts.Tuple.type_= "employee";
      attributes=
        BatMap.String.empty
        |> BatMap.String.add "name" (Concepts.Value.String "Alaric")
        |> BatMap.String.add "age" (Concepts.Value.Integer 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 name attributes =
      match H.relation conn ["name"; "age"] [{alaric with attributes}] with
      | Error condition -> BatString.starts_with (Concepts.Condition.to_string_hum condition) name
      | Ok _ -> false
    in
    check bool "a tuple lacking an attribute is refused" true
      (refused "missing-attribute" (BatMap.String.remove "name" alaric.attributes));
    check bool "a tuple with an attribute too many is refused" true
      (refused "unexpected-attribute"
         (BatMap.String.add "salary" (Concepts.Value.Integer 1) alaric.attributes) )

  let employee name age =
    { Concepts.Tuple.type_= "employee";
      attributes=
        BatMap.String.empty
        |> BatMap.String.add "name" (Concepts.Value.String name)
        |> BatMap.String.add "age" (Concepts.Value.Integer age) }

  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"]
            [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 is not a prefix of a longer one" [] unaged;
    check (list Helpers.value) "a string is not a prefix of a longer one" [] prefixed;
    check bool "an attribute without an index is refused" true
      ( match unindexed with
      | Error condition ->
          BatString.starts_with (Concepts.Condition.to_string_hum condition) "unindexed-attribute"
      | Ok _ -> false )

  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]