path: root/lib/evaluators/FOL.ml

module Error = struct
  open Concepts.Condition

  let unknown_relation name =
    condition "unknown-relation" "A plan named a relation that does not exist under this snapshot"
      ("name" |=| Concepts.Value.String name)

  let cancelled () =
    condition "evaluation-cancelled" "An evaluation was stopped before it produced its result" empty

  let not_a_plan () =
    condition "not-a-fol-program" "The evaluator was given a program of another kind" empty

  let unknown_attribute name =
    condition "unknown-attribute" "A plan named an attribute its relation does not have"
      ("attribute" |=| Concepts.Value.String name)

  let malformed_program () =
    condition "malformed-fol-program"
      "A stored FOL program did not conform to what was expected. Is your database corrupted?" empty

  let cyclic_program code =
    condition "cyclic-program" "A stored program reads itself"
      ("program" |=| Concepts.Value.String (Concepts.Hash.to_hum_string code))
end

let name = "fol"

type binding = Concepts.Value.value BatMap.String.t

type 'r term =
  | Base of 'r
  | Project of 'r term * string BatFingerTree.t
  | Where of 'r term * binding

type plan = Protocols.Handle.t term
type Kernel.Program.kind += Fol of Kernel.Path.t term

module Bencode = Concepts.Encoding.Bencode

let rec bencode_of_term =
  let strings values = Bencode.List (List.map (fun value -> Bencode.String value) values) in
  function
  | Base path -> Bencode.Tagged ('b', strings (Kernel.Path.to_list path))
  | Project (term, attributes) ->
      Bencode.Tagged
        ( 'p',
          Bencode.Dict
            ["term", bencode_of_term term; "attributes", strings (BatFingerTree.to_list attributes)]
        )
  | Where (term, binding) ->
      Bencode.Tagged
        ( 'w',
          Bencode.Dict
            [ "term", bencode_of_term term;
              ( "binding",
                Bencode.Dict
                  ( BatMap.String.bindings binding
                  |> List.map (fun (name, value) -> name, Concepts.Tuple.bencode_of_value value) ) )
            ] )

let rec term_of_bencode =
  let open Utilities.Result in
  let strings values =
    let* values = Bencode.as_list values in
    List.map Bencode.as_string values |> Utilities.List.sequence
  in
  function
  | Bencode.Tagged ('b', segments) ->
      strings segments |> Result.map (fun segments -> Base (Kernel.Path.of_list segments))
  | Bencode.Tagged ('p', data) ->
      let* term = Bencode.field "term" data |>> term_of_bencode in
      let* attributes = Bencode.field "attributes" data |>> strings in
      Ok (Project (term, BatFingerTree.of_list attributes))
  | Bencode.Tagged ('w', data) ->
      let* term = Bencode.field "term" data |>> term_of_bencode in
      let* binding = Bencode.field "binding" data |>> Bencode.as_dict in
      let* binding =
        List.map
          (fun (name, value) ->
            Concepts.Tuple.value_of_bencode value |> Result.map (fun value -> name, value) )
          binding
        |> Utilities.List.sequence
      in
      Ok (Where (term, BatMap.String.of_list binding))
  | _ -> Error (Error.malformed_program ())

let encode term = bencode_of_term term |> Bencode.to_bytes |> Bytes.to_string
let decode source = Utilities.Result.(Bencode.of_bytes (Bytes.of_string source) |>> term_of_bencode)
let bound binding = BatSet.String.of_enum (BatMap.String.keys binding)
let names attributes = BatSet.String.of_list (BatFingerTree.to_list attributes)

let rec push = function
  | Base relation -> Base relation
  | Project (term, attributes) -> Project (push term, attributes)
  | Where (term, binding) -> (
    match push term with
    | Project (term, attributes) when BatSet.String.subset (bound binding) (names attributes) ->
        Project (push (Where (term, binding)), attributes)
    | term -> Where (term, binding) )

(* TODO: To strenghten our checks for self references, we need to
   construct a graph and see raise a condition if there are self
   references. We partially do that here with the program calling
   self, but if the flow is alternated, say between program A and B,
   where B calls A and A calls B, we also must check. *)
let instantiate within =
  let open Utilities.Result in
  let rec bind expanding = function
    | Base reference -> (
        let* relation = Kernel.Path.lookup within reference in
        match Kernel.Program.image relation with
        | None -> Ok (Base relation)
        | Some {kind= Fol term; source; _} ->
            Protocols.Handle.release relation;
            let identity = Concepts.Hash.hash_of_bytes (Bytes.of_string source) in
            if List.exists (Concepts.Hash.hash_equals identity) expanding then
              Error (Error.cyclic_program identity)
            else bind (identity :: expanding) term
        | Some _ ->
            Protocols.Handle.releasing relation (fun () ->
                let* program = Protocols.Executable.require relation in
                let* result = Protocols.Executable.invoke program [] ~within in
                Ok (Base result) ) )
    | Project (term, attributes) ->
        let* plan = bind expanding term in
        Ok (Project (plan, attributes))
    | Where (term, binding) ->
        let* plan = bind expanding term in
        Ok (Where (plan, binding))
  in
  fun term -> bind [] term |> Result.map push

