cursor and context

2 files changed, 45 insertions, 0 deletions

diff --git a/lib/protocols/Context.ml b/lib/protocols/Context.ml
new file mode 100644
index 0000000..ea314a6
--- /dev/null
+++ b/lib/protocols/Context.ml
@@ -0,0 +1,30 @@
+module Error = struct
+  open Concepts.Condition
+
+  let unresolved name =
+    condition "unresolved-name" "A name did not resolve to any object reachable from this context"
+      ("name" |=| Concepts.Value.String name)
+end
+
+class type implementation = object
+  method resolve : string -> (Handle.t option, Concepts.Condition.condition) result
+  method cancelled : bool
+  method charge : int -> (unit, Concepts.Condition.condition) result
+  method nest : ?authority:string BatSet.t -> unit -> implementation
+end
+
+(* Unlike every other protocol here, a context is handed to [Program.invoke] directly rather than
+   looked up through [Handle.into], exactly as evaluators.org's pseudocode shows. It therefore needs
+   no extensible-variant constructor and [make] is a plain upcast. *)
+type t = implementation
+
+let make impl = (impl :> implementation)
+let resolve context name = context#resolve name
+let cancelled context = context#cancelled
+let charge context n = context#charge n
+let nest ?authority context = context#nest ?authority () |> make
+
+let require context name =
+  let open Utilities.Result in
+  let* found = resolve context name in
+  Option.to_result ~none:(Error.unresolved name) found
diff --git a/lib/protocols/Context.mli b/lib/protocols/Context.mli
new file mode 100644
index 0000000..ec585cd
--- /dev/null
+++ b/lib/protocols/Context.mli
@@ -0,0 +1,15 @@
+type t
+
+class type implementation = object
+  method resolve : string -> (Handle.t option, Concepts.Condition.condition) result
+  method cancelled : bool
+  method charge : int -> (unit, Concepts.Condition.condition) result
+  method nest : ?authority:string BatSet.t -> unit -> implementation
+end
+
+val make : #implementation -> t
+val resolve : t -> string -> (Handle.t option, Concepts.Condition.condition) result
+val require : t -> string -> (Handle.t, Concepts.Condition.condition) result
+val cancelled : t -> bool
+val charge : t -> int -> (unit, Concepts.Condition.condition) result
+val nest : ?authority:string BatSet.t -> t -> t