diff --git a/src/lib_base/bounded.ml b/src/lib_base/bounded.ml index 24a46987a82940050178e05c3543ffa28f6d9172..cb27193c09565ece5ac6cdf95a66a52ec22479ce 100644 --- a/src/lib_base/bounded.ml +++ b/src/lib_base/bounded.ml @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2022 Trili Tech, *) +(* Copyright (c) 2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -23,52 +24,246 @@ (* *) (*****************************************************************************) -module Int32 = struct - module type BOUNDS = sig - val min_int : int32 +(* This datatype aims to represent encodings from + [Data_encoding.t]. The GADT is used to know what is the underlying + ocaml datatype. This allows to write the logic of this module in a + generic manner, as long as the tests. *) - val max_int : int32 - end +type 'ocaml ty = + | Int64 : int64 ty + | Int32 : int32 ty + | Int31 : int ty + | Int16 : int ty + | Uint16 : int ty + | Int8 : int ty + | Uint8 : int ty - module type S = sig - type t +let encoding : type a. a ty -> a Data_encoding.t = function + | Int64 -> Data_encoding.int64 + | Int32 -> Data_encoding.int32 + | Int31 -> Data_encoding.int31 + | Int16 -> Data_encoding.int16 + | Uint16 -> Data_encoding.uint16 + | Int8 -> Data_encoding.int8 + | Uint8 -> Data_encoding.uint8 - include BOUNDS +let compare : type a. a ty -> (module Compare.S with type t = a) = function + | Int64 -> (module Compare.Int64) + | Int32 -> (module Compare.Int32) + | Int31 -> (module Compare.Int) + | Int16 -> (module Compare.Int) + | Uint16 -> (module Compare.Int) + | Int8 -> (module Compare.Int) + | Uint8 -> (module Compare.Int) - include Compare.S with type t := t +let pp_ty : type a. Format.formatter -> a ty -> unit = + fun fmt ty -> + match ty with + | Int64 -> Format.fprintf fmt "int64" + | Int32 -> Format.fprintf fmt "int32" + | Int31 -> Format.fprintf fmt "int31" + | Int16 -> Format.fprintf fmt "int16" + | Uint16 -> Format.fprintf fmt "uint16" + | Int8 -> Format.fprintf fmt "int8" + | Uint8 -> Format.fprintf fmt "uint8" - val encoding : t Data_encoding.t +let pp : type a. a ty -> Format.formatter -> a -> unit = function + | Int64 -> fun fmt value -> Format.fprintf fmt "%Ld" value + | Int32 -> fun fmt value -> Format.fprintf fmt "%ld" value + | Int31 -> Format.pp_print_int + | Int16 -> Format.pp_print_int + | Uint16 -> Format.pp_print_int + | Int8 -> Format.pp_print_int + | Uint8 -> Format.pp_print_int - val to_int32 : t -> int32 +let ty_max_value : type a. a ty -> a = function + | Int64 -> Int64.max_int + | Int32 -> Int32.max_int + | Int31 -> (1 lsl 30) - 1 + | Int16 -> (1 lsl 15) - 1 + | Uint16 -> (1 lsl 16) - 1 + | Int8 -> (1 lsl 7) - 1 + | Uint8 -> (1 lsl 8) - 1 - val of_int32 : int32 -> t option - end +let ty_min_value : type a. a ty -> a = function + | Int64 -> Int64.min_int + | Int32 -> Int32.min_int + | Int31 -> -(1 lsl 30) + | Int16 -> -(1 lsl 15) + | Uint16 -> 0 + | Int8 -> -(1 lsl 7) + | Uint8 -> 0 - module Make (B : BOUNDS) = struct - include Compare.Int32 (* This includes [type t = int32] *) - include B +module type BOUNDS = sig + type ocaml_type - let to_int32 x = x + val min_value : ocaml_type - let of_int32 n = - if Compare.Int32.(n < B.min_int) then None - else if Compare.Int32.(n > B.max_int) then None - else Some n + val max_value : ocaml_type +end + +module type S = sig + type t + + type ocaml_type + + include BOUNDS with type ocaml_type := ocaml_type + + include Compare.S with type t := t + + val encoding : t Data_encoding.t + + val pp : Format.formatter -> t -> unit + + val to_value : t -> ocaml_type + + val of_value : ocaml_type -> t option +end + +(* If the encoding choosen can represent strictly less values than the + underlying ocaml datatype, some exceptions could be raised at + encoding time. Those static checks aims to be executed when the + functor is instantiated to detect those cases sooner. *) +let checks (type ocaml_type) (ty : ocaml_type ty) ( < ) ( > ) ~min_value + ~max_value = + let pp = pp ty in + if max_value > ty_max_value ty then + invalid_arg + (Format.asprintf + "Tezos-base.Bounded(%a): Maximum encodable value: %a. Bound given: %a" + pp_ty + ty + pp + (ty_max_value ty) + pp + max_value) ; + if min_value < ty_min_value ty then + invalid_arg + (Format.asprintf + "Tezos-base.Bounded(%a): Minimum encodable value: %a. Bound given: %a" + pp_ty + ty + pp + (ty_max_value ty) + pp + max_value) + [@@inline always] + +(* A partial encoding that ensures the decoded value is in the specified bounds. *) +let guarded_encoding ty ~to_value ~of_value = + let open Data_encoding in + conv_with_guard + to_value + (fun x -> + match of_value x with None -> Error "Out of bounds" | Some x -> Ok x) + (encoding ty) + [@@inline always] + +let of_value ( < ) ( > ) ~min_value ~max_value x = + if x < min_value then None else if x > max_value then None else Some x + [@@inline always] + +(* We introduce one functor by OCaml datatype so that comparison + functions are statically known and consequently inlined. Using the + GADT, we could generalise this, but OCaml (without flambda) is + unable to make the correct optimisations to inline the comparison + functions. All the business code has been factored out so only the + declaration is duplicated. *) +module Int64 (B : BOUNDS with type ocaml_type := int64) = struct + include Compare.Int64 + include B + + let to_value = Fun.id + + let of_value = of_value ( < ) ( > ) ~min_value ~max_value + + let encoding = guarded_encoding Int64 ~to_value ~of_value + + let pp = pp Int64 + + let () = checks Int64 ( < ) ( > ) ~min_value ~max_value +end + +module Int32 (B : BOUNDS with type ocaml_type := int32) = struct + include Compare.Int32 + include B + + let to_value = Fun.id + + let of_value = of_value ( < ) ( > ) ~min_value ~max_value + + let encoding = guarded_encoding Int32 ~to_value ~of_value + + let pp = pp Int32 + + let () = checks Int32 ( < ) ( > ) ~min_value ~max_value +end + +(* A specifialisation of the functor above where the interval is + restricted to the non negative integer that can be represented on + 4 bytes. *) +module Non_negative_int32 = Int32 (struct + let min_value = 0l + + let max_value = Stdlib.Int32.max_int +end) + +(* The parameter [T] of this functor allows to choose the desired + encoding without duplicating the interface. *) +module Make31 (T : sig + val ty : int ty +end) +(B : BOUNDS with type ocaml_type := int) = +struct + include Compare.Int + include B + + let to_value = Fun.id + + let of_value = of_value ( < ) ( > ) ~min_value ~max_value + + let encoding = guarded_encoding T.ty ~to_value ~of_value + + let pp = pp T.ty + + let () = checks T.ty ( < ) ( > ) ~min_value ~max_value +end + +module Int31 = Make31 (struct + let ty = Int31 +end) + +module Int16 = Make31 (struct + let ty = Int16 +end) + +module Uint16 = Make31 (struct + let ty = Uint16 +end) + +module Int8 = Make31 (struct + let ty = Int8 +end) + +module Uint8 = Make31 (struct + let ty = Uint8 +end) + +module Internal_for_tests = struct + type 'ocaml t = 'ocaml ty = + | Int64 : int64 t + | Int32 : int32 t + | Int31 : int t + | Int16 : int t + | Uint16 : int t + | Int8 : int t + | Uint8 : int t + + let min_value = ty_min_value - let encoding = - Data_encoding.( - conv_with_guard - to_int32 - (fun x -> - match of_int32 x with - | None -> Error "Out of bounds" - | Some x -> Ok x) - int32) - end + let max_value = ty_max_value - module NonNegative = Make (struct - let min_int = 0l + let compare = compare - let max_int = Int32.max_int - end) + let pp_ty = pp_ty end diff --git a/src/lib_base/bounded.mli b/src/lib_base/bounded.mli index 58b341f6f49acd12b156df8c797b7aa44bd30aec..b71777739ec9d8db77df0bb3ea9cd181433c0d92 100644 --- a/src/lib_base/bounded.mli +++ b/src/lib_base/bounded.mli @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2022 Trili Tech, *) +(* Copyright (c) 2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -25,48 +26,139 @@ (** This module implements bounded (or refined) versions of data types. *) -(** Bounded [int32]. *) -module Int32 : sig - (** Bounds. +(** Bounds. - Formally each [B : BOUND] represents the interval of all integers - between [B.min_int] and [B.max_int]. This is a closed interval, e.g. - the endpoints are included. + Formally each [B : BOUND] represents the interval of all values + between [B.min_value] and [B.max_value]. This is a closed interval, + i.e. the endpoints are included. - Intervals can be empty, for example [struct let min_int = 1; let max_int - 0 end] is empty. - *) - module type BOUNDS = sig - val min_int : int32 + Intervals can be empty, for example [struct let min_value = 1; let + max_value 0 end] is empty. *) +module type BOUNDS = sig + (** [ocaml_type] is the type used for the internal representation of + values within the bounded interval. This is the type that values + in the interval are converted to and from. E.g., for an interval + of 32-bit integers [ocaml_type = int32]. *) + type ocaml_type + + (** [min_value] represents the minimal value (included) reprensatable. *) + val min_value : ocaml_type + + (** [max_value] represents the maximal value (included) + reprensatable. *) + val max_value : ocaml_type +end + +(** Signature for an interval of (included values) with an encoding + and projection functions towards the underlying ocaml datatype. *) +module type S = sig + (** Internal representation of a bounded value. *) + type t - val max_int : int32 - end + (** Underlying OCaml representation for the bounded value. *) + type ocaml_type - module type S = sig - type t + include BOUNDS with type ocaml_type := ocaml_type - include BOUNDS + include Compare.S with type t := t - include Compare.S with type t := t + (** A (partial) encoding of the datatype. If the encoded value is + out of bounds, an exception may be raised. See + {!val:Data_encoding.conv_with_guard}. *) + val encoding : t Data_encoding.t - val encoding : t Data_encoding.t + (** A pretty-printer for values of type [t]. *) + val pp : Format.formatter -> t -> unit - val to_int32 : t -> int32 + (** [to_value t] is a projection to the OCaml representation of the + bounded value [t]. *) + val to_value : t -> ocaml_type - val of_int32 : int32 -> t option - end + (** [of_value ocaml_value] represents [ocaml_value] as a bounded + value. Returns [None] if the value is outside of the bounds + specified by {!val:min_value} and {!val:max_value}. *) + val of_value : ocaml_type -> t option +end - (** Produce a module [_ : S] of bounded integers. +(** Allows to build interval of int64 integers. The encoding used is + {!val:Data_encoding.int64} regardless of the actual bounds. *) +module Int64 (B : BOUNDS with type ocaml_type := int64) : + S with type ocaml_type := int64 - If the given interval is empty, [S.t] is the empty type, and [of_int32] - returns [Error] for all inputs. +(** Allows to build interval of int32 integers. The encoding used is + {!val:Data_encoding.int32} regardless of the actual bounds. *) +module Int32 (B : BOUNDS with type ocaml_type := int32) : + S with type ocaml_type := int32 - {4 Encoding} - [(Make B).encoding] is based on the underlying [int32] encoding. This - allow future compatiblity with larger bounds, at the price of addding 1-3 - redundant bytes to each message. +(** Allows to build interval of non negative int32 integers. The + encoding used is {!val:Data_encoding.int32} regardless of the + actual bounds. *) +module Non_negative_int32 : S with type ocaml_type := int32 + +(** Allows to build interval of built-in OCaml int integers. The + encoding used is {!val:Data_encoding.int31} regardless of the + actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 4 bytes (depends on whether [int] is represented + on 4 bytes or 8 bytes which depends on the machine architecture).. *) - module Make (_ : BOUNDS) : S +module Int31 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of int integers representable on 2 + bytes. The encoding used is {!val:Data_encoding.int16} regardless + of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 2 bytes. *) +module Int16 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 2 bytes. The encoding used is + {!val:Data_encoding.uint16} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 2 bytes. *) +module Uint16 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 1 bytes. The encoding used is + {!val:Data_encoding.int8} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 1 bytes. *) +module Int8 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 1 bytes. The encoding used is + {!val:Data_encoding.uint8} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 1 bytes. *) +module Uint8 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(**/**) + +module Internal_for_tests : sig + type 'ocaml t = + | Int64 : int64 t + | Int32 : int32 t + | Int31 : int t + | Int16 : int t + | Uint16 : int t + | Int8 : int t + | Uint8 : int t + + val min_value : 'a. 'a t -> 'a + + val max_value : 'a. 'a t -> 'a + + val compare : 'a. 'a t -> (module Compare.S with type t = 'a) - module NonNegative : S + val pp_ty : Format.formatter -> 'ocaml t -> unit end diff --git a/src/lib_base/test/test_bounded.ml b/src/lib_base/test/test_bounded.ml index 5619a9e37976f8b1ab251bdb13439afa6ac871d7..8f66ddb74c4de9751286d16317020b3d05c3e06f 100644 --- a/src/lib_base/test/test_bounded.ml +++ b/src/lib_base/test/test_bounded.ml @@ -30,96 +30,391 @@ Subject: Test the [Bounded] module. *) -module Make_test_bounded_int32 (B : Bounded.Int32.BOUNDS) = struct - include Bounded.Int32.Make (B) +module Helpers : sig + (** Generators of non-empty bounded intervals. *) - let gen : t QCheck2.Gen.t = + module type S = sig + (** The signature is extended with a generator and helpers for debugging tests. *) + include Bounded.S + + val t : ocaml_type Bounded.Internal_for_tests.t + + val pp_ocaml_type : Format.formatter -> ocaml_type -> unit + + (** [gen] generates values [v] such that [S.min_value <= v <= S.max_value]. *) + val gen : ocaml_type QCheck2.Gen.t + end + + (** A value represent a bounded interval with an element in it. *) + type value = + | E' : { + bounded : (module S with type ocaml_type = 'a); + element : 'a; + } + -> value + + (** [print] can be used for debugging *) + val print : value -> string + + (** A generator for [value] elements. *) + val gen : value QCheck2.Gen.t +end = struct + module type PARAMETERS = sig + type t + + val rem : t -> t -> t + + val add : t -> t -> t + + val max : t -> t -> t + + val sub : t -> t -> t + + val abs : t -> t + + val one : t + end + + module type S = sig + include Bounded.S + + val t : ocaml_type Bounded.Internal_for_tests.t + + val pp_ocaml_type : Format.formatter -> ocaml_type -> unit + + val gen : ocaml_type QCheck2.Gen.t + end + + (* The complexity of this function comes from a limitation of QCheck + to provide ranged generators for datatypes such as int64, + int32... and could be useful if the module Bounded is exported with + other data types. *) + let bounded_gen (type ty) + (module B : Bounded.BOUNDS with type ocaml_type = ty) + (module Parameters : PARAMETERS with type t = ty) basic_generator = + let open Parameters in + let open QCheck2.Gen in + let* n = basic_generator in + let size = max one (add (sub B.max_value B.min_value) one) in + (* We use [abs] to ensure the value returned by [rem] is + positive. The value [unsigned_rem] does not exist for module + [Int]. *) + return (add B.min_value (rem (abs n) size)) + + (* This function is horrendously verbose because of the use of first + class modules. There might be a way to rewrite this function in a + less verbose manner. The purpose of this function is given a + specification like [Uint16], to compute a generator for a bounded + interval. + + The function is completely parametric so that it should be "easy" + to extend. Easy meaning following the OCaml type checker. *) + let gen_from_ty (type ty) : + ty Bounded.Internal_for_tests.t -> (module S) QCheck2.Gen.t = + let open QCheck2.Gen in + fun (type a) (ty : a Bounded.Internal_for_tests.t) -> + let (module Compare : Tezos_stdlib.Compare.S with type t = a) = + Bounded.Internal_for_tests.compare ty + in + let min_value = Bounded.Internal_for_tests.min_value ty in + let max_value = Bounded.Internal_for_tests.max_value ty in + let gen : a t = + match ty with + | Int64 -> int64 + | Int32 -> int32 + | Int31 -> int_range min_value max_value + | Int16 -> int_range min_value max_value + | Uint16 -> int_range min_value max_value + | Int8 -> int_range min_value max_value + | Uint8 -> int_range min_value max_value + in + let* a = gen in + let* b = gen in + let min_value, max_value = if Compare.(a < b) then (a, b) else (b, a) in + let bounds : (module Bounded.BOUNDS with type ocaml_type = a) = + (module struct + type ocaml_type = a + + let min_value = min_value + + let max_value = max_value + end) + in + let parameters : (module PARAMETERS with type t = a) = + match ty with + | Int64 -> (module Int64) + | Int32 -> (module Int32) + | Int31 -> (module Int) + | Int16 -> (module Int) + | Uint16 -> (module Int) + | Int8 -> (module Int) + | Uint8 -> (module Int) + in + let bounded_gen = bounded_gen bounds parameters gen in + + let gen : (module S) = + (* Because of the GADT, the code below cannot be factored easily. *) + match (ty : a Bounded.Internal_for_tests.t) with + | Int64 -> + let (module Bounds) = bounds in + (module struct + type ocaml_type = int64 + + include Bounded.Int64 (Bounds) + + let t = Bounded.Internal_for_tests.Int64 + + let pp_ocaml_type fmt v = Format.fprintf fmt "%Ld" v + + let gen = bounded_gen + end) + | Int32 -> + let (module Bounds) = bounds in + (module struct + type ocaml_type = int32 + + include Bounded.Int32 (Bounds) + + let t = Bounded.Internal_for_tests.Int32 + + let pp_ocaml_type fmt v = Format.fprintf fmt "%ld" v + + let gen = bounded_gen + end) + | Int31 -> + let (module Bounds) = bounds in + (module struct + type ocaml_type = int + + include Bounded.Int31 (Bounds) + + let t = Bounded.Internal_for_tests.Int31 + + let pp_ocaml_type fmt v = Format.fprintf fmt "%d" v + + let gen = bounded_gen + end) + | Int16 -> + let (module Bounds) = bounds in + (module struct + type ocaml_type = int + + include Bounded.Int16 (Bounds) + + let t = Bounded.Internal_for_tests.Int16 + + let pp_ocaml_type fmt v = Format.fprintf fmt "%d" v + + let gen = bounded_gen + end) + | Uint16 -> + let (module Bounds) = bounds in + (module struct + type ocaml_type = int + + include Bounded.Uint16 (Bounds) + + let t = Bounded.Internal_for_tests.Uint16 + + let pp_ocaml_type fmt v = Format.fprintf fmt "%d" v + + let gen = bounded_gen + end) + | Int8 -> + let (module Bounds) = bounds in + (module struct + type ocaml_type = int + + include Bounded.Int8 (Bounds) + + let t = Bounded.Internal_for_tests.Int8 + + let pp_ocaml_type fmt v = Format.fprintf fmt "%d" v + + let gen = bounded_gen + end) + | Uint8 -> + let (module Bounds) = bounds in + (module struct + type ocaml_type = int + + include Bounded.Uint8 (Bounds) + + let t = Bounded.Internal_for_tests.Uint8 + + let pp_ocaml_type fmt v = Format.fprintf fmt "%d" v + + let gen = bounded_gen + end) + in + return gen + + type ty = E : _ Bounded.Internal_for_tests.t -> ty + + type value = + | E' : { + bounded : (module S with type ocaml_type = 'a); + element : 'a; + } + -> value + + let gen : value QCheck2.Gen.t = + let open Bounded.Internal_for_tests in let open QCheck2.Gen in - let* n = QCheck2.Gen.int32 in - let size = - Tezos_stdlib.Compare.Int32.max - 1l - (Int32.add (Int32.sub max_int min_int) 1l) + let values = + [E Int64; E Int32; E Int31; E Int16; E Uint16; E Int8; E Uint8] in - let in_bounds = Int32.add min_int (Int32.unsigned_rem n size) in - match of_int32 in_bounds with - | None -> failwith "Out of bounds" - | Some x -> return x - - let print (x : t) : string = Int32.to_string (to_int32 x) - - let roundtrips_json : QCheck2.Test.t = - QCheck2.Test.make - ~name:"Bounded.Int32 roundtrips in JSON" - ~print - gen - (fun t -> - let b = Data_encoding.Json.construct encoding t in - let tt = Data_encoding.Json.destruct encoding b in - t = tt) - - let roundtrips_binary : QCheck2.Test.t = - QCheck2.Test.make - ~name:"Bounded.Int32 roundtrips in binary" - ~print - gen - (fun t -> - let b = Data_encoding.Binary.to_bytes_exn encoding t in - let tt = Data_encoding.Binary.of_bytes_exn encoding b in - t = tt) - - let tests = [roundtrips_binary; roundtrips_json] + let* ety = oneofl values in + match ety with + | E (type a) (ty : a Bounded.Internal_for_tests.t) -> + let* (module S : S) = gen_from_ty ty in + let* element = S.gen in + return (E' {bounded = (module S); element}) + + let print (E' {bounded = (module S); element}) = + Format.asprintf + "type(%a) min: %a, max: %a, element: %a" + Bounded.Internal_for_tests.pp_ty + S.t + S.pp_ocaml_type + S.min_value + S.pp_ocaml_type + S.max_value + S.pp_ocaml_type + element end -module Empty = Make_test_bounded_int32 (struct - let min_int = 1l +open Helpers + +let roundtrips_json : QCheck2.Test.t = + QCheck2.Test.make + ~name:"Bounded: roundtrips in JSON" + ~print + gen + (fun (E' {bounded = (module S); element}) -> + match S.of_value element with + | None -> false + | Some x -> + let b = Data_encoding.Json.construct S.encoding x in + let tt = Data_encoding.Json.destruct S.encoding b in + x = tt) + +let roundtrips_binary : QCheck2.Test.t = + QCheck2.Test.make + ~name:"Bounded: roundtrips in binary" + ~print + gen + (fun (E' {bounded = (module S); element}) -> + match S.of_value element with + | None -> false + | Some x -> + let b = Data_encoding.Binary.to_bytes_exn S.encoding x in + let tt = Data_encoding.Binary.of_bytes_exn S.encoding b in + x = tt) - let max_int = 0l +let tests = [roundtrips_json; roundtrips_binary] + +module Empty = Bounded.Int32 (struct + let min_value = 1l + + let max_value = 0l end) -module Small = Make_test_bounded_int32 (struct - let min_int = 1l +module Small = Bounded.Int32 (struct + let min_value = 1l - let max_int = 3l + let max_value = 3l end) -module Small_with_neg = Make_test_bounded_int32 (struct - let min_int = -10l +module Small_with_neg = Bounded.Int32 (struct + let min_value = -10l - let max_int = 10l + let max_value = 10l end) -module Full = Make_test_bounded_int32 (Int32) +module Full = Bounded.Int32 (struct + let min_value = Stdlib.Int32.min_int + + let max_value = Stdlib.Int32.max_int +end) + +module Uint16 = Bounded.Uint16 (struct + let min_value = 0 + + let max_value = 32767 +end) let int32_checks = let open Alcotest in [ test_case "0 not in empty" `Quick (fun () -> - assert (Empty.of_int32 0l = None)); + assert (Empty.of_value 0l = None)); test_case "123 not in empty" `Quick (fun () -> - assert (Empty.of_int32 123l = None)); + assert (Empty.of_value 123l = None)); test_case "Int32.min_int not in empty" `Quick (fun () -> - assert (Empty.of_int32 Int32.min_int = None)); + assert (Empty.of_value Int32.min_int = None)); test_case "0 not in Small" `Quick (fun () -> - assert (Small.of_int32 0l = None)); + assert (Small.of_value 0l = None)); test_case "1 in Small" `Quick (fun () -> - assert (Option.map Small.to_int32 (Small.of_int32 1l) = Some 1l)); + assert (Option.map Small.to_value (Small.of_value 1l) = Some 1l)); test_case "2 in Small" `Quick (fun () -> - assert (Option.map Small.to_int32 (Small.of_int32 2l) = Some 2l)); + assert (Option.map Small.to_value (Small.of_value 2l) = Some 2l)); test_case "4 not in Small" `Quick (fun () -> - assert (Small.of_int32 4l = None)); + assert (Small.of_value 4l = None)); test_case "0 in full" `Quick (fun () -> - assert (Option.map Full.to_int32 (Full.of_int32 0l) = Some 0l)); + assert (Option.map Full.to_value (Full.of_value 0l) = Some 0l)); test_case "123 in full" `Quick (fun () -> - assert (Option.map Full.to_int32 (Full.of_int32 123l) = Some 123l)); + assert (Option.map Full.to_value (Full.of_value 123l) = Some 123l)); test_case "Int32.min_int in full" `Quick (fun () -> assert ( - Option.map Full.to_int32 (Full.of_int32 Int32.min_int) + Option.map Full.to_value (Full.of_value Int32.min_int) = Some Int32.min_int)); test_case "Int32.max_int in full" `Quick (fun () -> assert ( - Option.map Full.to_int32 (Full.of_int32 Int32.max_int) + Option.map Full.to_value (Full.of_value Int32.max_int) = Some Int32.max_int)); + test_case "Uint8.bad instantiation lower value" `Quick (fun () -> + try + let (_ : (module Bounded.S)) = + (module struct + (* A bit hackish but this is due to a limitation of + OCaml that not accept substitutions in signatures of + first-class modules at the moment. *) + type ocaml_type = int + + include Bounded.Uint8 (struct + let min_value = -1 + + let max_value = 1 + end) + end) + in + assert false + with Invalid_argument _ -> ()); + test_case "Uint8.bad instantiation upper value" `Quick (fun () -> + try + let (_ : (module Bounded.S)) = + (module struct + (* A bit hackish but this is due to a limitation of + OCaml that not accept substitutions in signatures of + first-class modules at the moment. *) + type ocaml_type = int + + include Bounded.Uint8 (struct + let min_value = 0 + + let max_value = 256 + end) + end) + in + assert false + with Invalid_argument _ -> ()); + test_case "Uint16.tight bounds" `Quick (fun () -> + assert ( + Uint16.of_value (-1) = None + && Uint16.of_value 32768 = None + && Uint16.of_value 0 <> None + && Uint16.of_value 32767 <> None)); ] let () = @@ -127,8 +422,5 @@ let () = "Bounded" [ ("Int32", int32_checks); - ("Int32 Small", Lib_test.Qcheck2_helpers.qcheck_wrap Small.tests); - ( "Int32 Small_with_neg", - Lib_test.Qcheck2_helpers.qcheck_wrap Small_with_neg.tests ); - ("Int32 Full", Lib_test.Qcheck2_helpers.qcheck_wrap Full.tests); + ("Round-trip property", Lib_test.Qcheck2_helpers.qcheck_wrap tests); ] diff --git a/src/lib_protocol_environment/environment_V5.ml b/src/lib_protocol_environment/environment_V5.ml index 3e983339a3346d25af951155b1cbdfe30984ba12..f412112ca93f8eae94798491cdab1355004e58c1 100644 --- a/src/lib_protocol_environment/environment_V5.ml +++ b/src/lib_protocol_environment/environment_V5.ml @@ -760,7 +760,7 @@ struct module Fitness = Fitness module Operation = Operation module Block_header = Block_header - module Bounded = Bounded + module Bounded = Tezos_protocol_environment_structs.V5.Bounded module Protocol = Protocol module RPC_arg = RPC_arg module RPC_path = RPC_path diff --git a/src/lib_protocol_environment/environment_V6.ml b/src/lib_protocol_environment/environment_V6.ml index 5952bdf1a9dd97de51ab49921c7aac16e38af9a5..271e3d5bcf6316daa40698217c5cb58690176fe5 100644 --- a/src/lib_protocol_environment/environment_V6.ml +++ b/src/lib_protocol_environment/environment_V6.ml @@ -766,7 +766,7 @@ struct module Fitness = Fitness module Operation = Operation module Block_header = Block_header - module Bounded = Bounded + module Bounded = Tezos_protocol_environment_structs.V6.Bounded module Protocol = Protocol module RPC_arg = RPC_arg module RPC_path = RPC_path @@ -1144,14 +1144,30 @@ struct let set_input_step {inbox_level; message_counter} payload (tree : Tree.tree) = + let inbox_level = + Tezos_protocol_environment_structs.V6.Bounded.Int32 + .non_negative_of_legacy_non_negative + inbox_level + in Wasm.set_input_step {inbox_level; message_counter} payload tree let get_output {outbox_level; message_index} (tree : Tree.tree) = + let outbox_level = + Tezos_protocol_environment_structs.V6.Bounded.Int32 + .non_negative_of_legacy_non_negative + outbox_level + in Wasm.get_output {outbox_level; message_index} tree let convert_input : Tezos_scoru_wasm.Wasm_pvm_sig.input_info -> input = function - | {inbox_level; message_counter} -> {inbox_level; message_counter} + | {inbox_level; message_counter} -> + let inbox_level = + Tezos_protocol_environment_structs.V6.Bounded.Int32 + .legacy_non_negative_of_non_negative + inbox_level + in + {inbox_level; message_counter} let get_info (tree : Tree.tree) = let open Lwt_syntax in diff --git a/src/lib_protocol_environment/environment_V7.ml b/src/lib_protocol_environment/environment_V7.ml index 73c0faed87339c3585c516858ccdd03c104e0e8e..beb388e79fe0d0f97d4116aacf86ea5757a436bd 100644 --- a/src/lib_protocol_environment/environment_V7.ml +++ b/src/lib_protocol_environment/environment_V7.ml @@ -1104,12 +1104,12 @@ struct module Wasm_2_0_0 = struct type input = { - inbox_level : Bounded.Int32.NonNegative.t; + inbox_level : Bounded.Non_negative_int32.t; message_counter : Z.t; } type output = { - outbox_level : Bounded.Int32.NonNegative.t; + outbox_level : Bounded.Non_negative_int32.t; message_index : Z.t; } diff --git a/src/lib_protocol_environment/sigs/v7.ml b/src/lib_protocol_environment/sigs/v7.ml index 1c20234e1f6e38e57b748e86fbef60639054bc50..624f75b9a48c4c0423f95b16f080437d956baca7 100644 --- a/src/lib_protocol_environment/sigs/v7.ml +++ b/src/lib_protocol_environment/sigs/v7.ml @@ -10079,6 +10079,7 @@ end (* *) (* Open Source License *) (* Copyright (c) 2022 Trili Tech, *) +(* Copyright (c) 2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -10102,51 +10103,121 @@ end (** This module implements bounded (or refined) versions of data types. *) -(** Bounded [int32]. *) -module Int32 : sig - (** Bounds. +(** Bounds. - Formally each [B : BOUND] represents the interval of all integers - between [B.min_int] and [B.max_int]. This is a closed interval, e.g. - the endpoints are included. + Formally each [B : BOUND] represents the interval of all values + between [B.min_value] and [B.max_value]. This is a closed interval, + i.e. the endpoints are included. - Intervals can be empty, for example [struct let min_int = 1; let max_int - 0 end] is empty. - *) - module type BOUNDS = sig - val min_int : int32 + Intervals can be empty, for example [struct let min_value = 1; let + max_value 0 end] is empty. *) +module type BOUNDS = sig + (** [ocaml_type] is the type used for the internal representation of + values within the bounded interval. This is the type that values + in the interval are converted to and from. E.g., for an interval + of 32-bit integers [ocaml_type = int32]. *) + type ocaml_type - val max_int : int32 - end + (** [min_value] represents the minimal value (included) reprensatable. *) + val min_value : ocaml_type + + (** [max_value] represents the maximal value (included) + reprensatable. *) + val max_value : ocaml_type +end + +(** Signature for an interval of (included values) with an encoding + and projection functions towards the underlying ocaml datatype. *) +module type S = sig + (** Internal representation of a bounded value. *) + type t - module type S = sig - type t + (** Underlying OCaml representation for the bounded value. *) + type ocaml_type - include BOUNDS + include BOUNDS with type ocaml_type := ocaml_type - include Compare.S with type t := t + include Compare.S with type t := t - val encoding : t Data_encoding.t + (** A (partial) encoding of the datatype. If the encoded value is + out of bounds, an exception may be raised. See + {!val:Data_encoding.conv_with_guard}. *) + val encoding : t Data_encoding.t - val to_int32 : t -> int32 + (** A pretty-printer for values of type [t]. *) + val pp : Format.formatter -> t -> unit - val of_int32 : int32 -> t option - end + (** [to_value t] is a projection to the OCaml representation of the + bounded value [t]. *) + val to_value : t -> ocaml_type - (** Produce a module [_ : S] of bounded integers. + (** [of_value ocaml_value] represents [ocaml_value] as a bounded + value. Returns [None] if the value is outside of the bounds + specified by {!val:min_value} and {!val:max_value}. *) + val of_value : ocaml_type -> t option +end + +(** Allows to build interval of int64 integers. The encoding used is + {!val:Data_encoding.int64} regardless of the actual bounds. *) +module Int64 (B : BOUNDS with type ocaml_type := int64) : + S with type ocaml_type := int64 + +(** Allows to build interval of int32 integers. The encoding used is + {!val:Data_encoding.int32} regardless of the actual bounds. *) +module Int32 (B : BOUNDS with type ocaml_type := int32) : + S with type ocaml_type := int32 - If the given interval is empty, [S.t] is the empty type, and [of_int32] - returns [Error] for all inputs. +(** Allows to build interval of non negative int32 integers. The + encoding used is {!val:Data_encoding.int32} regardless of the + actual bounds. *) +module Non_negative_int32 : S with type ocaml_type := int32 - {4 Encoding} - [(Make B).encoding] is based on the underlying [int32] encoding. This - allow future compatiblity with larger bounds, at the price of addding 1-3 - redundant bytes to each message. +(** Allows to build interval of built-in OCaml int integers. The + encoding used is {!val:Data_encoding.int31} regardless of the + actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 4 bytes (depends on whether [int] is represented + on 4 bytes or 8 bytes which depends on the machine architecture).. *) - module Make (_ : BOUNDS) : S +module Int31 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int - module NonNegative : S -end +(** Allows to build interval of int integers representable on 2 + bytes. The encoding used is {!val:Data_encoding.int16} regardless + of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 2 bytes. *) +module Int16 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 2 bytes. The encoding used is + {!val:Data_encoding.uint16} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 2 bytes. *) +module Uint16 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 1 bytes. The encoding used is + {!val:Data_encoding.int8} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 1 bytes. *) +module Int8 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 1 bytes. The encoding used is + {!val:Data_encoding.uint8} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 1 bytes. *) +module Uint8 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int end # 122 "v7.in.ml" @@ -11353,9 +11424,9 @@ end (* *) (*****************************************************************************) -type input = {inbox_level : Bounded.Int32.NonNegative.t; message_counter : Z.t} +type input = {inbox_level : Bounded.Non_negative_int32.t; message_counter : Z.t} -type output = {outbox_level : Bounded.Int32.NonNegative.t; message_index : Z.t} +type output = {outbox_level : Bounded.Non_negative_int32.t; message_index : Z.t} type input_request = No_input_required | Input_required diff --git a/src/lib_protocol_environment/sigs/v7/bounded.mli b/src/lib_protocol_environment/sigs/v7/bounded.mli index 58b341f6f49acd12b156df8c797b7aa44bd30aec..000b2f9ac9c1cc6f3faee38e07beefde67debc1c 100644 --- a/src/lib_protocol_environment/sigs/v7/bounded.mli +++ b/src/lib_protocol_environment/sigs/v7/bounded.mli @@ -2,6 +2,7 @@ (* *) (* Open Source License *) (* Copyright (c) 2022 Trili Tech, *) +(* Copyright (c) 2022 Nomadic Labs, *) (* *) (* Permission is hereby granted, free of charge, to any person obtaining a *) (* copy of this software and associated documentation files (the "Software"),*) @@ -25,48 +26,118 @@ (** This module implements bounded (or refined) versions of data types. *) -(** Bounded [int32]. *) -module Int32 : sig - (** Bounds. +(** Bounds. - Formally each [B : BOUND] represents the interval of all integers - between [B.min_int] and [B.max_int]. This is a closed interval, e.g. - the endpoints are included. + Formally each [B : BOUND] represents the interval of all values + between [B.min_value] and [B.max_value]. This is a closed interval, + i.e. the endpoints are included. - Intervals can be empty, for example [struct let min_int = 1; let max_int - 0 end] is empty. - *) - module type BOUNDS = sig - val min_int : int32 + Intervals can be empty, for example [struct let min_value = 1; let + max_value 0 end] is empty. *) +module type BOUNDS = sig + (** [ocaml_type] is the type used for the internal representation of + values within the bounded interval. This is the type that values + in the interval are converted to and from. E.g., for an interval + of 32-bit integers [ocaml_type = int32]. *) + type ocaml_type + + (** [min_value] represents the minimal value (included) reprensatable. *) + val min_value : ocaml_type + + (** [max_value] represents the maximal value (included) + reprensatable. *) + val max_value : ocaml_type +end - val max_int : int32 - end +(** Signature for an interval of (included values) with an encoding + and projection functions towards the underlying ocaml datatype. *) +module type S = sig + (** Internal representation of a bounded value. *) + type t - module type S = sig - type t + (** Underlying OCaml representation for the bounded value. *) + type ocaml_type - include BOUNDS + include BOUNDS with type ocaml_type := ocaml_type - include Compare.S with type t := t + include Compare.S with type t := t - val encoding : t Data_encoding.t + (** A (partial) encoding of the datatype. If the encoded value is + out of bounds, an exception may be raised. See + {!val:Data_encoding.conv_with_guard}. *) + val encoding : t Data_encoding.t + + (** A pretty-printer for values of type [t]. *) + val pp : Format.formatter -> t -> unit + + (** [to_value t] is a projection to the OCaml representation of the + bounded value [t]. *) + val to_value : t -> ocaml_type + + (** [of_value ocaml_value] represents [ocaml_value] as a bounded + value. Returns [None] if the value is outside of the bounds + specified by {!val:min_value} and {!val:max_value}. *) + val of_value : ocaml_type -> t option +end - val to_int32 : t -> int32 +(** Allows to build interval of int64 integers. The encoding used is + {!val:Data_encoding.int64} regardless of the actual bounds. *) +module Int64 (B : BOUNDS with type ocaml_type := int64) : + S with type ocaml_type := int64 - val of_int32 : int32 -> t option - end +(** Allows to build interval of int32 integers. The encoding used is + {!val:Data_encoding.int32} regardless of the actual bounds. *) +module Int32 (B : BOUNDS with type ocaml_type := int32) : + S with type ocaml_type := int32 - (** Produce a module [_ : S] of bounded integers. +(** Allows to build interval of non negative int32 integers. The + encoding used is {!val:Data_encoding.int32} regardless of the + actual bounds. *) +module Non_negative_int32 : S with type ocaml_type := int32 - If the given interval is empty, [S.t] is the empty type, and [of_int32] - returns [Error] for all inputs. +(** Allows to build interval of built-in OCaml int integers. The + encoding used is {!val:Data_encoding.int31} regardless of the + actual bounds. - {4 Encoding} - [(Make B).encoding] is based on the underlying [int32] encoding. This - allow future compatiblity with larger bounds, at the price of addding 1-3 - redundant bytes to each message. + @raise Invalid_argument if the bounds provided cannot be + representable on 4 bytes (depends on whether [int] is represented + on 4 bytes or 8 bytes which depends on the machine architecture).. *) - module Make (_ : BOUNDS) : S +module Int31 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int - module NonNegative : S -end +(** Allows to build interval of int integers representable on 2 + bytes. The encoding used is {!val:Data_encoding.int16} regardless + of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 2 bytes. *) +module Int16 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 2 bytes. The encoding used is + {!val:Data_encoding.uint16} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 2 bytes. *) +module Uint16 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 1 bytes. The encoding used is + {!val:Data_encoding.int8} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 1 bytes. *) +module Int8 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int + +(** Allows to build interval of non-negative int integers + representable on 1 bytes. The encoding used is + {!val:Data_encoding.uint8} regardless of the actual bounds. + + @raise Invalid_argument if the bounds provided cannot be + representable on 1 bytes. *) +module Uint8 (B : BOUNDS with type ocaml_type := int) : + S with type ocaml_type := int diff --git a/src/lib_protocol_environment/sigs/v7/wasm_2_0_0.mli b/src/lib_protocol_environment/sigs/v7/wasm_2_0_0.mli index 3d9b45fea9c5c8999c4003832c04ef3fa577a67b..aa17a2bb4f6aeea7041b418976998410b624f2d8 100644 --- a/src/lib_protocol_environment/sigs/v7/wasm_2_0_0.mli +++ b/src/lib_protocol_environment/sigs/v7/wasm_2_0_0.mli @@ -23,9 +23,9 @@ (* *) (*****************************************************************************) -type input = {inbox_level : Bounded.Int32.NonNegative.t; message_counter : Z.t} +type input = {inbox_level : Bounded.Non_negative_int32.t; message_counter : Z.t} -type output = {outbox_level : Bounded.Int32.NonNegative.t; message_index : Z.t} +type output = {outbox_level : Bounded.Non_negative_int32.t; message_index : Z.t} type input_request = No_input_required | Input_required diff --git a/src/lib_protocol_environment/structs/tezos_protocol_environment_structs.ml b/src/lib_protocol_environment/structs/tezos_protocol_environment_structs.ml index 138de4fb0f900e5088bc6311a18fd9dbd75628b7..e0a31f8e479efb2993ac506adb70e13beec4d0fb 100644 --- a/src/lib_protocol_environment/structs/tezos_protocol_environment_structs.ml +++ b/src/lib_protocol_environment/structs/tezos_protocol_environment_structs.ml @@ -87,11 +87,13 @@ end module V5 = struct module Error_monad_infix_globals = V0_error_monad_infix_globals + module Bounded = V5_bounded end module V6 = struct module Error_monad_infix_globals = V0_error_monad_infix_globals module Plonk = V6_plonk + module Bounded = V5_bounded end module V7 = struct diff --git a/src/lib_protocol_environment/structs/v5_bounded.ml b/src/lib_protocol_environment/structs/v5_bounded.ml new file mode 100644 index 0000000000000000000000000000000000000000..18d77c52b1ee482dac11e87e84d56f8a10529cec --- /dev/null +++ b/src/lib_protocol_environment/structs/v5_bounded.ml @@ -0,0 +1,87 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Trili Tech, *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +module Int32 = struct + module type BOUNDS = sig + val min_int : int32 + + val max_int : int32 + end + + module type S = sig + type t + + include BOUNDS + + include Tezos_base.TzPervasives.Compare.S with type t := t + + val encoding : t Data_encoding.t + + val to_int32 : t -> int32 + + val of_int32 : int32 -> t option + end + + module Make (B : BOUNDS) = struct + include Tezos_base.TzPervasives.Compare.Int32 + (* This includes [type t = int32] *) + + include B + + let to_int32 x = x + + let of_int32 n = + if Tezos_base.TzPervasives.Compare.Int32.(n < B.min_int) then None + else if Tezos_base.TzPervasives.Compare.Int32.(n > B.max_int) then None + else Some n + + let encoding = + Data_encoding.( + conv_with_guard + to_int32 + (fun x -> + match of_int32 x with + | None -> Error "Out of bounds" + | Some x -> Ok x) + int32) + end + + module NonNegative = struct + include Tezos_base.Bounded.Non_negative_int32 + + let to_int32 = to_value + + let of_int32 = of_value + + let min_int = min_value + + let max_int = max_value + end + + let non_negative_of_legacy_non_negative = Fun.id + + let legacy_non_negative_of_non_negative = Fun.id +end diff --git a/src/lib_protocol_environment/structs/v5_bounded.mli b/src/lib_protocol_environment/structs/v5_bounded.mli new file mode 100644 index 0000000000000000000000000000000000000000..c407e8ea11175d860d5cab5d27014339226776cb --- /dev/null +++ b/src/lib_protocol_environment/structs/v5_bounded.mli @@ -0,0 +1,79 @@ +(*****************************************************************************) +(* *) +(* Open Source License *) +(* Copyright (c) 2022 Trili Tech, *) +(* Copyright (c) 2022 Nomadic Labs, *) +(* *) +(* 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. *) +(* *) +(*****************************************************************************) + +(** This module implements bounded (or refined) versions of data types. *) + +(** Bounded [int32]. *) +module Int32 : sig + (** Bounds. + + Formally each [B : BOUND] represents the interval of all integers + between [B.min_int] and [B.max_int]. This is a closed interval, e.g. + the endpoints are included. + + Intervals can be empty, for example [struct let min_int = 1; let max_int + 0 end] is empty. + *) + module type BOUNDS = sig + val min_int : int32 + + val max_int : int32 + end + + module type S = sig + type t + + include BOUNDS + + include Tezos_base.TzPervasives.Compare.S with type t := t + + val encoding : t Data_encoding.t + + val to_int32 : t -> int32 + + val of_int32 : int32 -> t option + end + + (** Produce a module [_ : S] of bounded integers. + + If the given interval is empty, [S.t] is the empty type, and [of_int32] + returns [Error] for all inputs. + + {4 Encoding} + [(Make B).encoding] is based on the underlying [int32] encoding. This + allow future compatiblity with larger bounds, at the price of addding 1-3 + redundant bytes to each message. + *) + module Make (_ : BOUNDS) : S + + module NonNegative : S + + val non_negative_of_legacy_non_negative : + NonNegative.t -> Tezos_base.Bounded.Non_negative_int32.t + + val legacy_non_negative_of_non_negative : + Tezos_base.Bounded.Non_negative_int32.t -> NonNegative.t +end diff --git a/src/lib_scoru_wasm/test/test_input.ml b/src/lib_scoru_wasm/test/test_input.ml index 375f1fd5f9517879450642cd7eeda03007b81cbf..c5e3ea8d00ed29dfc0e012adf2d1c8e48665d25e 100644 --- a/src/lib_scoru_wasm/test/test_input.ml +++ b/src/lib_scoru_wasm/test/test_input.ml @@ -234,7 +234,9 @@ let floppy_encoding = let inp_encoding = Tree_encoding.value ["input"; "0"; "1"] Data_encoding.string let zero = - WithExceptions.Option.get ~loc:__LOC__ (Bounded.Int32.NonNegative.of_int32 0l) + WithExceptions.Option.get + ~loc:__LOC__ + (Bounded.Non_negative_int32.of_value 0l) (** Artificial initialization. Under normal circumstances the changes in [current_tick], [gather_floppies] and [status] will be done by the other @@ -276,7 +278,7 @@ let make_inbox_level ~inbox_level ~message_counter = inbox_level = WithExceptions.Option.get ~loc:__LOC__ - (Bounded.Int32.NonNegative.of_int32 (Int32.of_int inbox_level)); + (Bounded.Non_negative_int32.of_value (Int32.of_int inbox_level)); message_counter = Z.of_int message_counter; } diff --git a/src/lib_scoru_wasm/wasm_pvm.ml b/src/lib_scoru_wasm/wasm_pvm.ml index 68d29099cb617be4e20561ddeaa47422a3f73b5c..51516688188e956af2275fc3711cb3c11b746727 100644 --- a/src/lib_scoru_wasm/wasm_pvm.ml +++ b/src/lib_scoru_wasm/wasm_pvm.ml @@ -264,7 +264,7 @@ module Make (T : Tree_encoding.Runner.TREE) : let open Lwt_syntax in let open Wasm_pvm_sig in let {inbox_level; message_counter} = input_info in - let raw_level = Bounded.Int32.NonNegative.to_int32 inbox_level in + let raw_level = Bounded.Non_negative_int32.to_value inbox_level in let level = Int32.to_string raw_level in let id = Z.to_string message_counter in let* pvm_state = Tree_encoding_runner.decode pvm_state_encoding tree in diff --git a/src/lib_scoru_wasm/wasm_pvm_sig.ml b/src/lib_scoru_wasm/wasm_pvm_sig.ml index 43cf63465df26b2538716aaeb39acab8e512f3cb..336a9af2b3155da4b035ffbfdbfd381c6724af92 100644 --- a/src/lib_scoru_wasm/wasm_pvm_sig.ml +++ b/src/lib_scoru_wasm/wasm_pvm_sig.ml @@ -25,14 +25,14 @@ (** Represents the location of an input message. *) type input_info = { - inbox_level : Tezos_base.Bounded.Int32.NonNegative.t; + inbox_level : Tezos_base.Bounded.Non_negative_int32.t; (** The inbox level at which the message exists.*) message_counter : Z.t; (** The index of the message in the inbox. *) } (** Represents the location of an output message. *) type output_info = { - outbox_level : Tezos_base.Bounded.Int32.NonNegative.t; + outbox_level : Tezos_base.Bounded.Non_negative_int32.t; (** The outbox level at which the message exists.*) message_index : Z.t; (** The index of the message in the outbox. *) } @@ -87,5 +87,5 @@ let input_info_encoding = (fun {inbox_level; message_counter} -> (inbox_level, message_counter)) (fun (inbox_level, message_counter) -> {inbox_level; message_counter}) (obj2 - (req "inbox_level" Tezos_base.Bounded.Int32.NonNegative.encoding) + (req "inbox_level" Tezos_base.Bounded.Non_negative_int32.encoding) (req "message_counter" n)) diff --git a/src/proto_alpha/bin_sc_rollup_node/commitment.ml b/src/proto_alpha/bin_sc_rollup_node/commitment.ml index b198d1138fe00cad9c137fec52d64078f088ce58..bb61b46a1a17e04ac5f5b0bf5e543eb2f0a20a68 100644 --- a/src/proto_alpha/bin_sc_rollup_node/commitment.ml +++ b/src/proto_alpha/bin_sc_rollup_node/commitment.ml @@ -184,7 +184,7 @@ module Make (PVM : Pvm.S) : Commitment_sig.S with module PVM = PVM = struct let*! number_of_ticks = Number_of_ticks.get store inbox_level in let+ number_of_ticks = match - Sc_rollup.Number_of_ticks.of_int32 @@ Z.to_int32 number_of_ticks + Sc_rollup.Number_of_ticks.of_value @@ Z.to_int32 number_of_ticks with | Some number_of_ticks -> return number_of_ticks | None -> diff --git a/src/proto_alpha/lib_client/client_proto_args.ml b/src/proto_alpha/lib_client/client_proto_args.ml index 1915b09fee683778355617773a945c852fc64c5c..9595dff61e1bcbaf2465e52c6d7843fb72bbfe13 100644 --- a/src/proto_alpha/lib_client/client_proto_args.ml +++ b/src/proto_alpha/lib_client/client_proto_args.ml @@ -966,14 +966,14 @@ module Sc_rollup_params = struct Clic.parameter (fun _ nb_of_ticks -> match Int32.of_string_opt nb_of_ticks with | Some nb_of_ticks -> ( - match Sc_rollup.Number_of_ticks.of_int32 nb_of_ticks with + match Sc_rollup.Number_of_ticks.of_value nb_of_ticks with | None -> failwith "Parameter '%ld' is out of bounds, it should be between %ld \ and %ld" nb_of_ticks - Sc_rollup.Number_of_ticks.min_int - Sc_rollup.Number_of_ticks.max_int + Sc_rollup.Number_of_ticks.min_value + Sc_rollup.Number_of_ticks.max_value | Some nb_of_ticks -> return nb_of_ticks) | None -> failwith "'%s' is not valid, should be a int32 value" nb_of_ticks) diff --git a/src/proto_alpha/lib_protocol/alpha_context.mli b/src/proto_alpha/lib_protocol/alpha_context.mli index d7dfee4067b75127297a01f725d872c3462cc64c..2e856ff1520607f69ab35fa03e6fcd05e22c3bbb 100644 --- a/src/proto_alpha/lib_protocol/alpha_context.mli +++ b/src/proto_alpha/lib_protocol/alpha_context.mli @@ -3259,7 +3259,7 @@ module Sc_rollup : sig end module Number_of_ticks : sig - include Bounded.Int32.S + include module type of Bounded.Non_negative_int32 val zero : t end diff --git a/src/proto_alpha/lib_protocol/raw_level_repr.ml b/src/proto_alpha/lib_protocol/raw_level_repr.ml index 7cbc3fa42445d0b1a03bffd0c4960822052531b8..bb30979dad49625e7872a475c983f0c87fa90d91 100644 --- a/src/proto_alpha/lib_protocol/raw_level_repr.ml +++ b/src/proto_alpha/lib_protocol/raw_level_repr.ml @@ -65,7 +65,7 @@ let diff = Int32.sub let to_int32 l = l let to_int32_non_negative l = - match Bounded.Int32.NonNegative.of_int32 l with + match Bounded.Non_negative_int32.of_value l with | Some x -> x | _ -> assert false (* invariant: raw_levels are non-negative *) @@ -95,7 +95,7 @@ let of_int32_exn l = | Error _ -> invalid_arg "Level_repr.of_int32" let of_int32_non_negative l = - match of_int32 (Bounded.Int32.NonNegative.to_int32 l) with + match of_int32 (Bounded.Non_negative_int32.to_value l) with | Ok l -> l | Error _ -> assert false (* invariant: raw_levels are non-negative *) diff --git a/src/proto_alpha/lib_protocol/raw_level_repr.mli b/src/proto_alpha/lib_protocol/raw_level_repr.mli index 2efca396ef539f59aba550968c3e195151cb7b3d..2a0f5bf695b785632301f5d7eddcdf9d3debbe65 100644 --- a/src/proto_alpha/lib_protocol/raw_level_repr.mli +++ b/src/proto_alpha/lib_protocol/raw_level_repr.mli @@ -43,7 +43,7 @@ include Compare.S with type t := raw_level val to_int32 : raw_level -> int32 -val to_int32_non_negative : raw_level -> Bounded.Int32.NonNegative.t +val to_int32_non_negative : raw_level -> Bounded.Non_negative_int32.t (** @raise Invalid_argument when the level to encode is negative *) val of_int32_exn : int32 -> raw_level @@ -51,7 +51,7 @@ val of_int32_exn : int32 -> raw_level (** Can trigger Unexpected_level error when the level to encode is negative *) val of_int32 : int32 -> raw_level tzresult -val of_int32_non_negative : Bounded.Int32.NonNegative.t -> raw_level +val of_int32_non_negative : Bounded.Non_negative_int32.t -> raw_level val diff : raw_level -> raw_level -> int32 diff --git a/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.ml index f6c4393837304b8212c974f8ce08b7794e67b13c..9e61bf73fb0595a1a4fb14ddaaad9a08acbcfbec 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_commitment_repr.ml @@ -76,7 +76,7 @@ module V1 = struct inbox_level Hash.pp predecessor - (Number_of_ticks.to_int32 number_of_ticks) + (Number_of_ticks.to_value number_of_ticks) let encoding = let open Data_encoding in diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml index 01c1d9d6d9bd2d18e59ca02751adff0e74f23370..129eafbb1ef150e45dcf0c249656eb5c915be2cd 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.ml @@ -189,14 +189,10 @@ module Index = struct end module Number_of_ticks = struct - include Bounded.Int32.Make (struct - let min_int = 0l - - let max_int = Int32.max_int - end) + include Bounded.Non_negative_int32 let zero = - match of_int32 0l with + match of_value 0l with | Some zero -> zero | None -> assert false (* unreachable case, since [min_int = 0l] *) end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli index 7e317f1c4d5db0dea16fb7d8e9c26821f336741b..73ce017df2f9d069ec68ca189e189d8a15cc992a 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_repr.mli +++ b/src/proto_alpha/lib_protocol/sc_rollup_repr.mli @@ -79,7 +79,7 @@ end See also {!Commitment_repr.}. *) module Number_of_ticks : sig - include Bounded.Int32.S + include module type of Bounded.Non_negative_int32 val zero : t end diff --git a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml index 7603f88c6b15ad7af9745338a48e0ea779535765..a05dd74a416e155868a67b9dedc7983e103336ab 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_stake_storage.ml @@ -194,7 +194,7 @@ let assert_refine_conditions_met ctxt rollup lcc commitment = let* ctxt = assert_commitment_period ctxt rollup commitment in if Int32.equal - (Sc_rollup_repr.Number_of_ticks.to_int32 + (Sc_rollup_repr.Number_of_ticks.to_value Commitment.(commitment.number_of_ticks)) 0l then assert_same_hash_as_predecessor ctxt rollup commitment diff --git a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml index a0bbdeecf9a17ec5b2a838800e632e0a1a73cb84..fbe414a63342617318834c49569a113d76dbabcc 100644 --- a/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml +++ b/src/proto_alpha/lib_protocol/sc_rollup_tick_repr.ml @@ -45,7 +45,7 @@ let to_int x = if Z.fits_int x then Some (Z.to_int x) else None let of_z x = x let of_number_of_ticks x = - Z.of_int32 (Sc_rollup_repr.Number_of_ticks.to_int32 x) + Z.of_int32 (Sc_rollup_repr.Number_of_ticks.to_value x) let ( <= ) = leq diff --git a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml index 3e92585ca863b1db406c396fd9f41213debbcb8f..7e4466dfdfa266b2eea9653c4c7133ba3eb525f2 100644 --- a/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml +++ b/src/proto_alpha/lib_protocol/test/integration/operations/test_sc_rollup.ml @@ -172,7 +172,7 @@ let init_and_originate ?boot_sector ?origination_proof return (block, contracts, rollup) let number_of_ticks_exn n = - match Sc_rollup.Number_of_ticks.of_int32 n with + match Sc_rollup.Number_of_ticks.of_value n with | Some x -> x | None -> Stdlib.failwith "Bad Number_of_ticks" diff --git a/src/proto_alpha/lib_protocol/test/integration/test_constants.ml b/src/proto_alpha/lib_protocol/test/integration/test_constants.ml index 610929ef0116810aa11f058e23073ee5b64c2d4e..d63c0087eea855219d592d3c16ab550755e490a4 100644 --- a/src/proto_alpha/lib_protocol/test/integration/test_constants.ml +++ b/src/proto_alpha/lib_protocol/test/integration/test_constants.ml @@ -120,7 +120,7 @@ let test_sc_rollup_commitment_storage_size () = let open Protocol in Assert.get_some ~loc:__LOC__ - (Sc_rollup_repr.Number_of_ticks.of_int32 1232909l) + (Sc_rollup_repr.Number_of_ticks.of_value 1232909l) >>=? fun number_of_ticks -> let commitment = Sc_rollup_commitment_repr.to_versioned diff --git a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml index 3801665430fb158635e024521b47414af282a34f..f5d1eeb9767c4c93b352ae4c8dc867bed3e4886c 100644 --- a/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml +++ b/src/proto_alpha/lib_protocol/test/integration/validate/manager_operation_helpers.ml @@ -839,7 +839,7 @@ let mk_sc_rollup_origination (oinfos : operation_req) (infos : infos) = let sc_dummy_commitment = let number_of_ticks = - match Sc_rollup.Number_of_ticks.of_int32 3000l with + match Sc_rollup.Number_of_ticks.of_value 3000l with | None -> assert false | Some x -> x in diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml index a784d3015f8d6e2459f33b609db8595d7a59f870..e1d2d376ef0f771787ce493e7e24749c034bc508 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_refutation_game.ml @@ -60,7 +60,7 @@ let tick_of_int_exn ?(__LOC__ = __LOC__) n = WithExceptions.Option.get ~loc:__LOC__ (Tick.of_int n) let number_of_ticks_of_int32_exn ?(__LOC__ = __LOC__) n = - WithExceptions.Option.get ~loc:__LOC__ (Number_of_ticks.of_int32 n) + WithExceptions.Option.get ~loc:__LOC__ (Number_of_ticks.of_value n) let make_external_inbox_message str = WithExceptions.Result.get_ok diff --git a/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_encoding.ml b/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_encoding.ml index 4e3d526a4623031307520c19296a7afd8293c5ef..c76f5195fad51b8d84f2520c92f9ab3c3fc13b58 100644 --- a/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_encoding.ml +++ b/src/proto_alpha/lib_protocol/test/pbt/test_sc_rollup_encoding.ml @@ -57,8 +57,8 @@ let gen_commitment_hash = let gen_number_of_ticks = let open Gen in let open Sc_rollup_repr.Number_of_ticks in - let* v = int32_range_gen min_int max_int in - return (WithExceptions.Option.get ~loc:__LOC__ (of_int32 v)) + let* v = int32_range_gen min_value max_value in + return (WithExceptions.Option.get ~loc:__LOC__ (of_value v)) let gen_commitment = let open Gen in diff --git a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml index 76c1beaa3bacf437fb21690520722b12c9a31466..21647d95ad84225ffba1118559c99fe1db404f0e 100644 --- a/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml +++ b/src/proto_alpha/lib_protocol/test/unit/test_sc_rollup_storage.ml @@ -469,7 +469,7 @@ let test_withdrawing_twice () = Sc_rollup_errors.Sc_rollup_not_staked let number_of_ticks_exn n = - match Sc_rollup_repr.Number_of_ticks.of_int32 n with + match Sc_rollup_repr.Number_of_ticks.of_value n with | Some x -> x | None -> Stdlib.failwith "Bad Number_of_ticks"