# Copyright (c) 2024 Trevor L. Davis <trevor.l.davis@gmail.com>
# Copyright (c) 2018 Jenya Sovetkin <e.sovetkin@gmail.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.

#' Determine default tool chain used for reading in register
#'
#' `default_toolchain` determines default tool chain used for reading in register.
#'
#' @param file Filename for a ledger, hledger, or beancount file.
#'
#' @export
default_toolchain <- function(file) {
	ext <- tools::file_ext(file)
	toolchain <- switch(
		ext,
		ledger = "ledger",
		hledger = "hledger",
		bean = "beancount",
		beancount = "beancount",
		NULL
	)
	if (is.null(toolchain)) {
		stop(paste("Couldn't find an acceptable toolchain for", ext))
	}
	toolchain
}

#' Import a ledger, hledger, or beancount register
#'
#' `register` imports the register from a ledger, hledger, or beancount file as a tibble.
#'
#' @param file Filename for a ledger, hledger, or beancount file.
#' @param ... Arguments passed on to either `register_ledger`,
#'     `register_hledger`, or `register_beancount`
#' @param flags Character vector of additional command line flags to pass
#'     to either `ledger csv` or `hledger register`.
#' @param toolchain Toolchain used to read in register.
#'     Either `"ledger"` (uses `ledger`), `"hledger"` (uses `hledger`),
#'     `"beancount"` (uses `bean-query` if available, else `rledger`),
#'     `"bean-query"` (uses `bean-query` from `beanquery`),
#'     or `"rledger"` (uses `rledger` from `rustledger`).
#' @param date End date.
#'     Only transactions (and implicitly price statements) strictly before this date are used.
#' @return `register` returns a tibble.
#'
#' @importFrom dplyr bind_rows
#' @importFrom dplyr mutate
#' @importFrom dplyr select
#' @importFrom tools file_ext
#' @importFrom rlang .data
#' @export
#' @examples
#'  if (Sys.which("ledger") != "") {
#'      example_ledger_file <- system.file("extdata", "example.ledger", package = "ledger")
#'      dfl <- register(example_ledger_file)
#'      head(dfl)
#'  }
#'  if (Sys.which("hledger") != "") {
#'      example_hledger_file <- system.file("extdata", "example.hledger", package = "ledger")
#'      dfh <- register(example_hledger_file)
#'      head(dfh)
#'  }
#'  if (Sys.which("bean-query") != "" || Sys.which("rledger") != "") {
#'      example_beancount_file <- system.file("extdata", "example.beancount", package = "ledger")
#'      dfb <- register(example_beancount_file)
#'      head(dfb)
#'  }
register <- function(file, ..., toolchain = default_toolchain(file), date = NULL) {
	.assert_toolchain(toolchain)
	switch(
		toolchain,
		"ledger" = register_ledger(file, ..., date = date),
		"hledger" = register_hledger(file, ..., date = date),
		"beancount" = register_beancount(file, ..., date = date),
		"bean-query" = register_bean_query(file, ..., date = date),
		"rledger" = register_rledger(file, ..., date = date),
		"bean-report_ledger" = {
			.Deprecated(
				msg = paste(
					'`toolchain = "bean-report_ledger" is deprecated.',
					'Use `toolchain = "beancount"` instead.'
				)
			)
			file <- .bean_report(file, "ledger")
			on.exit(unlink(file))
			register_ledger(file, ..., date = date)
		},
		"bean-report_hledger" = {
			.Deprecated(
				msg = paste(
					'`toolchain = "bean-report_hledger" is deprecated.',
					'Use `toolchain = "beancount"` instead.'
				)
			)
			file <- .bean_report(file, "hledger")
			on.exit(unlink(file))
			register_hledger(file, ..., date = date)
		}
	)
}

#' @importFrom tidyselect matches
.select_columns <- function(df) {
	select(
		df,
		"date",
		tidyselect::matches("mark$"),
		"payee",
		"description",
		tidyselect::matches("^code$"),
		"account",
		"amount",
		"commodity",
		tidyselect::matches("historical_cost"),
		tidyselect::matches("hc_commodity"),
		tidyselect::matches("market_value"),
		tidyselect::matches("mv_commodity"),
		tidyselect::matches("comment"),
		tidyselect::matches("tags"),
		tidyselect::matches("id")
	)
}

.nf <- function(filename) shQuote(normalizePath(filename, mustWork = FALSE))

.bean_report <- function(file, format) {
	tfile <- tempfile(fileext = paste0(".", format))
	args <- c("-o", .nf(tfile), .nf(file), format)
	if (.Platform$OS.type == "windows") {
		# bean-report on Windows seems to choke when called from system2
		shell(paste("bean-report -o", .nf(tfile), .nf(file), format), mustWork = TRUE)
	} else {
		.system("bean-report", args)
	}
	tfile
}

