//
// utils.rs
//
// Copyright (C) 2022 Posit Software, PBC. All rights reserved.
//
//

use std::ffi::CStr;
use std::ffi::CString;

use itertools::Itertools;
use libr::*;

use crate::call::r_expr_quote;
use crate::call::RArgument;
use crate::environment::Environment;
use crate::error::Error;
use crate::error::Result;
use crate::exec::RFunction;
use crate::exec::RFunctionExt;
use crate::modules::HARP_ENV;
use crate::object::r_alloc_character;
use crate::object::r_chr_get;
use crate::object::r_chr_poke;
use crate::object::r_dim;
use crate::object::r_length;
use crate::object::r_node_car;
use crate::object::r_node_cdr;
use crate::object::r_str_blank;
use crate::object::r_str_na;
use crate::object::RObject;
use crate::protect::RProtect;
use crate::r::fn_formals;
use crate::r_char;
use crate::r_lang;
use crate::r_null;
use crate::r_symbol;
use crate::symbol::RSymbol;
use crate::vector::CharacterVector;
use crate::vector::IntegerVector;
use crate::vector::Vector;

pub fn init_utils() {}

pub use crate::syntax::is_valid_symbol;
pub use crate::syntax::sym_quote;
pub use crate::syntax::sym_quote_invalid;

#[harp::register]
pub extern "C-unwind" fn harp_log_trace(msg: SEXP) -> crate::error::Result<SEXP> {
    let msg = String::try_from(RObject::view(msg))?;
    log::trace!("{msg}");

    unsafe { Ok(libr::R_NilValue) }
}

#[harp::register]
pub extern "C-unwind" fn harp_log_warning(msg: SEXP) -> crate::error::Result<SEXP> {
    let msg = String::try_from(RObject::view(msg))?;
    log::warn!("{msg}");

    unsafe { Ok(libr::R_NilValue) }
}

#[harp::register]
pub extern "C-unwind" fn harp_log_error(msg: SEXP) -> crate::error::Result<SEXP> {
    let msg = String::try_from(RObject::view(msg))?;
    log::error!("{msg}");

    unsafe { Ok(libr::R_NilValue) }
}

pub fn r_assert_type(object: SEXP, expected: &[u32]) -> Result<u32> {
    let actual = r_typeof(object);

    if !expected.contains(&actual) {
        return Err(Error::UnexpectedType(actual, expected.to_vec()));
    }

    Ok(actual)
}

pub fn r_assert_capacity(object: SEXP, required: usize) -> Result<usize> {
    let actual = unsafe { Rf_xlength(object) } as usize;
    if actual < required {
        return Err(Error::UnexpectedLength(actual, required));
    }

    Ok(actual)
}

pub fn r_assert_length(object: SEXP, expected: usize) -> Result<usize> {
    let actual = unsafe { Rf_xlength(object) as usize };
    if actual != expected {
        return Err(Error::UnexpectedLength(actual, expected));
    }

    Ok(actual)
}

pub fn assert_class(object: SEXP, expected: &str) -> Result<()> {
    if !RObject::view(object).inherits(expected) {
        let actual = RObject::view(object).class()?;
        return Err(Error::UnexpectedClass(actual, expected.into()));
    }

    Ok(())
}

pub fn assert_non_optional<T>(object: Vec<Option<T>>) -> harp::Result<Vec<T>> {
    let Some(non_optional): Option<Vec<T>> = object.into_iter().collect() else {
        return Err(harp::anyhow!("Values are unexpectedly missing"));
    };
    Ok(non_optional)
}

pub fn r_is_data_frame(object: SEXP) -> bool {
    r_typeof(object) == VECSXP && r_inherits(object, "data.frame")
}

pub fn r_is_null(object: SEXP) -> bool {
    unsafe { object == libr::R_NilValue }
}

pub fn r_is_altrep(object: SEXP) -> bool {
    unsafe { libr::ALTREP(object) != 0 }
}

pub fn r_is_object(object: SEXP) -> bool {
    unsafe { libr::Rf_isObject(object) != 0 }
}

pub fn r_is_s4(object: SEXP) -> bool {
    unsafe { libr::Rf_isS4(object) != 0 }
}

