#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;