.beancount_query <- function(date) {
	query <- paste(
		"select date, flag as mark, account, payee,",
		"narration as description,",
		"number as amount, currency as commodity,",
		"number(cost(position)) as historical_cost,",
		"currency(cost(position)) as hc_commodity,",
		"tags, id,"
	)
	if (!is.null(date)) {
		date <- as.Date(date)
		query <- paste(
			query,
			sprintf("number(value(position,%s)) as market_value,", date - 1),
			sprintf("currency(value(position,%s)) as mv_commodity", date - 1),
			"from close on",
			date
		)
	} else {
		query <- paste(
			query,
			"number(value(position)) as market_value,",
			"currency(value(position)) as mv_commodity"
		)
	}
	query
}

#' @importFrom stringr str_squish
#' @importFrom stringr str_trim
.clean_beancount <- function(df) {
	if (nrow(df) == 0L) {
		tibble(
			date = as.Date(character()),
			mark = character(),
			account = character(),
			payee = character(),
			description = character(),
			amount = numeric(),
			commodity = character(),
			historical_cost = numeric(),
			hc_commodity = character(),
			market_value = numeric(),
			mv_commodity = character(),
			tags = character(),
			id = character()
		)
	} else {
		df <- mutate(
			df,
			date = as.Date(str_trim(.data$date)),
			mark = str_trim(.data$mark),
			account = str_trim(.data$account),
			payee = str_trim(.data$payee),
			description = str_trim(.data$description),
			commodity = str_trim(.data$commodity),
			hc_commodity = str_trim(.data$hc_commodity),
			mv_commodity = str_trim(.data$mv_commodity),
			tags = str_squish(.data$tags),
			id = str_trim(.data$id)
		)
		.select_columns(df)
	}
}

#' @rdname register
#' @export
register_beancount <- function(file, date = NULL) {
	if (.is_binary_on_path("bean-query")) {
		register_bean_query(file, date)
	} else {
		register_rledger(file, date)
	}
}

#' @importFrom tidyr separate
#' @rdname register
#' @export
register_bean_query <- function(file, date = NULL) {
	cfile <- tempfile(fileext = ".csv")
	query <- .beancount_query(date)
	args <- c("-f", "csv", "-o", .nf(cfile), .nf(file), shQuote(query))
	if (.Platform$OS.type == "windows") {
		# bean-query on Windows seems to choke when called from system2
		shell(paste("bean-query -f csv -o", .nf(cfile), .nf(file), shQuote(query)), mustWork = TRUE)
	} else {
		.system("bean-query", args)
	}
	.clean_beancount(.read_csv(cfile))
}

#' @rdname register
#' @export
register_rledger <- function(file, date = NULL) {
	cfile <- tempfile(fileext = ".csv")
	query <- .beancount_query(date)
	args <- c("query", "-f", "csv", "-o", .nf(cfile), .nf(file), shQuote(query))
	.system("rledger", args)
	.clean_beancount(.read_csv(cfile))
}

#' @rdname register
#' @param add_mark Whether to add a column with the mark information.  Only relevant for hledger files.
#' @param add_cost Whether to add historical cost columns.  Only relevant for hledger files.
#' @param add_value Whether to add market value columns.  Only relevant for hledger files.
#' @export
register_hledger <- function(
	file,
	flags = "",
	date = NULL,
	add_mark = TRUE,
	add_cost = TRUE,
	add_value = TRUE
) {
	if (!is.null(date)) {
		flags <- c(flags, paste0("--end=", date))
	}
	df <- .register_hledger_helper(file, flags, add_mark)
	if (add_cost) {
		df_c <- .register_hledger_helper(file, c(flags, "--cost"), add_mark)
		df$historical_cost <- df_c$amount
		df$hc_commodity <- df_c$commodity
	}
	if (add_value) {
		df_m <- .register_hledger_helper(file, c(flags, "-V"), add_mark)
		df$market_value <- df_m$amount
		df$mv_commodity <- df_m$commodity
	}
	.select_columns(df)
}

.register_hledger_helper <- function(hfile, flags = "", add_mark = TRUE) {
	df <- .read_hledger(hfile, flags)
	if (!add_mark) {
		df <- select(df, -"mark")
	}
	df
}

.read_hledger <- function(hfile, flags) {
	cfile <- tempfile(fileext = ".csv")
	on.exit(unlink(cfile))
	args <- c("print", "-f", .nf(hfile), "-o", .nf(cfile), flags)
	.system("hledger", args)
	df <- .read_csv(cfile)
	.clean_hledger(df)
}

#' @importFrom tibble tibble
#' @importFrom tibble as_tibble
#' @importFrom utils read.csv
.read_csv <- function(cfile, ...) {
	as_tibble(read.csv(cfile, stringsAsFactors = FALSE, ...))
}

.system <- function(cmd, args) {
	tryCatch(system2(cmd, args, stdout = TRUE, stderr = TRUE), warning = function(w) {
		stop(paste(c(paste(cmd, "had an import error:"), w), collapse = "\n"))
	})
}

