path: root/lib/ledger.ml

open Prelude

type tx_type =
  | Interest_tx
  | Online_banking_tx
  | Recurrent_direct_tx
  | Payment_terminal_tx
  | Cash_payment_tx
  | Atm_tx
  | Auto_save_rounding_tx
  | Batch_tx
  | Direct_debit_tx
  | Periodic_tx

type iban_tag = Account_tag | Counterparty_iban_tag [@@deriving compare, sexp]

type unit_tag = Filed_tag | Google_pay_tag | Auto_round_savings_tag
[@@deriving compare, sexp]

type string_tag =
  | Desc_tag
  | User_tag
  | Counterparty_name_tag
  | Reference_tag
  | Mandate_id_tag
  | Creditor_id_tag
  | Other_party_tag
  | Transaction_tag
  | Terminal_tag
  | Card_seq_no_tag
  | Savings_account_tag
[@@deriving compare, sexp]

module Label = struct
  type 'a t =
    | Iban_label : iban_tag -> Iban.t t
    | String_label : string_tag -> string t
    | Timestamp_label : Time_ns.t t
    | Unit_label : unit_tag -> unit t

  let int_to_cmp x : ('a, 'a) Dmap.cmp =
    if x < 0 then Lt else if x > 0 then Gt else Eq

  let compare (type a1 a2) (v1 : a1 t) (v2 : a2 t) : (a1, a2) Dmap.cmp =
    match (v1, v2) with
    | Iban_label t1, Iban_label t2 -> int_to_cmp @@ [%compare: iban_tag] t1 t2
    | String_label t1, String_label t2 ->
        int_to_cmp @@ [%compare: string_tag] t1 t2
    | Timestamp_label, Timestamp_label -> Eq
    | Unit_label t1, Unit_label t2 -> int_to_cmp @@ [%compare: unit_tag] t1 t2
    | Iban_label _, _ -> Lt
    | String_label _, Iban_label _ -> Gt
    | String_label _, _ -> Lt
    | Timestamp_label, Unit_label _ -> Lt
    | Timestamp_label, _ -> Gt
    | Unit_label _, _ -> Gt
end

module Labels = struct
  include Dmap.Make (Label)

  let sexp_of_binding = function
    | Binding (Iban_label tag, iban) ->
        Sexp.List
          [
            Sexp.Atom "iban"; [%sexp_of: iban_tag] tag; [%sexp_of: Iban.t] iban;
          ]
    | Binding (String_label tag, s) ->
        Sexp.List
          [ Sexp.Atom "string"; [%sexp_of: string_tag] tag; Sexp.Atom s ]
    | Binding (Timestamp_label, ts) ->
        Sexp.List [ Sexp.Atom "timestamp"; [%sexp_of: Time_ns_unix.t] ts ]
    | Binding (Unit_label tag, ()) ->
        Sexp.List [ Sexp.Atom "unit"; [%sexp_of: unit_tag] tag ]

  let binding_of_sexp sexp =
    match sexp with
    | Sexp.List [ Sexp.Atom "iban"; tag_sexp; iban_sexp ] ->
        Binding
          ( Iban_label ([%of_sexp: iban_tag] tag_sexp),
            [%of_sexp: Iban.t] iban_sexp )
    | Sexp.List [ Sexp.Atom "string"; tag_sexp; Sexp.Atom s ] ->
        Binding (String_label ([%of_sexp: string_tag] tag_sexp), s)
    | Sexp.List [ Sexp.Atom "timestamp"; ts_sexp ] ->
        Binding (Timestamp_label, [%of_sexp: Time_ns_unix.t] ts_sexp)
    | Sexp.List [ Sexp.Atom "unit"; tag_sexp ] ->
        Binding (Unit_label ([%of_sexp: unit_tag] tag_sexp), ())
    | _ -> of_sexp_error "Labels.binding_of_sexp: invalid binding" sexp

  let sexp_of_t m = Sexp.List (bindings m |> List.map ~f:sexp_of_binding)

  let t_of_sexp sexp =
    match sexp with
    | Sexp.List labels ->
        Sequence.(of_list labels >>| binding_of_sexp |> to_seq) |> of_seq
    | Sexp.Atom _ -> of_sexp_error "Labels.t_of_sexp: list needed" sexp
end

module Money : sig
  type t

  val equal : t -> t -> bool
  val compare : t -> t -> int
  val of_bigint : Bigint.t -> t
  val to_bigint : t -> Bigint.t
  val ( + ) : t -> t -> t
  val ( - ) : t -> t -> t
  val ( = ) : t -> t -> bool
  val ( ~$ ) : int -> t
  val sexp_of_t : t -> Sexp.t
