(**************************************************************************) (* *) (* Copyright (c) 2014 - 2016. *) (* Dynamic Ledger Solutions, Inc. <contact@tezos.com> *) (* *) (* All rights reserved. No warranty, explicit or implicit, provided. *) (* *) (**************************************************************************) open Error_monad 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_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_cents : qty -> int64 (** [of_cents n] is None if n is negative *) val of_cents : int64 -> qty option (** [of_cents_exn n] fails if n is negative. It should only be used at toplevel for constants. *) val of_cents_exn : int64 -> qty (** It should only be used at toplevel for constants. *) val add_exn : qty -> qty -> 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 let one_cent = 1L let fifty_cents = 50L let one = 100L let id = T.id let of_cents t = if t < 0L then None else Some t let of_string s = let len = String.length s in let rec dec i len acc = if Compare.Int.(i = len) then acc else dec (succ i) len (Int64.add (Int64.mul 10L acc) (match String.get s i with | '0' -> 0L | '1' -> 1L | '2' -> 2L | '3' -> 3L | '4' -> 4L | '5' -> 5L | '6' -> 6L | '7' -> 7L | '8' -> 8L | '9' -> 9L | _ -> raise Exit)) in let rec loop acc m len = if Compare.Int.(len >= 4) && Compare.Char.(String.get s (len - 4) = ',') then let acc = Int64.add acc Int64.(mul (dec (len - 3) len 0L) m) in loop acc Int64.(mul 1000L m) (len - 4) else Int64.add acc Int64.(mul (dec 0 len 0L) m) in let cents, len = if Compare.Int.(len >= 3) && Compare.Char.(String.get s (len - 3) = '.') then dec (len - 2) len 0L, len - 3 else 0L, len in let res = if Compare.Int.(len >= 4) && Compare.Char.(String.get s (len - 4) = ',') then loop cents 100L len else if Compare.Int.(len = 0) && Compare.Int.(String.length s = 3) then cents else try Int64.(add (mul 100L (of_string (String.sub s 0 len))) cents) with _ -> raise Exit in match of_cents res with | None -> raise Exit | Some tez -> tez let of_string s = try Some (of_string s) with Exit -> None let pp ppf amount = let rec loop ppf amount= let d, r = Int64.div amount 1000L, Int64.rem amount 1000L in if d > 0L then Format.fprintf ppf "%a,%03Ld" loop d r else Format.fprintf ppf "%Ld" r in let i, c = Int64.div amount 100L, Int64.rem amount 100L in Format.fprintf ppf "%a.%02Ld" loop i c 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 to_cents t = t let of_cents_exn x = match of_cents x with | None -> invalid_arg "Qty.of_cents" | Some v -> v let to_int64 t = t let encoding = let open Data_encoding in describe ~title: "Amount in centiles" (conv to_int64 (Json.wrap_error of_cents_exn) int64) 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