aboutsummaryrefslogtreecommitdiffstats
path: root/lib/protocols
diff options
context:
space:
mode:
Diffstat (limited to 'lib/protocols')
-rw-r--r--lib/protocols/Admission.ml21
-rw-r--r--lib/protocols/Admission.mli11
-rw-r--r--lib/protocols/Evaluator.ml10
-rw-r--r--lib/protocols/Evaluator.mli15
-rw-r--r--lib/protocols/Executable.ml12
-rw-r--r--lib/protocols/Executable.mli19
-rw-r--r--lib/protocols/Handle.ml1
-rw-r--r--lib/protocols/Handle.mli1
-rw-r--r--lib/protocols/Relation.ml20
-rw-r--r--lib/protocols/Relation.mli10
10 files changed, 116 insertions, 4 deletions
diff --git a/lib/protocols/Admission.ml b/lib/protocols/Admission.ml
new file mode 100644
index 0000000..c29f192
--- /dev/null
+++ b/lib/protocols/Admission.ml
@@ -0,0 +1,21 @@
+module Error = struct
+ open Concepts.Condition
+
+ let not_admitting () =
+ condition "not-admitting" "A handle was expected to carry the admission protocol and did not"
+ empty
+end
+
+type violations = (string * Concepts.Tuple.t) list
+
+class type implementation = object
+ method check : (violations, Concepts.Condition.condition) result
+end
+
+type Handle.protocol += Admission of implementation
+type t = implementation
+
+let make impl = Admission (impl :> implementation)
+let from handle = Handle.into handle (function Admission impl -> Some impl | _ -> None)
+let require handle = from handle |> Option.to_result ~none:(Error.not_admitting ())
+let check i = Handle.invoke i (fun o -> o#check)
diff --git a/lib/protocols/Admission.mli b/lib/protocols/Admission.mli
new file mode 100644
index 0000000..7f0c596
--- /dev/null
+++ b/lib/protocols/Admission.mli
@@ -0,0 +1,11 @@
+type t
+type violations = (string * Concepts.Tuple.t) list
+
+class type implementation = object
+ method check : (violations, Concepts.Condition.condition) result
+end
+
+val make : #implementation -> Handle.protocol
+val from : Handle.t -> t Handle.interface option
+val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
+val check : t Handle.interface -> (violations, Concepts.Condition.condition) result
diff --git a/lib/protocols/Evaluator.ml b/lib/protocols/Evaluator.ml
index 789fb9d..6a63431 100644
--- a/lib/protocols/Evaluator.ml
+++ b/lib/protocols/Evaluator.ml
@@ -1,5 +1,10 @@
+type kind = ..
+
class type implementation = object
- method invoke : Handle.t -> (Handle.t, Concepts.Condition.condition) result
+ method parse : string -> (kind, Concepts.Condition.condition) result
+
+ method eval :
+ kind -> Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result
end
type Handle.protocol += Evaluator of implementation
@@ -8,4 +13,5 @@ type t = implementation
let make impl = Evaluator (impl :> implementation)
let from handle = Handle.into handle (function Evaluator impl -> Some impl | _ -> None)
let require = Handle.require from
-let invoke i program = Handle.invoke i (fun o -> o#invoke program)
+let parse i source = Handle.invoke i (fun o -> o#parse source)
+let eval i kind inputs ~within = Handle.invoke i (fun o -> o#eval kind inputs ~within)
diff --git a/lib/protocols/Evaluator.mli b/lib/protocols/Evaluator.mli
index 3d42b5c..934c5e3 100644
--- a/lib/protocols/Evaluator.mli
+++ b/lib/protocols/Evaluator.mli
@@ -1,10 +1,21 @@
type t
+type kind = ..
class type implementation = object
- method invoke : Handle.t -> (Handle.t, Concepts.Condition.condition) result
+ method parse : string -> (kind, Concepts.Condition.condition) result
+
+ method eval :
+ kind -> Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result
end
val make : #implementation -> Handle.protocol
val from : Handle.t -> t Handle.interface option
val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
-val invoke : t Handle.interface -> Handle.t -> (Handle.t, Concepts.Condition.condition) result
+val parse : t Handle.interface -> string -> (kind, Concepts.Condition.condition) result
+
+val eval :
+ t Handle.interface ->
+ kind ->
+ Handle.t list ->
+ within:Handle.t ->
+ (Handle.t, Concepts.Condition.condition) result
diff --git a/lib/protocols/Executable.ml b/lib/protocols/Executable.ml
new file mode 100644
index 0000000..5dea52c
--- /dev/null
+++ b/lib/protocols/Executable.ml
@@ -0,0 +1,12 @@
+class type implementation = object
+ method invoke :
+ Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result
+end
+
+type Handle.protocol += Executable of implementation
+type t = implementation
+
+let make impl = Executable (impl :> implementation)
+let from handle = Handle.into handle (function Executable impl -> Some impl | _ -> None)
+let require = Handle.require from
+let invoke i inputs ~within = Handle.invoke i (fun o -> o#invoke inputs ~within)
diff --git a/lib/protocols/Executable.mli b/lib/protocols/Executable.mli
new file mode 100644
index 0000000..ccb63e1
--- /dev/null
+++ b/lib/protocols/Executable.mli
@@ -0,0 +1,19 @@
+type t
+
+(** [within] is the directory the program's paths resolve against: the
+ branch state a stored program was read through, or whatever part of
+ the tree a caller hands over. *)
+class type implementation = object
+ method invoke :
+ Handle.t list -> within:Handle.t -> (Handle.t, Concepts.Condition.condition) result
+end
+
+val make : #implementation -> Handle.protocol
+val from : Handle.t -> t Handle.interface option
+val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
+
+val invoke :
+ t Handle.interface ->
+ Handle.t list ->
+ within:Handle.t ->
+ (Handle.t, Concepts.Condition.condition) result
diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml
index dd923c6..0c5f3cc 100644
--- a/lib/protocols/Handle.ml
+++ b/lib/protocols/Handle.ml
@@ -91,4 +91,5 @@ let move handle =
let equal h1 h2 = Concepts.Hash.hash_equals (object_of h1)#hash (object_of h2)#hash
let hash h = (object_of h)#hash
let protocols h = (object_of h)#protocols
+let releasing handle f = Fun.protect ~finally:(fun () -> release handle) f
let require f h = Option.to_result ~none:(Error.unimplemented_protocol (to_string h)) (f h)
diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli
index 1c3b9d4..94734e4 100644
--- a/lib/protocols/Handle.mli
+++ b/lib/protocols/Handle.mli
@@ -19,6 +19,7 @@ val copy : t -> t option
val move : t -> t
val equal : t -> t -> bool
val release : t -> unit
+val releasing : t -> (unit -> 'a) -> 'a
val hash : t -> Concepts.Hash.hash
val protocols : t -> protocol list
val to_string : t -> string
diff --git a/lib/protocols/Relation.ml b/lib/protocols/Relation.ml
index 3962c9c..c1cdfee 100644
--- a/lib/protocols/Relation.ml
+++ b/lib/protocols/Relation.ml
@@ -8,6 +8,7 @@ end
class type implementation = object
method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+ method modes : (Concepts.Mode.t, Concepts.Condition.condition) result
end
type Handle.protocol += Relation of implementation
@@ -17,3 +18,22 @@ let make impl = Relation (impl :> implementation)
let from handle = Handle.into handle (function Relation impl -> Some impl | _ -> None)
let require handle = from handle |> Option.to_result ~none:(Error.not_a_relation ())
let contains i tuple = Handle.invoke i (fun o -> o#contains tuple)
+let modes i = Handle.invoke i (fun o -> o#modes)
+
+let heading relation =
+ let open Utilities.Result in
+ let* schematics = Handle.require Schematics.from relation in
+ let* description = Schematics.describe schematics in
+ match description with
+ | Schematics.Relation heading -> Ok heading
+ | _ -> Error (Error.not_a_relation ())
+
+let read relation =
+ let open Utilities.Result in
+ let* heading = heading relation in
+ let* enumerable = Enumerable.require relation in
+ let* cursor = Enumerable.enumerate enumerable in
+ Handle.releasing cursor (fun () ->
+ let* scan = Cursor.require cursor in
+ let* tuples = Cursor.drain scan () in
+ Ok (heading, BatFingerTree.to_list tuples) )
diff --git a/lib/protocols/Relation.mli b/lib/protocols/Relation.mli
index be11cc1..28dfdff 100644
--- a/lib/protocols/Relation.mli
+++ b/lib/protocols/Relation.mli
@@ -2,9 +2,19 @@ type t
class type implementation = object
method contains : Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+ method modes : (Concepts.Mode.t, Concepts.Condition.condition) result
end
val make : #implementation -> Handle.protocol
val from : Handle.t -> t Handle.interface option
val require : Handle.t -> (t Handle.interface, Concepts.Condition.condition) result
val contains : t Handle.interface -> Concepts.Tuple.t -> (bool, Concepts.Condition.condition) result
+val modes : t Handle.interface -> (Concepts.Mode.t, Concepts.Condition.condition) result
+
+(** the heading a relation describes itself with. *)
+val heading : Handle.t -> (Schematics.relation_description, Concepts.Condition.condition) result
+
+(** the heading and tuples of a relation, read whole. *)
+val read :
+ Handle.t ->
+ (Schematics.relation_description * Concepts.Tuple.t list, Concepts.Condition.condition) result
generated by cgit v1.2.3 (git 2.25.1) at 2026-11-10 12:01:34 +0000