#include "rlang.h"
#include "decl/env-decl.h"

r_obj* rlang_ns_env;

r_obj* r_ns_env(const char* pkg) {
    r_obj* pkg_str = KEEP(r_chr(pkg));
    r_obj* ns = R_FindNamespace(pkg_str);
    FREE(1);
    return ns;
}

r_obj* r_base_ns_get(const char* name) {
    return r_env_get(r_envs.base, r_sym(name));
}
r_obj* rlang_ns_get(const char* name) {
    return r_env_get(rlang_ns_env, r_sym(name));
}

r_obj* r_alloc_environment(r_ssize size, r_obj* parent) {
#if R_VERSION < R_Version(4, 1, 0)
    parent = parent ? parent : r_envs.empty;
    r_node_poke_car(new_env__parent_node, parent);

    size = size ? size : 29;
    r_node_poke_car(new_env__size_node, r_int(size));

    r_obj* env = r_eval(new_env_call, r_envs.base);

    // Free for gc
    r_node_poke_car(new_env__parent_node, r_null);

    return env;
#else
    const int hash = 1;
    return R_NewEnv(parent, hash, size);
#endif
}

r_obj* r_env_as_list(r_obj* env) {
    return eval_with_x(env2list_call, env);
}

r_obj* r_env_clone(r_obj* env, r_obj* parent) {
    if (parent == NULL) {
        parent = r_env_parent(env);
    }

    // This better reproduces the behaviour of `list2env()` which in
    // turn affects how bindings are stored in the hash table and the
    // default sort of the character vector generated by `names()`.
    size_t size = R_MAX(r_length(env), 29);

    r_obj* out = KEEP(r_alloc_environment(size, parent));
    r_env_coalesce(out, env);

    FREE(1);
    return out;
}

void r_env_coalesce(r_obj* env, r_obj* from) {
    r_obj* syms = KEEP(r_env_syms(from));
    r_obj* types = KEEP(r_env_binding_types(from, syms));

    if (types == r_null) {
        env_coalesce_plain(env, from, syms);
        FREE(2);
        return;
    }

    r_ssize n = r_length(syms);
    r_obj* const* v_syms = r_list_cbegin(syms);
    enum r_env_binding_type* v_types =
        (enum r_env_binding_type*) r_int_begin(types);

    for (r_ssize i = 0; i < n; ++i) {
        r_obj* sym = v_syms[i];

        if (r_env_has(env, sym)) {
            continue;
        }

        switch (v_types[i]) {
        case R_ENV_BINDING_TYPE_unbound:
            break;

        case R_ENV_BINDING_TYPE_value:
            r_env_bind(env, sym, KEEP(r_env_get(from, sym)));
            FREE(1);
            break;

        case R_ENV_BINDING_TYPE_delayed:
            r_env_bind_delayed(
                env,
                sym,
                KEEP(r_env_binding_delayed_expr(from, sym)),
                KEEP(r_env_binding_delayed_env(from, sym))
            );
            FREE(2);
            break;

        case R_ENV_BINDING_TYPE_forced:
            r_env_bind_forced(
                env,
                sym,
                KEEP(r_env_binding_forced_expr(from, sym)),
                KEEP(r_env_get(from, sym))
            );
            FREE(2);
            break;

        case R_ENV_BINDING_TYPE_missing:
            r_env_bind_missing(env, sym);
            break;

        case R_ENV_BINDING_TYPE_active:
            r_env_bind_active(
                env,
                sym,
                KEEP(r_env_binding_active_fn(from, sym))
            );
            FREE(1);
            break;
        }
    }

    FREE(2);
    return;
}

static void env_coalesce_plain(r_obj* env, r_obj* from, r_obj* syms) {
    r_ssize n = r_length(syms);
    r_obj* const* v_syms = r_list_cbegin(syms);

    for (r_ssize i = 0; i < n; ++i) {
        r_obj* sym = v_syms[i];

        if (r_env_has(env, sym)) {
            continue;
        }

        r_env_bind(env, sym, KEEP(r_env_get(from, sym)));
        FREE(1);
    }

    return;
}

r_obj* r_list_as_environment(r_obj* x, r_obj* parent) {
    parent = parent ? parent : r_envs.empty;
    return eval_with_xy(list2env_call, x, parent);
}