pub fn r_is_unbound(object: SEXP) -> bool {
    object == unsafe { R_UnboundValue }
}

pub fn r_is_simple_vector(value: SEXP) -> bool {
    unsafe {
        let class = Rf_getAttrib(value, R_ClassSymbol);

        match r_typeof(value) {
            LGLSXP | REALSXP | CPLXSXP | STRSXP | RAWSXP => r_is_null(class),
            INTSXP => r_is_null(class) || r_inherits(value, "factor"),

            _ => false,
        }
    }
}

pub fn r_is_string(x: SEXP) -> bool {
    r_typeof(x) == STRSXP && r_length(x) == 1 && x != r_str_na()
}

/// Is `object` a matrix?
///
/// Notably returns `false` for 1D arrays and >=3D arrays.
pub fn r_is_matrix(object: SEXP) -> bool {
    // We can't check the `dim` attribute for CHARSXP's
    if r_typeof(object) == CHARSXP {
        return false;
    }

    let dim = r_dim(object);

    if dim == r_null() {
        return false;
    }

    r_length(dim) == 2
}

pub fn r_classes(value: SEXP) -> Option<CharacterVector> {
    unsafe {
        let classes = RObject::from(Rf_getAttrib(value, R_ClassSymbol));

        if *classes == libr::R_NilValue {
            None
        } else {
            Some(CharacterVector::new_unchecked(classes))
        }
    }
}

/// Translates a UTF-8 string from an R character vector to a Rust string.
///
/// - `x` is the R vector to translate from.
/// - `i` is the index in the vector of the string to translate.
pub fn r_chr_get_owned_utf8(x: SEXP, i: isize) -> Result<String> {
    unsafe { r_str_to_owned_utf8(STRING_ELT(x, i)) }
}

/// Translates an R string to a UTF-8 Rust string.
///
/// - `x` is a CHARSXP.
///
/// Missing values return an `Error::MissingValueError`.
pub fn r_str_to_owned_utf8(x: SEXP) -> Result<String> {
    if x == unsafe { R_NaString } {
        Err(Error::MissingValueError)
    } else {
        Ok(r_str_to_owned_utf8_unchecked(x))
    }
}

/// Translates an R string to a UTF-8 Rust string without type checking.
///
/// - `x` is a CHARSXP that is assumed to not be missing.
///
/// Unchecked here only refers to checking for `NA`. Otherwise it still attempts
/// a UTF-8 translation and will replace any remaining invalid UTF-8 characters
/// with the UTF-8 replacement character.
pub fn r_str_to_owned_utf8_unchecked(x: SEXP) -> String {
    unsafe {
        // Attempt to translate it to a UTF-8 C string (note that this allocates
        // with `R_alloc()` so we need to save and reset the protection stack).
        // Sadly this can still result in invalid UTF-8 bytes, so we are forced
        // to use `to_string_lossy()` below to be absolutely sure that invalid
        // UTF-8 has been replaced with the valid UTF-8 replacement character.
        // https://github.com/posit-dev/positron/issues/2698
        let vmax = vmaxget();
        let x = Rf_translateCharUTF8(x);
        vmaxset(vmax);

        // `const char*` -> `Cstr` wrapper -> `Cow<'static, str>` -> `String`
        let x = CStr::from_ptr(x);
        let x = x.to_string_lossy();

        x.to_string()
    }
}

pub fn pairlist_size(mut pairlist: SEXP) -> Result<isize> {
    let mut n = 0;
    unsafe {
        while pairlist != libr::R_NilValue {
            r_assert_type(pairlist, &[LISTSXP])?;

            pairlist = CDR(pairlist);
            n += 1;
        }
    }
    Ok(n)
}

pub fn r_vec_is_single_dimension_with_single_value(value: SEXP) -> bool {
    r_dim(value) == r_null() && r_length(value) == 1
}

pub fn r_vec_type(value: SEXP) -> String {
    match r_typeof(value) {
        INTSXP => unsafe {
            if r_inherits(value, "factor") {
                let levels = Rf_getAttrib(value, R_LevelsSymbol);
                format!("fct({})", Rf_xlength(levels))
            } else {
                String::from("int")
            }
        },
        REALSXP => String::from("dbl"),
        LGLSXP => String::from("lgl"),
        STRSXP => String::from("str"),
        RAWSXP => String::from("raw"),
        CPLXSXP => String::from("cplx"),

        // TODO: this should not happen
        _ => String::from("???"),
    }
}

