path: root/lib/kernel/EphemeralRelation.ml

module type DERIVATION = sig
  type plan

  val identity : plan -> Concepts.Hash.hash

  val describe :
    plan -> (Protocols.Schematics.relation_description, Concepts.Condition.condition) result

  val modes : plan -> (Concepts.Mode.t, Concepts.Condition.condition) result

  val generate :
    plan ->
    Protocols.Generative.binding ->
    (Protocols.Handle.t, Concepts.Condition.condition) result
end

module Make (D : DERIVATION) = struct
  let pinned_tag = "rnt/pinned/1"

  let identity ?pinned plan =
    let derivation = D.identity plan in
    match pinned with
    | None -> derivation
    | Some branch ->
        pinned_tag ^ Concepts.Hash.to_raw_string derivation ^ Concepts.Hash.to_raw_string branch
        |> Bytes.of_string
        |> Concepts.Hash.hash_of_bytes

  let exhaustible declaration =
    match Concepts.Mode.generation declaration BatSet.String.empty with
    | Some cardinality -> Concepts.Cardinality.exhaustible cardinality
    | None -> false

  class ephemeral plan address declaration total edges =
    object (self)
      inherit Lifecycle.counted
      val plan : D.plan = plan
      method destroy = List.iter Protocols.Handle.release edges
      method predicate = Ok None
      method local_constraints = Ok None
      method modes = Ok declaration
      method generate binding = D.generate plan binding
      method enumerate = D.generate plan Protocols.Generative.nothing

      method describe () =
        D.describe plan |> Result.map (fun description -> Protocols.Schematics.Relation description)

      (* Membership of a derived relation is decided by the derivation
         and not by a lookup, so it is asked of the generator under the
         binding the tuple itself fixes. *)
      method contains (tuple : Concepts.Tuple.t) =
        let open Utilities.Result in
        let* cursor = D.generate plan tuple.Concepts.Tuple.attributes in
        Fun.protect
          ~finally:(fun () -> Protocols.Handle.release cursor)
          (fun () ->
            let* scan = Protocols.Cursor.require cursor in
            let* first = Protocols.Cursor.next scan in
            Ok (Option.is_some first) )

      method protocols : Protocols.Handle.protocol list =
        let carried =
          [ Protocols.Relation.make self;
            Protocols.Schematics.make self;
            Protocols.Generative.make self ]
        in
        if total then Protocols.Enumerable.make self :: carried else carried

      method hash : Concepts.Hash.hash = address
    end

  let derive ?pinned ?(edges = []) plan =
    let open Utilities.Result in
    let* declaration = D.modes plan in
    Ok
      ( new ephemeral plan (identity ?pinned plan) declaration (exhaustible declaration) edges
      |> Protocols.Handle.make )
end