mte/src/amount.ml

(* TODO
   have a currency agnostic amount_lib.ml
   and specialize amount.ml to Config.currency??

   have safe amount arithmetic *)
open Syntax

type sign =
  | Sign_plus
  | Sign_minus

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

let maximum_currency_length = 11
let value_upper_bound = Int64.of_float @@ Float.pow 2. 52.
let fraction_max_number_of_digits = 8

(* TODO choose to either include or exclude upper limit for all bounds
   need a -1 here *)
let fraction_upper_bound =
  Int32.of_float @@ Float.pow 10. (Int.to_float fraction_max_number_of_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 > maximum_currency_length then
      Fmt.error "currency is more than %d characters long"
        maximum_currency_length
    else Ok ()

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

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

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 }

(*
let config_currency =
  match check_currency Config.currency with
  | Error e -> Fmt.failwith "Invalid currency name configuration: %s@." e
  | Ok () -> String.uppercase_ascii Config.currency

let make_config_currency ~value ~fraction =
  let* () = check_value value in
  let* () = check_fraction fraction in
  Ok { sign= None; currency= config_currency; value; fraction }
  *)

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_max_number_of_digits with
  | false ->
      fail
        (Fmt.str "fraction has more than %d digits"
           fraction_max_number_of_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_max_number_of_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 of_string s = parse_string ~consume:Consume.All amount s |> Result.join

let pp =
  let open Fmt in
  let pp_sign ppf = function
    | Sign_plus -> char ppf '+'
    | Sign_minus -> char ppf '-'
  in
  fun ppf { sign; currency; value; fraction } ->
    (* TODO
       depends on the currency's number of fraction digits *)
    pf ppf "%a%s:%Lu.%0*lu" (Fmt.option pp_sign) sign currency value
      fraction_max_number_of_digits fraction

let to_string = Fmt.str "%a" pp

(* - *)

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

let pad_currency_string s =
  let len = String.length s in
  assert (len < currency_length);
  let b = Bytes.make currency_length '\x00' in
  Bytes.blit_string s 0 b 0 len;
  Bytes.to_string b

(* binary decoding 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 -> Int32.mul t.fraction 1_000_000_l)
  |+ field (bytes currency_length) (fun t -> pad_currency_string t.currency)
  |> sealr