pub fn r_vec_shape(value: SEXP) -> String {
    unsafe {
        let dim = RObject::new(Rf_getAttrib(value, R_DimSymbol));

        if r_is_null(*dim) {
            format!("{}", Rf_xlength(value))
        } else {
            let dim = IntegerVector::new_unchecked(*dim);
            dim.iter().map(|d| d.unwrap()).join(", ")
        }
    }
}

pub fn r_altrep_class(object: SEXP) -> String {
    let serialized_klass = unsafe { ATTRIB(ALTREP_CLASS(object)) };

    let klass = RSymbol::new_unchecked(unsafe { CAR(serialized_klass) });
    let pkg = RSymbol::new_unchecked(unsafe { CADR(serialized_klass) });

    format!("{}::{}", pkg, klass)
}

pub fn r_typeof(object: SEXP) -> u32 {
    // SAFETY: The type of an R object is typically considered constant,
    // and TYPEOF merely queries the R type directly from the SEXPREC struct.
    unsafe { TYPEOF(object) as u32 }
}

pub fn r_type2char<T: Into<u32>>(kind: T) -> String {
    unsafe {
        let kind = Rf_type2char(kind.into());
        let cstr = CStr::from_ptr(kind);
        cstr.to_str().unwrap().to_string()
    }
}

pub fn r_inherits(object: SEXP, class: &str) -> bool {
    let class = CString::new(class).unwrap();
    unsafe { libr::Rf_inherits(object, class.as_ptr()) != 0 }
}

pub fn r_is_function(object: SEXP) -> bool {
    matches!(r_typeof(object), CLOSXP | BUILTINSXP | SPECIALSXP)
}

pub fn r_formals(object: SEXP) -> Result<Vec<RArgument>> {
    // convert primitive functions into equivalent closures
    let mut object = RObject::new(object);
    if r_typeof(*object) == BUILTINSXP || r_typeof(*object) == SPECIALSXP {
        object = RFunction::new("base", "args").add(*object).call()?;
        if r_typeof(*object) != CLOSXP {
            return Ok(Vec::new());
        }
    }

    // validate we have a closure now
    r_assert_type(*object, &[CLOSXP])?;

    // get the formals
    let mut formals = fn_formals(*object);

    // iterate through the entries
    let mut arguments = Vec::new();

    unsafe {
        while formals != r_null() {
            let name = RObject::from(TAG(formals)).to::<String>()?;
            let value = CAR(formals);
            arguments.push(RArgument::new(name.as_str(), RObject::new(value)));
            formals = CDR(formals);
        }
    }

    Ok(arguments)
}

pub fn r_envir_name(envir: SEXP) -> Result<String> {
    r_assert_type(envir, &[ENVSXP])?;

    if r_env_is_pkg_env(envir) {
        let name = RObject::from(r_pkg_env_name(envir));
        return name.to::<String>();
    }

    if r_env_is_ns_env(envir) {
        let name = RObject::from(r_ns_env_name(envir));
        return name.to::<String>();
    }

    let name = unsafe { Rf_getAttrib(envir, r_symbol!("name")) };
    if r_typeof(name) == STRSXP {
        let name = RObject::view(name).to::<String>()?;
        return Ok(name);
    }

    Ok(format!("{:p}", envir))
}

pub fn r_envir_get(symbol: &str, envir: SEXP) -> Option<SEXP> {
    unsafe {
        let value = Rf_findVar(r_symbol!(symbol), envir);

        if value == R_UnboundValue {
            None
        } else {
            Some(value)
        }
    }
}

pub fn r_envir_set(symbol: &str, value: SEXP, envir: SEXP) {
    unsafe { Rf_defineVar(r_symbol!(symbol), value, envir) };
}

pub fn r_envir_remove(symbol: &str, envir: SEXP) {
    unsafe { R_removeVarFromFrame(r_symbol!(symbol), envir) };
}

