338 lines
11 KiB
OCaml
338 lines
11 KiB
OCaml
(*****************************************************************************)
|
|
(* *)
|
|
(* Open Source License *)
|
|
(* Copyright (c) 2018 Dynamic Ledger Solutions, Inc. <contact@tezos.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. *)
|
|
(* *)
|
|
(*****************************************************************************)
|
|
|
|
module type QTY = sig
|
|
val id : string
|
|
end
|
|
|
|
module type S = sig
|
|
type qty
|
|
|
|
type error +=
|
|
| Addition_overflow of qty * qty (* `Temporary *)
|
|
| Subtraction_underflow of qty * qty (* `Temporary *)
|
|
| Multiplication_overflow of qty * int64 (* `Temporary *)
|
|
| Negative_multiplicator of qty * int64 (* `Temporary *)
|
|
| Invalid_divisor of qty * int64
|
|
|
|
(* `Temporary *)
|
|
|
|
val id : string
|
|
|
|
val zero : qty
|
|
|
|
val one_mutez : qty
|
|
|
|
val one_cent : qty
|
|
|
|
val fifty_cents : qty
|
|
|
|
val one : qty
|
|
|
|
val ( -? ) : qty -> qty -> qty tzresult
|
|
|
|
val ( +? ) : qty -> qty -> qty tzresult
|
|
|
|
val ( *? ) : qty -> int64 -> qty tzresult
|
|
|
|
val ( /? ) : qty -> int64 -> qty tzresult
|
|
|
|
val to_mutez : qty -> int64
|
|
|
|
(** [of_mutez n] (micro tez) is None if n is negative *)
|
|
val of_mutez : int64 -> qty option
|
|
|
|
(** [of_mutez_exn n] fails if n is negative.
|
|
It should only be used at toplevel for constants. *)
|
|
val of_mutez_exn : int64 -> qty
|
|
|
|
(** It should only be used at toplevel for constants. *)
|
|
val add_exn : qty -> qty -> qty
|
|
|
|
(** It should only be used at toplevel for constants. *)
|
|
val mul_exn : qty -> int -> qty
|
|
|
|
val encoding : qty Data_encoding.t
|
|
|
|
val to_int64 : qty -> int64
|
|
|
|
include Compare.S with type t := qty
|
|
|
|
val pp : Format.formatter -> qty -> unit
|
|
|
|
val of_string : string -> qty option
|
|
|
|
val to_string : qty -> string
|
|
end
|
|
|
|
module Make (T : QTY) : S = struct
|
|
type qty = int64 (* invariant: positive *)
|
|
|
|
type error +=
|
|
| Addition_overflow of qty * qty (* `Temporary *)
|
|
| Subtraction_underflow of qty * qty (* `Temporary *)
|
|
| Multiplication_overflow of qty * int64 (* `Temporary *)
|
|
| Negative_multiplicator of qty * int64 (* `Temporary *)
|
|
| Invalid_divisor of qty * int64
|
|
|
|
(* `Temporary *)
|
|
|
|
include Compare.Int64
|
|
|
|
let zero = 0L
|
|
|
|
(* all other constant are defined from the value of one micro tez *)
|
|
let one_mutez = 1L
|
|
|
|
let one_cent = Int64.mul one_mutez 10_000L
|
|
|
|
let fifty_cents = Int64.mul one_cent 50L
|
|
|
|
(* 1 tez = 100 cents = 1_000_000 mutez *)
|
|
let one = Int64.mul one_cent 100L
|
|
|
|
let id = T.id
|
|
|
|
let of_string s =
|
|
let triplets = function
|
|
| hd :: tl ->
|
|
let len = String.length hd in
|
|
Compare.Int.(
|
|
len <= 3 && len > 0
|
|
&& List.for_all (fun s -> String.length s = 3) tl)
|
|
| [] ->
|
|
false
|
|
in
|
|
let integers s = triplets (String.split_on_char ',' s) in
|
|
let decimals s =
|
|
let l = String.split_on_char ',' s in
|
|
if Compare.Int.(List.length l > 2) then false else triplets (List.rev l)
|
|
in
|
|
let parse left right =
|
|
let remove_commas s = String.concat "" (String.split_on_char ',' s) in
|
|
let pad_to_six s =
|
|
let len = String.length s in
|
|
String.init 6 (fun i -> if Compare.Int.(i < len) then s.[i] else '0')
|
|
in
|
|
try
|
|
Some
|
|
(Int64.of_string
|
|
(remove_commas left ^ pad_to_six (remove_commas right)))
|
|
with _ -> None
|
|
in
|
|
match String.split_on_char '.' s with
|
|
| [left; right] ->
|
|
if String.contains s ',' then
|
|
if integers left && decimals right then parse left right else None
|
|
else if
|
|
Compare.Int.(String.length right > 0)
|
|
&& Compare.Int.(String.length right <= 6)
|
|
then parse left right
|
|
else None
|
|
| [left] ->
|
|
if (not (String.contains s ',')) || integers left then parse left ""
|
|
else None
|
|
| _ ->
|
|
None
|
|
|
|
let pp ppf amount =
|
|
let mult_int = 1_000_000L in
|
|
let rec left ppf amount =
|
|
let (d, r) = (Int64.(div amount 1000L), Int64.(rem amount 1000L)) in
|
|
if d > 0L then Format.fprintf ppf "%a%03Ld" left d r
|
|
else Format.fprintf ppf "%Ld" r
|
|
in
|
|
let right ppf amount =
|
|
let triplet ppf v =
|
|
if Compare.Int.(v mod 10 > 0) then Format.fprintf ppf "%03d" v
|
|
else if Compare.Int.(v mod 100 > 0) then
|
|
Format.fprintf ppf "%02d" (v / 10)
|
|
else Format.fprintf ppf "%d" (v / 100)
|
|
in
|
|
let (hi, lo) = (amount / 1000, amount mod 1000) in
|
|
if Compare.Int.(lo = 0) then Format.fprintf ppf "%a" triplet hi
|
|
else Format.fprintf ppf "%03d%a" hi triplet lo
|
|
in
|
|
let (ints, decs) =
|
|
(Int64.(div amount mult_int), Int64.(to_int (rem amount mult_int)))
|
|
in
|
|
Format.fprintf ppf "%a" left ints ;
|
|
if Compare.Int.(decs > 0) then Format.fprintf ppf ".%a" right decs
|
|
|
|
let to_string t = Format.asprintf "%a" pp t
|
|
|
|
let ( - ) t1 t2 = if t2 <= t1 then Some (Int64.sub t1 t2) else None
|
|
|
|
let ( -? ) t1 t2 =
|
|
match t1 - t2 with
|
|
| None ->
|
|
error (Subtraction_underflow (t1, t2))
|
|
| Some v ->
|
|
ok v
|
|
|
|
let ( +? ) t1 t2 =
|
|
let t = Int64.add t1 t2 in
|
|
if t < t1 then error (Addition_overflow (t1, t2)) else ok t
|
|
|
|
let ( *? ) t m =
|
|
let open Compare.Int64 in
|
|
let open Int64 in
|
|
let rec step cur pow acc =
|
|
if cur = 0L then ok acc
|
|
else
|
|
pow +? pow
|
|
>>? fun npow ->
|
|
if logand cur 1L = 1L then
|
|
acc +? pow >>? fun nacc -> step (shift_right_logical cur 1) npow nacc
|
|
else step (shift_right_logical cur 1) npow acc
|
|
in
|
|
if m < 0L then error (Negative_multiplicator (t, m))
|
|
else
|
|
match step m t 0L with
|
|
| Ok res ->
|
|
Ok res
|
|
| Error ([Addition_overflow _] as errs) ->
|
|
Error (Multiplication_overflow (t, m) :: errs)
|
|
| Error errs ->
|
|
Error errs
|
|
|
|
let ( /? ) t d =
|
|
if d <= 0L then error (Invalid_divisor (t, d)) else ok (Int64.div t d)
|
|
|
|
let add_exn t1 t2 =
|
|
let t = Int64.add t1 t2 in
|
|
if t <= 0L then invalid_arg "add_exn" else t
|
|
|
|
let mul_exn t m =
|
|
match t *? Int64.(of_int m) with
|
|
| Ok v ->
|
|
v
|
|
| Error _ ->
|
|
invalid_arg "mul_exn"
|
|
|
|
let of_mutez t = if t < 0L then None else Some t
|
|
|
|
let of_mutez_exn x =
|
|
match of_mutez x with None -> invalid_arg "Qty.of_mutez" | Some v -> v
|
|
|
|
let to_int64 t = t
|
|
|
|
let to_mutez t = t
|
|
|
|
let encoding =
|
|
let open Data_encoding in
|
|
check_size 10 (conv Z.of_int64 (Json.wrap_error Z.to_int64) n)
|
|
|
|
let () =
|
|
let open Data_encoding in
|
|
register_error_kind
|
|
`Temporary
|
|
~id:(T.id ^ ".addition_overflow")
|
|
~title:("Overflowing " ^ T.id ^ " addition")
|
|
~pp:(fun ppf (opa, opb) ->
|
|
Format.fprintf
|
|
ppf
|
|
"Overflowing addition of %a %s and %a %s"
|
|
pp
|
|
opa
|
|
T.id
|
|
pp
|
|
opb
|
|
T.id)
|
|
~description:("An addition of two " ^ T.id ^ " amounts overflowed")
|
|
(obj1 (req "amounts" (tup2 encoding encoding)))
|
|
(function Addition_overflow (a, b) -> Some (a, b) | _ -> None)
|
|
(fun (a, b) -> Addition_overflow (a, b)) ;
|
|
register_error_kind
|
|
`Temporary
|
|
~id:(T.id ^ ".subtraction_underflow")
|
|
~title:("Underflowing " ^ T.id ^ " subtraction")
|
|
~pp:(fun ppf (opa, opb) ->
|
|
Format.fprintf
|
|
ppf
|
|
"Underflowing subtraction of %a %s and %a %s"
|
|
pp
|
|
opa
|
|
T.id
|
|
pp
|
|
opb
|
|
T.id)
|
|
~description:("An subtraction of two " ^ T.id ^ " amounts underflowed")
|
|
(obj1 (req "amounts" (tup2 encoding encoding)))
|
|
(function Subtraction_underflow (a, b) -> Some (a, b) | _ -> None)
|
|
(fun (a, b) -> Subtraction_underflow (a, b)) ;
|
|
register_error_kind
|
|
`Temporary
|
|
~id:(T.id ^ ".multiplication_overflow")
|
|
~title:("Overflowing " ^ T.id ^ " multiplication")
|
|
~pp:(fun ppf (opa, opb) ->
|
|
Format.fprintf
|
|
ppf
|
|
"Overflowing multiplication of %a %s and %Ld"
|
|
pp
|
|
opa
|
|
T.id
|
|
opb)
|
|
~description:
|
|
("A multiplication of a " ^ T.id ^ " amount by an integer overflowed")
|
|
(obj2 (req "amount" encoding) (req "multiplicator" int64))
|
|
(function Multiplication_overflow (a, b) -> Some (a, b) | _ -> None)
|
|
(fun (a, b) -> Multiplication_overflow (a, b)) ;
|
|
register_error_kind
|
|
`Temporary
|
|
~id:(T.id ^ ".negative_multiplicator")
|
|
~title:("Negative " ^ T.id ^ " multiplicator")
|
|
~pp:(fun ppf (opa, opb) ->
|
|
Format.fprintf
|
|
ppf
|
|
"Multiplication of %a %s by negative integer %Ld"
|
|
pp
|
|
opa
|
|
T.id
|
|
opb)
|
|
~description:
|
|
("Multiplication of a " ^ T.id ^ " amount by a negative integer")
|
|
(obj2 (req "amount" encoding) (req "multiplicator" int64))
|
|
(function Negative_multiplicator (a, b) -> Some (a, b) | _ -> None)
|
|
(fun (a, b) -> Negative_multiplicator (a, b)) ;
|
|
register_error_kind
|
|
`Temporary
|
|
~id:(T.id ^ ".invalid_divisor")
|
|
~title:("Invalid " ^ T.id ^ " divisor")
|
|
~pp:(fun ppf (opa, opb) ->
|
|
Format.fprintf
|
|
ppf
|
|
"Division of %a %s by non positive integer %Ld"
|
|
pp
|
|
opa
|
|
T.id
|
|
opb)
|
|
~description:
|
|
("Multiplication of a " ^ T.id ^ " amount by a non positive integer")
|
|
(obj2 (req "amount" encoding) (req "divisor" int64))
|
|
(function Invalid_divisor (a, b) -> Some (a, b) | _ -> None)
|
|
(fun (a, b) -> Invalid_divisor (a, b))
|
|
end
|