lib/kernel/Prototype.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
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86

let mixture ps = Protocols.Handle.make @@
                   object
                     inherit Lifecycle.null
                     inherit Identity.of_id (* Should we allow the user to override this? *)

                     method protocols = ps
                   end

let rec mixture_of value f =
  mixture (f (fun value' -> mixture_of value' f) value)

module Error = struct
  open Concepts.Condition

  let invalid_property key = condition "invalid-property" "The specified key does not correspond to any property of the object"
                               ("key" |=| Concepts.Value.String key)

  let deletion_not_supported () = condition "deletion-not-supported" "Attempting to delete an object property"
                                    empty
end

module Associative = struct
  let of_properties props =
    Protocols.Associative.make @@
      object
        val props = BatList.to_seq props |> BatMap.of_seq

        method update key value =
          match BatMap.find_opt key props with
          | None -> Error (Error.invalid_property key)
          | Some f -> f value
      end

  let update_only f = function
    | None -> Error (Error.deletion_not_supported ())
    | Some x -> f x

  module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) = struct
    module Tree = Merkle.Make (S) (K)
    module SI = Storage.Make (S)

    let make ~storage ~constructor ~node =
      Protocols.Associative.make @@
        object
          method update key value =
            (* TODO: read-only transactions *)
            SI.with_transaction storage (fun tx ->
                let open Utilities.Result in
                let open Protocols in
                let* node' = match value with
                  | None -> Tree.remove tx key node
                  | Some h ->
                     let* addressable = Handle.require Addressable.from h in
                     let addr = Addressable.address addressable in
                     Tree.insert tx key addr node
                in
                constructor node')
        end
  end
end

module Directory = struct
  let of_properties props =
    Protocols.Directory.make @@
      object
        val props = BatList.to_seq props |> BatMap.of_seq

        method list = Ok (BatMap.keys props |> BatFingerTree.of_enum)
        method find k = Ok (BatMap.find_opt k props)
      end

  module OfTree (S : Abstract.Storage.STORAGE) (K : Merkle.KEY with type t = string) (V : Merkle.VALUE) = struct
    module Tree = Merkle.Interface (S) (K) (V)
    module SI = Storage.Make (S)

    let make ~storage ~constructor ~node =
      Protocols.Directory.make @@
        object
          method list = SI.with_transaction storage (Fun.flip Tree.keys node)
          method find k = SI.with_transaction storage (fun tx -> Tree.lookup tx k node)
                          |> Utilities.Result.fmap (function
                                 | None -> Ok None
                                 | Some x -> constructor x |> Result.map (Option.some))
        end
  end
end