/// Get names of a vector
///
/// `r_names2()` always returns a character vector, even when the object does
/// not have a `names` attribute. When there are no `names`, a vector of empty
/// names is returned. Missing names are standardized to `""`.
///
/// Note that it does not use S3 dispatch for length or names.
pub fn r_names2(x: SEXP) -> SEXP {
    let mut protect = RProtect::new();

    let size = r_length(x);

    let names = unsafe { Rf_getAttrib(x, R_NamesSymbol) };
    protect.add(names);

    if r_is_null(names) {
        // Comes initialized with `""`.
        return r_alloc_character(size);
    }

    if r_typeof(names) != STRSXP {
        log::error!("`names` attribute was neither a character vector nor `NULL`.");
        return r_alloc_character(size);
    }

    let mut needs_renaming = false;

    for i in 0..size {
        let elt = r_chr_get(names, i);

        if elt == r_str_na() {
            needs_renaming = true;
            break;
        }
    }

    if !needs_renaming {
        return names;
    }

    let out = r_alloc_character(size);
    protect.add(out);

    for i in 0..size {
        let elt = r_chr_get(names, i);

        if elt == r_str_na() {
            r_chr_poke(out, i, r_str_blank());
        } else {
            r_chr_poke(out, i, elt);
        }
    }

    out
}

pub fn r_stringify(object: SEXP, delimiter: &str) -> Result<String> {
    // handle SYMSXPs upfront
    if r_typeof(object) == SYMSXP {
        return RObject::view(object).to::<String>();
    }

    // call format on the object
    let object = RFunction::new("base", "format")
        .add(r_expr_quote(object))
        .call()?;

    // paste into a single string
    let object = RFunction::new("base", "paste")
        .add(object)
        .param("collapse", delimiter)
        .call()?
        .to::<String>()?;

    Ok(object)
}

pub fn r_inspect(object: SEXP) {
    unsafe {
        let mut protect = RProtect::new();
        let inspect = protect.add(Rf_lang2(r_symbol!("inspect"), object));
        let internal = protect.add(Rf_lang2(r_symbol!(".Internal"), inspect));
        Rf_eval(internal, R_BaseEnv);
    }
}

pub fn r_is_promise(x: SEXP) -> bool {
    r_typeof(x) == PROMSXP
}

pub fn r_promise_is_forced(x: SEXP) -> bool {
    unsafe { PRVALUE(x) != R_UnboundValue }
}

pub fn r_promise_value(x: SEXP) -> SEXP {
    unsafe { PRVALUE(x) }
}

pub fn r_promise_expr(x: SEXP) -> SEXP {
    // Like `PRCODE()`, but also handles bytecode expressions
    unsafe { R_PromiseExpr(x) }
}

pub fn r_promise_force(x: SEXP) -> harp::Result<RObject> {
    // Expect that the promise protects its own result
    harp::try_eval(x, unsafe { R_EmptyEnv })
}

pub fn r_promise_force_with_rollback(x: SEXP) -> harp::Result<RObject> {
    // Like `r_promise_force()`, but if evaluation results in an error
    // then the original promise is untouched, i.e. `PRSEEN` isn't modified,
    // avoiding `"restarting interrupted promise evaluation"` warnings.
    unsafe {
        let out = harp::try_eval(PRCODE(x), PRENV(x))?;
        SET_PRVALUE(x, out.sexp);
        Ok(out)
    }
}

pub fn r_promise_is_lazy_load_binding(x: SEXP) -> bool {
    // `rlang:::promise_expr("across", asNamespace("dplyr"))`
    // returns:
    // `lazyLoadDBfetch(c(105202L, 4670L), datafile, compressed, envhook)`
    // We can take advantage of this to identify promises in namespaces
    // that correspond to symbols we should evaluate when generating completions.

    let expr = unsafe { PRCODE(x) };

    if r_typeof(expr) != LANGSXP {
        return false;
    }

    if unsafe { Rf_xlength(expr) } == 0 {
        return false;
    }

    let expr = unsafe { CAR(expr) };

    if r_typeof(expr) != SYMSXP {
        return false;
    }

    expr == r_symbol!("lazyLoadDBfetch")
}

pub fn r_bytecode_expr(x: SEXP) -> SEXP {
    unsafe { R_BytecodeExpr(x) }
}

