mte/src/amount.ml

(* TODO implement operations on amounts *)
open Syntax

type sign =
  | Sign_plus
  | Sign_minus

type t = {
  sign: sign option;
  currency: string;
  value: Int64.t;
  fraction: Int32.t;
}

let currency_length_limit = 12
let value_limit = Int64.add 1_L (Int64.of_float (Float.pow 2. 52.))
let fraction_nb_digits = 8

let fraction_limit =
  Int32.of_float (Float.pow 10. (Int.to_float fraction_nb_digits))

let is_letter = function 'a' .. 'z' | 'A' .. 'Z' -> true | _ -> false
let is_digit = function '0' .. '9' -> true | _ -> false

let check_currency s =
  if not @@ String.for_all is_letter s then
    Error "currency contains forbidden character"
  else
    let len = String.length s in
    if len = 0 then Error "currency is empty string"
    else if len < currency_length_limit then Ok ()
    else
      Fmt.error "currency is more than %d characters long" currency_length_limit

let check_value v =
  if Int64.unsigned_compare v value_limit < 0 then Ok ()
  else Error "value is greater than 2^52"

let check_fraction v =
  if Int32.unsigned_compare v fraction_limit < 0 then Ok ()
  else Fmt.error "fraction has more than %d digits" fraction_nb_digits

let make ~sign ~currency ~value ~fraction =
  let* () = check_currency currency in
  let* () = check_value value in
  let* () = check_fraction fraction in
  let currency = String.uppercase_ascii currency in
  Ok { sign; currency; value; fraction }

module Parser = struct
  open Angstrom

  let letters = take_while1 is_letter
  let digits = take_while1 is_digit

  let sign =
    choice
      [
        char '+' *> return (Some Sign_plus);
        char '-' *> return (Some Sign_minus);
        return None;
      ]

  let value =
    digits >>= fun s ->
    match Int64.of_string_opt s with
    | None -> fail "not a valid int64"
    | Some n -> return n

  let fraction =
    digits >>= fun s ->
    let len = String.length s in
    match len <= fraction_nb_digits with
    | false ->
        fail (Fmt.str "fraction has more than %d digits" fraction_nb_digits)
    | true -> (
        match Int32.of_string_opt s with
        | None -> fail "not a valid int32"
        | Some n ->
            let magnitude =
              let exp = Int.to_float (fraction_nb_digits - len) in
              Int32.of_float @@ Float.pow 10. exp
            in
            let n = Int32.mul n magnitude in
            return n)

  let amount =
    lift4
      (fun sign currency value fraction ->
        make ~sign ~currency ~value ~fraction)
      sign letters
      (char ':' *> value)
      (option 0_l (char '.' *> fraction))
    <* end_of_input

  let parse s =
    Angstrom.parse_string ~consume:Consume.All amount s |> Result.join
end

let of_string = Parser.parse

let pp =
  let open Fmt in
  let pp_sign =
    let pp ppf = function
      | Sign_plus -> char ppf '+'
      | Sign_minus -> char ppf '-'
    in
    Fmt.option pp
  in
  let rec rm_trailing_zeros count x =
    if x <> 0_l && Int32.rem x 10_l = 0_l then
      rm_trailing_zeros (succ count) (Int32.div x 10_l)
    else (count, x)
  in
  let pp_fraction ppf fraction =
    match fraction = 0_l with
    | true -> Fmt.nop ppf ()
    | false ->
        let count, x = rm_trailing_zeros 0 fraction in
        let nb_leading_zeros = fraction_nb_digits - count in
        pf ppf ".%0*lu" nb_leading_zeros x
  in
  fun ppf { sign; currency; value; fraction } ->
    pf ppf "%a%s:%Lu%a" pp_sign sign currency value pp_fraction fraction

let to_string = Fmt.str "%a" pp

(* - *)

let jsont = Jsont.of_of_string ~kind:"Amount" of_string ~enc:to_string

let pad_currency_string s =
  let len = String.length s in
  match len < currency_length_limit with
  | false -> Fmt.failwith "amount with invalid currency"
  | true ->
      let b = Bytes.make currency_length_limit '\x00' in
      Bytes.blit_string s 0 b 0 len;
      Bytes.unsafe_to_string b

(* binary decoding never unused *)
let make_exn value fraction currency =
  match make ~sign:None ~currency ~value ~fraction with
  | Error _ -> Fmt.failwith "Amount of binary data failure"
  | Ok v -> v

let bin =
  let open Bin in
  record make_exn
  |+ field beint64 (fun t -> t.value)
  |+ field beint32 (fun t -> t.fraction)
  |+ field (bytes currency_length_limit) (fun t ->
      pad_currency_string t.currency)
  |> sealr