diff options
| -rw-r--r-- | lib/Utilities.ml | 4 | ||||
| -rw-r--r-- | lib/Utilities.mli | 4 | ||||
| -rw-r--r-- | lib/kernel/Path.ml | 41 | ||||
| -rw-r--r-- | lib/kernel/Path.mli | 1 |
4 files changed, 34 insertions, 16 deletions
diff --git a/lib/Utilities.ml b/lib/Utilities.ml index 404d8aa..fb5a7b3 100644 --- a/lib/Utilities.ml +++ b/lib/Utilities.ml @@ -104,3 +104,7 @@ module Atomic = struct then Ok atom else mswap atom f end + +module Fun = struct + let ( |.| ) = Fun.compose +end diff --git a/lib/Utilities.mli b/lib/Utilities.mli index 11c4487..2b9591c 100644 --- a/lib/Utilities.mli +++ b/lib/Utilities.mli @@ -34,3 +34,7 @@ module FingerTree : sig val join : string BatFingerTree.t -> string -> string end + +module Fun : sig + val ( |.| ) : ('a -> 'b) -> ('c -> 'a) -> 'c -> 'b +end diff --git a/lib/kernel/Path.ml b/lib/kernel/Path.ml index 629a527..25ce09a 100644 --- a/lib/kernel/Path.ml +++ b/lib/kernel/Path.ml @@ -15,32 +15,41 @@ module Error = struct let path_not_found path = condition "path-not-found" "A given path was not found under the specified object" ("path" |=| Concepts.Value.String (to_string path)) - - let not_a_registry path = condition "not-a-registry" "The specified path did not point to a registry" - ("path" |=| Concepts.Value.String (to_string path)) - - let not_a_directory path = condition "not-a-directory" "The specified path did not point to a directory" - ("path" |=| Concepts.Value.String (to_string path)) end -let lookup handle path = +let walking f g handle path = let rec walk handle = function - | [] -> Ok handle + | [] -> g handle | x::xs -> let open Utilities.Result in let open Protocols in - match Directory.from handle with + let* dir = Handle.require Directory.from handle in + let* elem = Directory.find dir x in + match elem with | None -> Error (Error.path_not_found path) - | Some dir -> - let* elem = Directory.find dir x in - match elem with - | None -> Error (Error.not_a_directory path) - | Some elem -> walk elem xs + | Some elem -> f x handle (fun () -> walk elem xs) in walk handle path +let lookup = walking (fun _ _ f -> f ()) Result.ok + let update handle path key reference value = let open Utilities.Result in + let open Protocols in let* handle = lookup handle path in - let* registry = Protocols.Registry.from handle |> Option.to_result ~none:(Error.not_a_registry path) in - Protocols.Registry.update registry key reference value + let* registry = Handle.require Registry.from handle in + Registry.update registry key reference value + +let assoc handle path key value = + let open Utilities.Result in + let open Utilities.Fun in + let open Protocols in + let assoc_on handle key value = + let* a = Handle.require Associative.from handle in + let* a' = Associative.update a key value in + Ok (Handle.from a') + in + walking + (fun key dir f -> f () |> fmap (assoc_on dir key |.| Option.some)) + (fun h -> assoc_on h key value) + handle path diff --git a/lib/kernel/Path.mli b/lib/kernel/Path.mli index 6a74350..ece0615 100644 --- a/lib/kernel/Path.mli +++ b/lib/kernel/Path.mli @@ -6,3 +6,4 @@ val (@/) : string -> t -> t val lookup : Protocols.Handle.t -> t -> (Protocols.Handle.t, Concepts.Condition.condition) result val update : Protocols.Handle.t -> t -> string -> Protocols.Handle.t option -> Protocols.Handle.t option -> (bool, Concepts.Condition.condition) result +val assoc : Protocols.Handle.t -> t -> string -> Protocols.Handle.t option -> (Protocols.Handle.t, Concepts.Condition.condition) result |