package octez-libs

  1. Overview
  2. Docs
package octez-libs
Legend:
Page
Library
Module
Module type
Parameter
Class
Class type
Source

Source file encoding.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
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
(*****************************************************************************)
(*                                                                           *)
(* Open Source License                                                       *)
(* Copyright (c) 2022 TriliTech <contact@trili.tech>                         *)
(* Copyright (c) 2022 Nomadic Labs <contact@nomadic-labs.com>                *)
(*                                                                           *)
(* Permission is hereby granted, free of charge, to any person obtaining a   *)
(* copy of this software and associated documentation files (the "Software"),*)
(* to deal in the Software without restriction, including without limitation *)
(* the rights to use, copy, modify, merge, publish, distribute, sublicense,  *)
(* and/or sell copies of the Software, and to permit persons to whom the     *)
(* Software is furnished to do so, subject to the following conditions:      *)
(*                                                                           *)
(* The above copyright notice and this permission notice shall be included   *)
(* in all copies or substantial portions of the Software.                    *)
(*                                                                           *)
(* THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR*)
(* IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,  *)
(* FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL   *)
(* THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER*)
(* LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING   *)
(* FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER       *)
(* DEALINGS IN THE SOFTWARE.                                                 *)
(*                                                                           *)
(*****************************************************************************)

type key = string list

exception No_tag_matched_on_encoding

(** [append_key prefix key] append [key] to [prefix] in order to create a new
      [prefix_key]. *)
let append_key prefix key tail = prefix (List.append key tail)

(** Given the tail key, construct a full key. *)
type prefix_key = key -> key

type -'a t = {
  encode : 'tree. 'tree Tree.backend -> 'a -> prefix_key -> 'tree -> 'tree Lwt.t;
}
[@@unboxed]

let ignore = {encode = (fun _backend _val _key tree -> Lwt.return tree)}

let run backend {encode} value tree = encode backend value Fun.id tree

let lwt {encode} =
  {
    encode =
      (fun backend value prefix tree ->
        let open Lwt_syntax in
        let* v = value in
        encode backend v prefix tree);
  }

let delayed f =
  {encode = (fun backend x key tree -> (f ()).encode backend x key tree)}

let contramap f {encode} =
  {encode = (fun backend value -> encode backend (f value))}

let contramap_lwt f {encode} =
  {
    encode =
      (fun backend value prefix tree ->
        let open Lwt_syntax in
        let* v = f value in
        encode backend v prefix tree);
  }

let tup2 lhs rhs =
  {
    encode =
      (fun backend (l, r) prefix tree ->
        let open Lwt.Syntax in
        let* tree = lhs.encode backend l prefix tree in
        rhs.encode backend r prefix tree);
  }

let tup3 encode_a encode_b encode_c =
  {
    encode =
      (fun backend (a, b, c) prefix tree ->
        let open Lwt.Syntax in
        let* tree = encode_a.encode backend a prefix tree in
        let* tree = encode_b.encode backend b prefix tree in
        encode_c.encode backend c prefix tree);
  }

let raw suffix =
  {
    encode =
      (fun backend bytes prefix tree ->
        Tree.add backend tree (prefix suffix) bytes);
  }

let value suffix enc =
  {
    encode =
      (fun backend v prefix tree ->
        (contramap (Data_encoding.Binary.to_bytes_exn enc) (raw suffix)).encode
          backend
          v
          prefix
          tree);
  }

let value_option key encoding =
  {
    encode =
      (fun backend v prefix tree ->
        match v with
        | Some v -> (value key encoding).encode backend v prefix tree
        | None -> Tree.remove backend tree (prefix key));
  }

let scope key {encode} =
  {
    encode =
      (fun backend value prefix tree ->
        encode backend value (append_key prefix key) tree);
  }

let lazy_mapping to_key enc_value =
  {
    encode =
      (fun backend (origin_opt, bindings) prefix tree ->
        let open Lwt_syntax in
        let* tree =
          match origin_opt with
          | Some (Tree.Wrapped_tree (origin, origin_backend)) ->
              Tree.add_tree
                backend
                tree
                (prefix [])
                (Tree.select backend @@ Tree.wrap origin_backend origin)
              (* Will fetch a tree of the same type as backend or throw an error.
                 Basically checking that origin's backend and encoding backeds are the same *)
          | None -> Tree.remove backend tree (prefix [])
        in
        List.fold_left_s
          (fun tree (k, v) ->
            let key = append_key prefix (to_key k) in
            let* tree = Tree.remove backend tree (key []) in
            match v with
            | Some v -> enc_value.encode backend v key tree
            | None -> Lwt.return tree)
          tree
          bindings);
  }

type ('tag, 'a) case =
  | Case : {
      tag : 'tag;
      probe : 'a -> 'b Lwt.t option;
      encode : 'b t;
    }
      -> ('tag, 'a) case

let case_lwt tag encode probe = Case {tag; encode; probe}

let case tag encode probe =
  let probe x = Option.map Lwt.return @@ probe x in
  case_lwt tag encode probe

let tagged_union encode_tag cases =
  {
    encode =
      (fun backend value prefix target_tree ->
        let open Lwt_syntax in
        let encode_tag = scope ["tag"] encode_tag in
        let match_case (Case {probe; tag; encode}) =
          match probe value with
          | Some res ->
              let* target_tree =
                encode_tag.encode backend tag prefix target_tree
              in
              let* value = res in
              let* x =
                (scope ["value"] encode).encode backend value prefix target_tree
              in
              return_some x
          | None -> return_none
        in
        let* tree_opt = List.find_map_s match_case cases in
        match tree_opt with
        | None -> raise No_tag_matched_on_encoding
        | Some tree -> return tree);
  }

let wrapped_tree =
  {
    encode =
      (fun backend (Tree.Wrapped_tree (subtree, backend')) prefix target_tree ->
        let subtree = Tree.select backend (Tree.wrap backend' subtree) in
        let key = prefix [] in
        Tree.add_tree backend target_tree key subtree);
  }
OCaml

Innovation. Community. Security.

GitHub Discord Twitter Peertube RSS
About
Changelog Releases Industrial Users Academic Users Why OCaml
Ecosystem
Packages Community Events OCaml Planet Jobs
Resources
Install OCaml Get Started Platform Tools Language Manual Standard Library API Books Exercises Papers OCaml Playground Logo
Policies
Carbon Footprint Governance Privacy Code of Conduct