pub fn r_env_names(env: SEXP) -> SEXP {
    // `all = true`, `sorted = false`
    unsafe { R_lsInternal3(env, Rboolean_TRUE, Rboolean_FALSE) }
}

pub fn r_env_has(env: SEXP, sym: SEXP) -> bool {
    unsafe { libr::R_existsVarInFrame(env, sym) == libr::Rboolean_TRUE }
}

/// Check if a symbol is an active binding in an environment
///
/// Returns:
/// - `Err` if `sym` doesn't exist in the `env`
/// - `Ok(true)` if `sym` exists in the `env` and is an active binding
/// - `Ok(false)` if `sym` exists in the `env` and is not an active binding
pub fn r_env_binding_is_active(env: SEXP, sym: SEXP) -> harp::Result<bool> {
    // `R_BindingIsActive()` will throw an error if the `env` doesn't contain
    // the symbol in question, which would be quite bad for us, so we are extra
    // careful with how we expose this.
    if !r_env_has(env, sym) {
        let name = RSymbol::new(sym)?.to_string();
        Err(harp::Error::MissingBindingError { name })
    } else {
        Ok(unsafe { R_BindingIsActive(sym, env) == Rboolean_TRUE })
    }
}

pub fn r_env_is_pkg_env(env: SEXP) -> bool {
    unsafe { R_IsPackageEnv(env) == Rboolean_TRUE || env == R_BaseEnv }
}

pub fn r_pkg_env_name(env: SEXP) -> SEXP {
    unsafe {
        if env == R_BaseEnv {
            // `R_BaseEnv` is not handled by `R_PackageEnvName()`, but most of the time we want to
            // treat it like a package namespace
            return r_char!("base");
        }

        let name = R_PackageEnvName(env);

        if name == libr::R_NilValue {
            // Should be very unlikely, but `NULL` can be returned
            return r_char!("");
        }

        STRING_ELT(name, 0)
    }
}

pub fn r_env_is_ns_env(env: SEXP) -> bool {
    // Does handle `R_BaseNamespace`
    // https://github.com/wch/r-source/blob/1cb35ff692d3eb3ab546e0db4761102b5ea4ac89/src/main/envir.c#L3689
    unsafe { R_IsNamespaceEnv(env) == Rboolean_TRUE }
}

pub fn r_ns_env_name(env: SEXP) -> SEXP {
    // Does handle `R_BaseNamespace`
    // https://github.com/wch/r-source/blob/1cb35ff692d3eb3ab546e0db4761102b5ea4ac89/src/main/envir.c#L3720
    unsafe {
        let mut protect = RProtect::new();

        let spec = protect.add(R_NamespaceEnvSpec(env));

        if spec == libr::R_NilValue {
            // Should be very unlikely, but `NULL` can be returned
            return r_char!("");
        }

        STRING_ELT(spec, 0)
    }
}

/// Returns `true` if `f` returns `true` for any node of the pairlist
pub fn r_pairlist_any<F>(x: SEXP, f: F) -> bool
where
    F: Fn(SEXP) -> bool,
{
    let mut node = x;

    while node != r_null() {
        let elt = r_node_car(node);

        if f(elt) {
            return true;
        }

        node = r_node_cdr(node);
    }

    false
}

// Note this might throw if wrong data types are passed in. The C-level
// implementation of `options()` type-checks some base options.
pub fn r_poke_option(sym: SEXP, value: SEXP) -> SEXP {
    unsafe {
        let mut protect = RProtect::new();

        let call = r_lang!(r_symbol!("options"), !!sym = value);
        protect.add(call);

        // `options()` is guaranteed by R to return a list
        VECTOR_ELT(Rf_eval(call, R_BaseEnv), 0)
    }
}

pub fn r_normalize_path(x: RObject) -> anyhow::Result<String> {
    if !r_is_string(x.sexp) {
        anyhow::bail!("Expected string for srcfile's filename");
    }
    let path = RFunction::new("base", "normalizePath")
        .param("path", x)
        .param("winslash", "/")
        .param("mustWork", false)
        .call()?
        .to::<String>()?;
    Ok(path)
}