end = struct
  type t = Bigint.t [@@deriving sexp_of]

  let equal = Bigint.equal
  let compare = Bigint.compare
  let of_bigint = Fn.id
  let to_bigint = Fn.id
  let ( + ) x y = Bigint.(x + y)
  let ( - ) x y = Bigint.(x - y)
  let ( = ) = equal
  let ( ~$ ) = Fn.compose of_bigint Bigint.of_int
end

type commodity_id = string
(* TODO: consider making this UUID *) [@@deriving equal, compare, sexp]

type scalar =
  | Amount of Money.t
  | Rate of { in_primary_commodity : Money.t; rate : Bigdecimal.t }
[@@deriving equal, compare, sexp_of]

module Account_id = struct
  type t = string list [@@deriving sexp, compare]
end

type account = {
  id : Account_id.t;
  description : string list;
  commodity_id : commodity_id;
  balance : Money.t;
}
[@@deriving sexp_of]

type bal_assert = {
  account : Account_id.t;
  amount : Money.t;
  labels : Labels.t;
}
[@@deriving sexp_of]

module Account_id_map = Map.Make (Account_id)

module Debit_credit = struct
  type t = Debit | Credit [@@deriving string, sexp_of]

  let opposite = function Debit -> Credit | Credit -> Debit
end

module Tx : sig
  (* Private because we only want to allow constructing balanced transactions. *)
  type t = private {
    cleared : Date.t option;
    commodity_id : commodity_id;
    entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t;
    labels : Labels.t;
  }

  type error = Unbalanced

  val make :
    cleared:Date.t option ->
    commodity_id:commodity_id ->
    entries:(Debit_credit.t * scalar * Money.t option) Account_id_map.t ->
    labels:Labels.t ->
    (t, error) result

  val sexp_of_t : t -> Sexp.t
end = struct
  type t = {
    cleared : Date.t option;
    commodity_id : commodity_id;
    entries : (Debit_credit.t * scalar * Money.t option) Account_id_map.t;
    labels : Labels.t;
  }
  [@@deriving sexp_of]

  type error = Unbalanced

  let is_balanced entries =
    Map.fold entries
      ~init:Money.(~$0, ~$0)
      ~f:(fun ~key:_ ~data:(type_, scalar, _oassert) (ds, cs) ->
        let m =
          match scalar with
          | Amount m -> m
          | Rate { in_primary_commodity = m; _ } -> m
        in
        match type_ with
        | Debit_credit.Debit -> Money.(ds + m, cs)
        | Debit_credit.Credit -> Money.(ds, cs + m))
    |> fun (ds, cs) -> Money.(ds = cs)

  let make ~cleared ~commodity_id ~entries ~labels =
    if not (is_balanced entries) then Error Unbalanced
    else Ok { cleared; commodity_id; entries; labels }
end

type item =
  | Tx_item of Tx.t
  | Bal_assert_item of bal_assert (*| Account_decl_item of account_decl*)
[@@deriving sexp_of]

type t = item list [@@deriving sexp_of]

module Account = struct
  type global_type = Asset | Equity | Liability | Expense | Income
  [@@deriving compare, sexp]

  type asset
  type global

  type 'a subcategory =
    | Asset : asset subcategory option -> global subcategory
    | Checking : asset subcategory

  type 'a t = Sub of ('a, 'a t) category String.Map.t

  let world : global t =
    Sub
      (String.Map.of_alist_exn [ ("Assets", Asset (Some (
           String.Map.of_alist_exn [
             ("Checking", Checking)
           ]
         ))) ])
end

(*
module World = struct
  type t = (commodity_id * Money.t) Account_id_map.t

  let empty : t = Account_id_map.empty

  let apply_tx_entry_base aid primary_commodity debit_credit scalar =
    let amount = Scalar.to_amount ~commodity:primary_commodity scalar in
    Map.update aid ~f:(function
          | None -> 

            (*
  let assert_bal aid sc world =

  let apply_tx_entry aid (dc, sc, oassert) world = *)

  let apply_tx (tx : Tx.t) world =
    Map.fold tx.entries ~init:world ~f:(fun ~key:account_id ~data:(type_, scalar, _oassert) world ->
        

      )

  let apply : item -> t -> t = function
    | Tx_item tx -> apply_tx tx
    | Bal_assert_item ba -> apply_ba ba
end *)

let make = Fn.id