aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--lib/protocols/Schematics.ml30
-rw-r--r--lib/protocols/Schematics.mli18
2 files changed, 48 insertions, 0 deletions
diff --git a/lib/protocols/Schematics.ml b/lib/protocols/Schematics.ml
new file mode 100644
index 0000000..b0297e7
--- /dev/null
+++ b/lib/protocols/Schematics.ml
@@ -0,0 +1,30 @@
+module type S = sig
+ module Schema : Abstract.Schematics.SCHEMA
+ type t
+
+ class type implementation = object
+ method schema : (Schema.t, Concepts.Condition.condition) result
+ end
+
+ val make : #implementation -> Handle.protocol
+ val from : Handle.t -> t Handle.interface option
+ val schema : t Handle.interface -> (Schema.t, Concepts.Condition.condition) result
+ val attributes :
+ t Handle.interface ->
+ ((string * Schema.attribute) BatFingerTree.t, Concepts.Condition.condition) result
+end
+
+module Make (Schema : Abstract.Schematics.SCHEMA) = struct
+ module Schema = Schema
+ class type implementation = object
+ method schema : (Schema.t, Concepts.Condition.condition) result
+ end
+
+ type Handle.protocol += Schematics of implementation
+ type t = implementation
+
+ let make impl = Schematics (impl :> implementation)
+ let from handle = Handle.into handle (function Schematics impl -> Some impl | _ -> None)
+ let schema i = Handle.invoke i (fun o -> o#schema)
+ let attributes i = Result.map Schema.attributes (schema i)
+end
diff --git a/lib/protocols/Schematics.mli b/lib/protocols/Schematics.mli
new file mode 100644
index 0000000..d8533bf
--- /dev/null
+++ b/lib/protocols/Schematics.mli
@@ -0,0 +1,18 @@
+(** Instantiate once and share the protocol with schema providers and evaluators. *)
+module type S = sig
+ module Schema : Abstract.Schematics.SCHEMA
+ type t
+
+ class type implementation = object
+ method schema : (Schema.t, Concepts.Condition.condition) result
+ end
+
+ val make : #implementation -> Handle.protocol
+ val from : Handle.t -> t Handle.interface option
+ val schema : t Handle.interface -> (Schema.t, Concepts.Condition.condition) result
+ val attributes :
+ t Handle.interface ->
+ ((string * Schema.attribute) BatFingerTree.t, Concepts.Condition.condition) result
+end
+
+module Make (Schema : Abstract.Schematics.SCHEMA) : S with module Schema = Schema