lib/kernel/Path.ml


1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62

type t = string list

let this = []
let ( @/ ) x y = x :: y

let to_string path =
  path
  |> List.map (fun x ->
      let str = BatString.replace ~str:x ~sub:"^" ~by:"^^" |> snd in
      BatString.replace ~str ~sub:"/" ~by:"^/" |> snd )
  |> BatIO.to_string (BatList.print ~first:"/" ~last:"" ~sep:"/" BatString.print)

module Error = struct
  open Concepts.Condition

  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))
end

let walking f g handle path =
  let rec walk handle = function
    | [] -> g handle
    | x :: xs -> (
        let open Utilities.Result in
        let open Protocols in
        let* dir =
          Handle.require Directory.from handle
          |> Result.map_error
               Concepts.Condition.(complement ("before-segment" |=| Concepts.Value.String x))
        in
        let* elem = Directory.find dir x in
        match elem with
        | None -> Error (Error.path_not_found path)
        | Some elem -> f x handle (fun () -> walk elem xs) )
  in
  walk handle path
  |> Result.map_error
       Concepts.Condition.(complement ("path" |=| Concepts.Value.String (to_string 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 = 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