.clean_hledger <- function(df) {
	if (nrow(df) > 0L) {
		df <- mutate(df, date = as.Date(date, tryFormats = c("%Y-%m-%d", "%Y/%m/%d")))
		df <- mutate(
			df,
			description = ifelse(
				grepl("\\|$", .data$description),
				paste0(.data$description, " "),
				.data$description
			)
		)
		df <- mutate(
			df,
			description = ifelse(
				grepl("\\|", .data$description),
				.data$description,
				paste0(" | ", .data$description)
			)
		)
		df <- mutate(df, payee = .left_of_split(.data$description, " \\| "))
		df <- mutate(df, description = .right_of_split(.data$description, " \\| "))
		df <- mutate(
			df,
			payee = ifelse(.data$payee == "", NA, .data$payee),
			description = ifelse(.data$description == "", NA, .data$description)
		)

		df <- mutate(df, amount = gsub(" @.*$", "", .data$amount))
		df <- mutate(df, amount = to_numeric(.data$amount))
		df <- mutate(df, id = as.character(.data$txnidx))

		df <- select(
			df,
			"date",
			"description",
			"payee",
			"amount",
			"commodity",
			"account",
			mark = "status",
			"id"
		)
	} else {
		df <- tibble(
			date = as.Date(character()),
			description = character(),
			payee = character(),
			amount = numeric(),
			commodity = character(),
			account = character(),
			mark = character(),
			id = character()
		)
	}
	df
}

.left_of_split <- function(strings, split) {
	sapply(strsplit(strings, split), function(x) x[1])
}
.right_of_split <- function(strings, split) {
	sapply(strsplit(strings, split), function(x) x[2])
}

#' @rdname register
#' @export
register_ledger <- function(file, flags = "", date = NULL) {
	if (!is.null(date)) {
		flags <- c(flags, paste0("--end=", date))
	}
	flags <- c(flags, "--empty")
	df <- .read_ledger(file, flags)
	.select_columns(df)
}

.read_ledger <- function(lfile, flags) {
	cfile <- tempfile(fileext = ".csv")
	on.exit(unlink(cfile))
	if (.Platform$OS.type == "windows") {
		# ledger on Windows seems to choke on absolute file paths
		tlfile <- tempfile(fileext = ".ledger")
		on.exit(unlink(tlfile))
		file.copy(lfile, tlfile)
		wd <- getwd()
		on.exit(setwd(wd))
		setwd(tempdir())
		args <- c("csv", "-f", basename(tlfile), "-o", basename(cfile), flags)
	} else {
		args <- c("csv", "-f", .nf(lfile), "-o", .nf(cfile), flags)
	}
	.system("ledger", args)
	.clean_ledger(.read_csv(cfile, header = FALSE))
}

.clean_ledger <- function(df) {
	names(df) <- c(
		"date",
		"code",
		"description",
		"account",
		"commodity",
		"amount",
		"mark",
		"comment"
	)
	df <- mutate(
		df,
		date = as.Date(date, "%Y/%m/%d"),
		# When a transaction code is present, ledger embeds the mark in the
		# description instead of the mark column
		mark = ifelse(
			.data$mark == "" & grepl("^[*!] ", .data$description),
			sub("^([*!]) .*", "\\1", .data$description),
			.data$mark
		),
		description = ifelse(
			grepl("^[*!] ", .data$description),
			sub("^[*!] ", "", .data$description),
			.data$description
		),
		description = ifelse(
			grepl("\\|$", .data$description),
			paste0(.data$description, " "),
			.data$description
		),
		description = ifelse(
			grepl("\\|", .data$description),
			.data$description,
			paste0(" | ", .data$description)
		),
		payee = .left_of_split(.data$description, " \\| "),
		description = .right_of_split(.data$description, " \\| "),
		payee = ifelse(.data$payee == "", NA_character_, .data$payee),
		description = ifelse(.data$description == "", NA_character_, .data$description),
		payee = as.character(.data$payee),
		code = ifelse(.data$code == "", NA_character_, as.character(.data$code)),
		comment = str_trim(as.character(.data$comment))
	)
	df
}

.is_binary_on_path <- function(binary) {
	Sys.which(binary) != ""
}
.is_toolchain_supported <- function(toolchain) {
	if (toolchain == "ledger") {
		.is_binary_on_path("ledger")
	} else if (toolchain == "hledger") {
		.is_binary_on_path("hledger")
	} else if (toolchain == "beancount") {
		.is_binary_on_path("bean-query") || .is_binary_on_path("rledger")
	} else if (toolchain == "bean-query") {
		.is_binary_on_path("bean-query")
	} else if (toolchain == "rledger") {
		.is_binary_on_path("rledger")
	} else if (toolchain == "bean-report_ledger") {
		.is_binary_on_path("ledger") && .is_binary_on_path("bean-report")
	} else if (toolchain == "bean-report_hledger") {
		.is_binary_on_path("hledger") && .is_binary_on_path("bean-report")
	} else {
		FALSE
	}
}

.assert_toolchain <- function(toolchain) {
	if (!.is_toolchain_supported(toolchain)) {
		stop(paste(toolchain, "binaries not found on path"))
	}
}
