Foreign call PRL (#67)

5 files changed, 216 insertions, 0 deletions

diff --git a/lib/prl/ast.ml b/lib/prl/ast.ml
new file mode 100644
index 0000000..1969da6
--- /dev/null
+++ b/lib/prl/ast.ml
@@ -0,0 +1,16 @@
+open Sexplib.Std
+
+type function_predicate = {
+  name : string;
+  schema : (string * string) list;
+  symbol : string;
+  purity : Conventions.Purity.t;
+  cardinality : Conventions.Cardinality.t;
+}
+[@@deriving sexp]
+
+type statement =
+  | LoadLibrary of string
+  | DefineFunctionPredicate of function_predicate
+  | ListFunctionPredicates
+[@@deriving sexp]
diff --git a/lib/prl/executor.ml b/lib/prl/executor.ml
new file mode 100644
index 0000000..d4ceca5
--- /dev/null
+++ b/lib/prl/executor.ml
@@ -0,0 +1,83 @@
+module Make (Storage : Management.Physical.S) = struct
+  module Ops = Manipulation.Make (Storage)
+
+  type error =
+    | ParseError of string
+    | RuntimeError of string
+    | RelationError of Error.t
+    | UnknownPluginSymbol of string
+    | RelationNotFound of string
+
+  let sexp_of_error e =
+    let open Sexplib.Sexp in
+    match e with
+    | ParseError s -> List [ Atom "parse-error"; Atom s ]
+    | RuntimeError s -> List [ Atom "runtime-error"; Atom s ]
+    | RelationError err -> Error.sexp_of_error err
+    | UnknownPluginSymbol s -> List [ Atom "unknown-plugin-symbol"; Atom s ]
+    | RelationNotFound s -> List [ Atom "relation-not-found"; Atom s ]
+
+  let ( let* ) = Result.bind
+  let map_rel_error r = Result.map_error (fun e -> RelationError e) r
+
+  let require_relation (db : Management.Database.t) rel_name =
+    match Management.Database.get_relation db rel_name with
+    | Some rel -> Ok rel
+    | None -> Error (RelationNotFound rel_name)
+
+  let execute_load_library storage db path =
+    match Runtime.load_library path with
+    | Error e -> Error (RuntimeError e)
+    | Ok () ->
+        let* ll_rel = require_relation db Prelude.Catalog.loaded_library_rel_name in
+        let tuple = Prelude.Catalog.build_loaded_library_tuple path in
+        (match Ops.create_tuple storage db ll_rel tuple with
+        | Ok (new_db, _, _) -> Ok (Sublanguage_types.Transition new_db)
+        | Error (Error.DuplicateTuple _) -> Ok (Sublanguage_types.Transition db)
+        | Error e -> Error (RelationError e))
+
+  let execute_define_function_predicate storage db (spec : Ast.function_predicate) =
+    match Sakura_prl_api.find spec.symbol with
+    | None -> Error (UnknownPluginSymbol spec.symbol)
+    | Some impl ->
+        let schema =
+          List.fold_left
+            (fun s (a, d) -> Schema.add a d s)
+            Schema.empty spec.schema
+        in
+        let name = Qualified_name.(parse spec.name |> to_key) in
+        let generator = Runtime.make_generator name schema impl [] in
+        let producer = Runtime.make_producer name schema impl in
+        let membership_criteria = Runtime.make_membership_criteria schema impl in
+        let* new_db, _ =
+          Ops.create_immutable_relation storage db ~name ~schema ~generator
+            ~membership_criteria ~cardinality:spec.cardinality
+            ~producer:(Some producer)
+          |> map_rel_error
+        in
+        let* fp_rel =
+          require_relation new_db Prelude.Catalog.function_predicate_rel_name
+        in
+        let fp_tuple =
+          Prelude.Catalog.build_function_predicate_tuple ~name
+            ~symbol:spec.symbol ~cardinality:spec.cardinality ~purity:spec.purity
+        in
+        let* final_db =
+          Ops.create_tuple storage new_db fp_rel fp_tuple
+          |> map_rel_error
+          |> Result.map (fun (db, _, _) -> db)
+        in
+        Ok (Sublanguage_types.Transition final_db)
+
+  let execute_list_function_predicates db =
+    require_relation db Prelude.Catalog.function_predicate_rel_name
+    |> Result.map (fun rel -> Sublanguage_types.Query rel)
+
+  let execute storage db = function
+    | Ast.LoadLibrary path -> execute_load_library storage db path
+    | Ast.DefineFunctionPredicate spec ->
+        execute_define_function_predicate storage db spec
+    | Ast.ListFunctionPredicates -> execute_list_function_predicates db
+end
+
+module Memory = Make (Management.Physical.Memory)
diff --git a/lib/prl/parser.ml b/lib/prl/parser.ml
new file mode 100644
index 0000000..17102a4
--- /dev/null
+++ b/lib/prl/parser.ml
@@ -0,0 +1,12 @@
+type error = ParseError of string
+
+let of_sexp sexp =
+  let sexp =
+    match sexp with Sexplib.Sexp.List [ atom ] -> atom | other -> other
+  in
+  match Ast.statement_of_sexp sexp with
+  | stmt -> Ok stmt
+  | exception exn -> Error (ParseError (Printexc.to_string exn))
+
+let of_string s = of_sexp (Sexplib.Sexp.of_string s)
+let to_string stmt = Ast.sexp_of_statement stmt |> Sexplib.Sexp.to_string_hum
diff --git a/lib/prl/runtime.ml b/lib/prl/runtime.ml
new file mode 100644
index 0000000..d5e28ec
--- /dev/null
+++ b/lib/prl/runtime.ml
@@ -0,0 +1,84 @@
+type t = {
+  loaded_libraries : (string, unit) Hashtbl.t;
+  mutex : Mutex.t;
+}
+
+let state : t =
+  { loaded_libraries = Hashtbl.create 16; mutex = Mutex.create () }
+
+let load_library path : (unit, string) result =
+  Mutex.protect state.mutex (fun () ->
+      if Hashtbl.mem state.loaded_libraries path then Ok ()
+      else
+        try
+          Dynlink.loadfile path;
+          Hashtbl.replace state.loaded_libraries path ();
+          Ok ()
+        with Dynlink.Error e -> Error (Dynlink.error_message e))
+
+(* Convert an engine materialized tuple to the plugin's (string * Obj.t) list format. *)
+let to_plugin_row (schema : Schema.t) (tuple : Tuple.materialized) :
+    Sakura_prl_api.tuple option =
+  let rec go acc = function
+    | [] -> Some (List.rev acc)
+    | (attr_name, _) :: rest -> (
+        match Tuple.AttributeMap.find_opt attr_name tuple.attributes with
+        | None -> None
+        | Some attr -> go ((attr_name, attr.Attribute.value) :: acc) rest)
+  in
+  go [] schema
+
+(* Convert a plugin row back to an engine materialized tuple. *)
+let of_plugin_row relation_name (schema : Schema.t)
+    (row : Sakura_prl_api.tuple) : Tuple.materialized option =
+  let rec go acc = function
+    | [] -> Some { Tuple.relation = relation_name; attributes = acc }
+    | (attr_name, _) :: rest -> (
+        match List.assoc_opt attr_name row with
+        | None -> None
+        | Some value ->
+            go (Tuple.AttributeMap.add attr_name { Attribute.value = value } acc)
+              rest)
+  in
+  go Tuple.AttributeMap.empty schema
+
+(* Wrap a list of plugin rows as a generator. Uses an array for O(1) indexing. *)
+let rows_to_generator relation_name schema (rows : Sakura_prl_api.tuple list) :
+    Generator.t =
+  let arr = Array.of_list rows in
+  let n = Array.length arr in
+  let rec gen i _pos =
+    if i >= n then Generator.Done
+    else
+      match of_plugin_row relation_name schema arr.(i) with
+      | None -> Generator.Error "Plugin row does not conform to predicate schema."
+      | Some tuple -> Generator.Value (Tuple.Materialized tuple, gen (i + 1))
+  in
+  gen 0
+
+let make_generator relation_name schema (impl : Sakura_prl_api.implementation)
+    (bindings : Sakura_prl_api.tuple) : Generator.t =
+  match impl.produce with
+  | None -> fun _ -> Generator.Done
+  | Some produce ->
+      let rows_result = lazy (produce bindings) in
+      fun _pos ->
+        match Lazy.force rows_result with
+        | Error e -> Generator.Error e
+        | Ok rows -> rows_to_generator relation_name schema rows _pos
+
+let make_producer relation_name schema (impl : Sakura_prl_api.implementation) :
+    Relation.producer =
+  fun bindings -> make_generator relation_name schema impl bindings
+
+let make_membership_criteria schema (impl : Sakura_prl_api.implementation) :
+    (string -> Merkle.t option) -> Tuple.t -> bool =
+  match impl.membership_criteria with
+  | None -> fun _ _ -> false
+  | Some check ->
+      fun _tree_of -> function
+        | Tuple.NonMaterialized _ -> false
+        | Tuple.Materialized m -> (
+            match to_plugin_row schema m with
+            | None -> false
+            | Some row -> (match check row with Ok b -> b | Error _ -> false))
diff --git a/lib/prl/sublanguage.ml b/lib/prl/sublanguage.ml
new file mode 100644
index 0000000..b23f370
--- /dev/null
+++ b/lib/prl/sublanguage.ml
@@ -0,0 +1,21 @@
+module Make (Storage : Management.Physical.S) = struct
+  module Exec = Executor.Make (Storage)
+
+  type configuration = unit
+  type storage = Storage.t
+  type ast = Ast.statement
+  type error = Exec.error
+
+  let name = "prl"
+  let parse _ = Ok ()
+
+  let parse_sexp sexp =
+    match Parser.of_sexp sexp with
+    | Ok r -> Ok r
+    | Error (Parser.ParseError s) -> Error (Exec.ParseError s)
+
+  let execute = Exec.execute
+  let sexp_of_error = Exec.sexp_of_error
+end
+
+module Memory = Make (Management.Physical.Memory)