pub fn save_rds(x: SEXP, path: &str) {
    let path = RObject::from(path);

    let env = Environment::new(harp::parse_eval_base("new.env()").unwrap());
    let x = RObject::from(x);
    env.bind("x".into(), &x);
    env.bind("path".into(), &path);

    let res = harp::parse_eval0("base::saveRDS(x, path)", env);

    // This is meant for internal use so report errors loudly
    res.unwrap();
}

/// Meant for debugging inside lldb. Since we can't call C functions reliably
/// (let me know if you find a way), Inserting `push_rds()` in your code lets
/// you save objects that you can then inspect from R.
///
/// The objects are pushed to a data frame with newer entries preserved in
/// earlier rows, with a datetime and optional context attached.
///
/// If `path` is empty, saves RDS in the path stored in the
/// `RUST_PUSH_RDS_PATH` environment variable.
pub fn push_rds(x: SEXP, path: &str, context: &str) {
    let path = if path.is_empty() {
        RObject::null()
    } else {
        RObject::from(path)
    };
    let context = RObject::from(context);

    let env = Environment::new(harp::parse_eval_base("new.env()").unwrap());

    let x = RObject::from(x);
    env.bind("x".into(), &x);
    env.bind("path".into(), &path);
    env.bind("context".into(), &context);

    let res = harp::parse_eval0(".ps.internal(push_rds(x, path, context))", env);

    // This is meant for internal use so report errors loudly
    res.unwrap();
}

pub fn r_print(x: impl Into<SEXP>) {
    unsafe {
        Rf_PrintValue(x.into());
    }
}

pub fn r_printf(x: &str) {
    let c_str = std::ffi::CString::new(x).unwrap();
    unsafe {
        libr::Rprintf(c_str.as_ptr());
    }
}

pub fn r_format_vec(x: SEXP) -> Result<SEXP> {
    unsafe {
        let out = RFunction::new("", "harp_format_vec")
            .add(x)
            .call_in(HARP_ENV.unwrap())?;
        Ok(out.sexp)
    }
}

pub fn r_format_s4(x: SEXP) -> Result<SEXP> {
    if !r_is_s4(x) {
        return Err(Error::UnexpectedType(r_typeof(x), vec![S4SXP]));
    }

    let out = RFunction::new("", "harp_format_s4")
        .add(x)
        .call_in(unsafe { HARP_ENV.unwrap() })?;
    Ok(out.sexp)
}

pub fn r_subset_vec(x: SEXP, indices: Vec<i64>) -> Result<SEXP> {
    let env = unsafe { HARP_ENV.unwrap() };
    let indices: Vec<i64> = indices.into_iter().map(|i| i + 1).collect();
    let out = RFunction::new("", "harp_subset_vec")
        .add(x)
        .add(&indices)
        .call_in(env)?;
    Ok(out.sexp)
}

#[cfg(test)]
mod tests {
    use libr::STRING_ELT;

    use crate::environment::R_ENVS;
    use crate::exec::RFunction;
    use crate::exec::RFunctionExt;
    use crate::r_str_to_owned_utf8_unchecked;

    #[test]
    fn test_r_str_to_utf8_replaces_invalid_utf8() {
        crate::r_task(|| {
            let env = RFunction::new("base", "new.env")
                .param("parent", R_ENVS.base)
                .call()
                .unwrap();

            // Constructs "\xa0" in such a way that it wrongly gets a UTF-8
            // encoding. This ends up bypassing translation in
            // `Rf_translateCharUTF8()`, so we end up replacing the invalid
            // UTF-8 with the `REPLACEMENT_CHARACTER`. This can also occur
            // when it gets an "unknown" encoding on an OS where the native
            // encoding is UTF-8.
            // https://github.com/posit-dev/positron/issues/2698
            let code = "
                x <- intToUtf8(0xa0)
                x <- iconv(x, from = 'UTF-8', to = 'latin1')
                Encoding(x) <- 'UTF-8'
                x
            ";

            let x = harp::parse_eval0(code, env).unwrap();
            let x = unsafe { STRING_ELT(x.sexp, 0) };
            let x = r_str_to_owned_utf8_unchecked(x);

            assert_eq!(x, String::from(std::char::REPLACEMENT_CHARACTER));
        })
    }
}