let restrict attributes description =
  let open Utilities.Result in
  Utilities.FingerTree.foldm_left
    (fun restricted name ->
      let* attribute =
        BatMap.String.find_opt name description
        |> Option.to_result ~none:(Error.unknown_attribute name)
      in
      Ok (BatMap.String.add name attribute restricted) )
    BatMap.String.empty attributes

let rec describe =
  let open Utilities.Result in
  function
  | Base relation -> Protocols.Relation.heading relation
  | Project (plan, attributes) -> describe plan |>> restrict attributes
  | Where (plan, binding) ->
      let* heading = describe plan in
      let* _ = restrict (BatFingerTree.of_enum (BatMap.String.keys binding)) heading in
      Ok heading

let index_for relation binding =
  let open Utilities.Option in
  let* indexed = Protocols.Indexed.from relation in
  let* attribute =
    List.find_opt (fun a -> BatMap.String.mem a binding) (Protocols.Indexed.indexes indexed)
  in
  Some (indexed, attribute)

let rec modes =
  let open Utilities.Result in
  function
  | Base relation ->
      let* relation = Protocols.Relation.require relation in
      Protocols.Relation.modes relation
  | Project (plan, attributes) ->
      modes plan |> Result.map (Concepts.Mode.project (names attributes))
  | Where (plan, binding) -> (
      let* modes = modes plan in
      match plan with
      | Base relation -> (
        match index_for relation binding with
        | Some (_, attribute) -> Ok (Concepts.Mode.given attribute modes)
        | None -> Ok modes )
      | _ -> Ok modes )

let project description relation =
  let open Utilities.Result in
  let* cursor = Protocols.Enumerable.cursor relation in
  let produce ~yield =
    let* scan = Protocols.Cursor.require cursor in
    let rec distinct seen =
      let* next = Protocols.Cursor.next scan in
      match next with
      | None -> Ok ()
      | Some tuple ->
          let tuple =
            { tuple with
              attributes=
                BatMap.String.filter
                  (fun name _ -> BatMap.String.mem name description)
                  tuple.Concepts.Tuple.attributes }
          in
          let key = Concepts.Tuple.hash tuple |> Concepts.Hash.to_raw_string in
          if BatSet.String.mem key seen then distinct seen
          else begin
            yield tuple;
            distinct (BatSet.String.add key seen)
          end
    in
    distinct BatSet.String.empty
  in
  Ok (Kernel.Generator.cursor_of ~finally:(fun () -> Protocols.Handle.release cursor) produce)

let agrees binding {Concepts.Tuple.attributes; _} =
  BatMap.String.for_all
    (fun name value ->
      Option.fold ~none:false ~some:(Concepts.Value.equal value)
        (BatMap.String.find_opt name attributes) )
    binding

let restricted binding relation =
  let open Utilities.Result in
  let* cursor =
    match index_for relation binding with
    | Some (indexed, attribute) ->
        Protocols.Indexed.lookup indexed attribute (BatMap.String.find attribute binding)
    | None -> Protocols.Enumerable.cursor relation
  in
  Ok (Kernel.Generator.filter (agrees binding) cursor)

let contains relation tuple =
  Result.bind (Protocols.Relation.require relation) (fun r -> Protocols.Relation.contains r tuple)

let derive ?decide relation description modes enumerate =
  Kernel.EphemeralRelation.instantiate ~inputs:[relation] ?decide
    ~modes:(fun () -> Ok modes)
    description
    (Kernel.EphemeralRelation.temporary description)
    (fun () -> enumerate relation)

let rec execute plan =
  let open Utilities.Result in
  let* description = describe plan in
  let* modes = modes plan in
  match plan with
  | Base relation ->
      let relation = Protocols.Handle.move relation in
      Ok (derive ~decide:(contains relation) relation description modes Protocols.Enumerable.cursor)
  | Project (plan, _) ->
      let* relation = execute plan in
      Ok (derive relation description modes (project description))
  | Where (plan, binding) ->
      let* relation =
        match plan with
        | Base relation -> Ok (Protocols.Handle.move relation)
        | plan -> execute plan
      in
      Ok
        (derive
           ~decide:(fun tuple -> if agrees binding tuple then contains relation tuple else Ok false)
           relation description modes (restricted binding) )

class evaluator =
  object (self)
    inherit Kernel.Lifecycle.null
    inherit Kernel.Identity.of_id
    method to_string = "fol-evaluator"
    method parse source = decode source |> Result.map (fun term -> Fol term)

    method eval kind _inputs ~within =
      let open Utilities.Result in
      match kind with
      | Fol term ->
          let* plan = instantiate within term in
          execute plan
      | _ -> Error (Error.not_a_plan ())

    method protocols : Protocols.Handle.protocol list = [Protocols.Evaluator.make self]
  end

let make () = new evaluator |> Protocols.Handle.make
let program ?root term = Kernel.Program.make ?root ~evaluator:name ~source:(encode term) (Fol term)