diff options
Diffstat (limited to 'lib/protocols')
| -rw-r--r-- | lib/protocols/Addressable.ml | 13 | ||||
| -rw-r--r-- | lib/protocols/Addressable.mli | 11 | ||||
| -rw-r--r-- | lib/protocols/Context.ml | 4 | ||||
| -rw-r--r-- | lib/protocols/Handle.ml | 9 | ||||
| -rw-r--r-- | lib/protocols/Handle.mli | 2 |
5 files changed, 35 insertions, 4 deletions
diff --git a/lib/protocols/Addressable.ml b/lib/protocols/Addressable.ml new file mode 100644 index 0000000..7e97f08 --- /dev/null +++ b/lib/protocols/Addressable.ml @@ -0,0 +1,13 @@ +class type implementation = object + method address : Concepts.Hash.hash +end + +type Handle.protocol += Addressable of implementation + +type t = implementation + +let make impl = Addressable (impl :> implementation) + +let from handle = Handle.into handle (function Addressable impl -> Some impl | _ -> None) + +let address i = Handle.invoke i (fun o -> o#address) diff --git a/lib/protocols/Addressable.mli b/lib/protocols/Addressable.mli new file mode 100644 index 0000000..2d9c14d --- /dev/null +++ b/lib/protocols/Addressable.mli @@ -0,0 +1,11 @@ +type t + +class type implementation = object + method address : Concepts.Hash.hash +end + +val make : #implementation -> Handle.protocol + +val from : Handle.t -> t Handle.interface option + +val address : t Handle.interface -> Concepts.Hash.hash diff --git a/lib/protocols/Context.ml b/lib/protocols/Context.ml deleted file mode 100644 index b7c8a37..0000000 --- a/lib/protocols/Context.ml +++ /dev/null @@ -1,4 +0,0 @@ -type t = - { snapshot : Concepts.Hash.hash - ; root : Handle.t - ; status : unit -> [`Live | `Cancelled | `Exhausted] } diff --git a/lib/protocols/Handle.ml b/lib/protocols/Handle.ml index 524386b..313a3d4 100644 --- a/lib/protocols/Handle.ml +++ b/lib/protocols/Handle.ml @@ -1,5 +1,12 @@ type protocol = .. +module Error = struct + open Concepts.Condition + + let unimplemented_protocol () = condition "unimplemented-protocol" "A required protocol was not implemented by the specified object" + empty +end + class type obj = object method reference : bool method release : unit @@ -45,3 +52,5 @@ let release ({ valid; _ } as handle) = let o = object_of handle in valid := false; o#release + +let require f h = Option.to_result ~none:(Error.unimplemented_protocol ()) (f h) diff --git a/lib/protocols/Handle.mli b/lib/protocols/Handle.mli index f36c95e..f63bbea 100644 --- a/lib/protocols/Handle.mli +++ b/lib/protocols/Handle.mli @@ -22,3 +22,5 @@ val equal : t -> t -> bool val release : t -> unit val hash : t -> Concepts.Hash.hash + +val require : (t -> 'a interface option) -> t -> ('a interface, Concepts.Condition.condition) result |