#if RLANG_USE_R_EXISTS
bool r__env_has(r_obj* env, r_obj* sym) {
    // `exists("")` errors on older R
    if (sym == R_MissingArg) {
        return Rf_findVarInFrame3(env, sym, FALSE) != R_UnboundValue;
    }
    r_obj* nm = KEEP(r_sym_as_utf8_character(sym));
    r_obj* out = eval_with_xyz(exists_call, env, nm, r_false);
    FREE(1);
    return r_as_bool(out);
}

bool r__env_has_anywhere(r_obj* env, r_obj* sym) {
    // `exists("")` errors on older R
    if (sym == R_MissingArg) {
        return Rf_findVar(sym, env) != R_UnboundValue;
    }
    r_obj* nm = KEEP(r_sym_as_utf8_character(sym));
    r_obj* out = eval_with_xyz(exists_call, env, nm, r_true);
    FREE(1);
    return r_as_bool(out);
}
#endif

bool r_env_inherits(r_obj* env, r_obj* ancestor, r_obj* top) {
    top = top ? top : r_envs.empty;

    if (r_typeof(env) != R_TYPE_environment) {
        r_abort("`env` must be an environment");
    }
    if (r_typeof(ancestor) != R_TYPE_environment) {
        r_abort("`ancestor` must be an environment");
    }
    if (r_typeof(top) != R_TYPE_environment) {
        r_abort("`top` must be an environment");
    }

    if (env == r_envs.empty) {
        return false;
    }

    while (env != top && env != r_envs.empty) {
        if (env == ancestor) {
            return true;
        }
        env = r_env_parent(env);
    }

    return env == ancestor;
}

r_obj* r_env_until(r_obj* env, r_obj* sym, r_obj* last) {
    r_obj* stop = r_envs.empty;
    if (last != r_envs.empty) {
        stop = r_env_parent(last);
    }

    while (true) {
        if (env == r_envs.empty) {
            return r_envs.empty;
        }
        if (r_env_has(env, sym)) {
            return env;
        }

        r_obj* next = r_env_parent(env);
        if (next == r_envs.empty || next == stop) {
            return r_envs.empty;
        }

        env = next;
    }
}

r_obj* r_env_get_anywhere(r_obj* env, r_obj* sym) {
    env = r_env_until(env, sym, r_envs.empty);
    return r_env_get(env, sym);
}

r_obj* r_env_get_until(r_obj* env, r_obj* sym, r_obj* last) {
    env = r_env_until(env, sym, last);
    return r_env_get(env, sym);
}

bool r_env_has_until(r_obj* env, r_obj* sym, r_obj* last) {
    env = r_env_until(env, sym, last);
    return r_env_has(env, sym);
}

bool r_env_has_missing(r_obj* env, r_obj* sym) {
    // That's a special primitive so no need to protect `sym`
    r_obj* call = KEEP(r_call2(missing_prim, sym));
    r_obj* out = r_eval(call, env);
    FREE(1);
    return r_as_bool(out);
}

void r_init_rlang_ns_env(void) {
    rlang_ns_env = r_ns_env("rlang");
}

void r_init_library_env(void) {
#if R_VERSION < R_Version(4, 1, 0)
    new_env_call =
        r_parse_eval("as.call(list(new.env, TRUE, NULL, NULL))", r_envs.base);
    r_preserve(new_env_call);

    new_env__parent_node = r_node_cddr(new_env_call);
    new_env__size_node = r_node_cdr(new_env__parent_node);
#endif

    missing_prim = r_parse_eval("missing", r_envs.base);

    env2list_call = r_parse("as.list.environment(x, all.names = TRUE)");
    r_preserve(env2list_call);

    list2env_call =
        r_parse("list2env(x, envir = NULL, parent = y, hash = TRUE)");
    r_preserve(list2env_call);

    exists_call = r_parse("exists(y, envir = x, inherits = z)");
    r_preserve(exists_call);

    remove_call = r_parse("remove(list = y, envir = x, inherits = z)");
    r_preserve(remove_call);

    r_methods_ns_env = r_parse_eval("asNamespace('methods')", r_envs.base);
}

r_obj* rlang_ns_env = NULL;
r_obj* r_methods_ns_env = NULL;

#if R_VERSION < R_Version(4, 1, 0)
static r_obj* new_env_call = NULL;

static r_obj* new_env__parent_node = NULL;

static r_obj* new_env__size_node = NULL;
#endif

static r_obj* exists_call = NULL;

static r_obj* remove_call = NULL;

static r_obj* env2list_call = NULL;

static r_obj* list2env_call = NULL;

static r_obj* missing_prim = NULL;
