# Take parsed R code (anything returnable by base::str2lang()) and returns
# a Fortran object, which is a string of Fortran code and some attributes
# describing the value.
lang2fortran <- r2f <- function(e, scope = NULL, ..., calls = character(), hoist = NULL) {
  ## 'hoist()' is a function that individual handlers can call to pre-emit some
  ## Fortran code. E.g., to setup a temporary variable if the generated Fortran
  ## code doesn't neatly translate into a single expression.
  hoisted <- character()
  if (is.null(hoist)) {
    delayedAssign("hoist_connection", textConnection("hoisted", "w", TRUE))
    hoist <- function(...) {
      writeLines(as.character(unlist(c(character(), ...))),
                 hoist_connection)
    }
  # if performance with textConnection() becomes an issue, maybe switch to an
  # anonymous file(), though, each hoisting context is typically shortlived and
  # usually 0 lines are hoisted per context, and if they are hoisted, a small number.
  }

  fortran <- switch(typeof(e),
      language = {
        # a call
        handler <- get_r2f_handler(callable <- e[[1L]])

        match.fun <- attr(handler, "match.fun", TRUE)
        if (is.null(match.fun)) {
          match.fun <- get0(callable, parent.env(globalenv()),
                            mode = "function")
          # this is a best effort to, eg. resolve `seq.default` from `seq`.
          # This should likely be moved into attaching the `match.fun` attr
          # to handlers, for more involved resolution (e.g., with getS3Method())
          if ("UseMethod" %in% all.names(body(match.fun)))
            match.fun <- get0(paste0(callable, ".default"),
                              parent.env(globalenv()),
                              mode = "function",
                              ifnotfound = match.fun)
        }
        if (typeof(match.fun) == "closure") {
          e <- match.call(match.fun, e)
        }

        if (isTRUE(getOption("quickr.r2f.debug"))) {

          try(handler(as.list(e)[-1L], scope, ...,
                      calls = c(calls, as.character(callable)),
                      hoist = hoist)) -> res
          if (inherits(res, "try-error")) {
            debugonce(handler)
            handler(as.list(e)[-1L], scope, ...,
                    calls = c(calls, as.character(callable)),
                    hoist = hoist)
          }

          res

        } else {

          handler(as.list(e)[-1L], scope, ...,
                  calls = c(calls, as.character(callable)),
                  hoist = hoist)

        }

      },

      integer = ,
      double = ,
      complex = ,
      logical =  atomic2Fortran(e),

      symbol = {
        s <- as.character(e)
        # logicals that come in from R are passed as integer types,
        # so for all fortran ops we cast to logical with /=0
        if (
          !is.null(scope[[e]] -> val) &&
            val@mode == "logical" &&
            val@is_external
        ) {
          s <- paste0("(", s, "/=0)")
        }
        Fortran(s, value = scope[[e]])
      },

      ## handling 'object' and 'closure' here are both bad ideas,
      ## TODO: delete both
      # "object" = {
      #   if (inherits(e, Variable))
      #     e <- Fortran(character(), e)
      #   stopifnot(inherits(e, Fortran))
      #   e
      # },

      closure = {
        if (is.null(name <- attr(e, "name", TRUE))) {
          name <- if (is.symbol(name <- substitute(e)))
            as.character(name)
          else
            "anonymous_function"
        }

        stopifnot(is.null(scope))
        new_fortran_subroutine(name, e)
      },

      ## all the other typeof() possible values
      # "character",
      # "raw" ,
      # "list",
      # "NULL",
      # "function",
      # "special",
      # "builtin",
      # "environment",
      # "S4",
      # "pairlist",
      # "promise",
      # "char",
      # "...",
      # "any",
      # "expression",
      # "externalptr",
      # "bytecode",
      # "weakref"
      # default
      stop("Unsupported object type encountered: ", typeof(e))
    )

  if (length(hoisted)) {
    combined <- str_flatten_lines(c(hoisted, fortran))
    attributes(combined) <- attributes(fortran)
    fortran <- combined
  }

  attr(fortran, "r") <- e
  fortran
}

atomic2Fortran <- function(x) {
  stopifnot(is_scalar_atomic(x))
  s <- switch(typeof(x),
              double =,
              integer = num2fortran(x),
              logical = if (x) ".true." else ".false.",
              complex = sprintf("(%s, %s)", num2fortran(Re(x)), num2fortran(Im(x))))
  Fortran(s, Variable(typeof(x)))
}

num2fortran <- function(x) {
  stopifnot(typeof(x) %in% c("integer", "double"))
  digits <- 7L
  nsmall <- switch(typeof(x), integer = 0L, double = 1L)
  repeat {
    s <- format.default(x, digits = digits, nsmall = nsmall, scientific = 1L)
    if (x == eval(str2lang(s))) # eval() needed for negative and complex numbers
      break
    add(digits) <- 1L
    if (digits > 22L)
      stop("number formatting error: ", x, " formatted as : ", s)
  }
  paste0(s, switch(typeof(x), double = "_c_double", integer = "_c_int"))
}

r2f_handlers := new.env(parent = emptyenv())

get_r2f_handler <- function(name) {
  stopifnot("All functions called must be named as symbols" = is.symbol(name))
  get0(name, r2f_handlers) %||% stop("Unsupported function: ", name, call. = FALSE)
}

r2f_default_handler <- function(args, scope = NULL, ..., calls) {
  # stopifnot(is.call(e), is.symbol(e[[1L]]))

  x <- lapply(args, r2f, scope = scope, calls = calls, ...)
  s <- sprintf("%s(%s)", last(calls), str_flatten_commas(x[-1]))
  Fortran(s)
}

## ??? export as S7::convert() methods?
register_r2f_handler <- function(name, fun) {
  stopifnot(
    is_string(name),
    identical(formals(fun), alist(x = , scope = NULL))
  )

  r2f_handlers[[name]] <- fun
}

.r2f_handler_not_implemented_yet <- function(e, scope, ...) {
  stop(gettextf("'%s' is not implemented yet", as.character(e[[1L]])),
       call. = FALSE)
}

r2f_handlers[["declare"]] <- function(args, scope, ...) {

  for (a in args) {
    if (is_missing(a)) {
      next
    }
    if (is_type_call(a)) {
      var <- type_call_to_var(a)
      var@is_arg <- var@name %in% names(formals(scope@closure))
      scope[[var@name]] <- var
    } else if (is_call(a, quote(`{`))) {
      Recall(as.list(a)[-1], scope)
    }
  }

  Fortran("")
}

r2f_handlers[["Fortran"]] <- function(args, scope = NULL, ...) {
  if (!is_string(args[[1]]))
    stop("Fortran() must be called with a string")
  Fortran(args[[1]])
  # enable passing through literal fortran code
  # used like:
  #   Fortran("nearest(x, 1)", double(length(x)))
  #   Fortran("nearest(x, 1)", x)
  #   Fortran("x = nearest(x, 1)")
}

r2f_handlers[["("]] <- function(args, scope, ...) {
  r2f(args[[1L]], scope, ...)
}

r2f_handlers[["{"]] <- function(args, scope, ..., hoist = NULL) {
  # every top level R-expr / fortran statement gets its own hoist target.
  x <- lapply(args, r2f, scope, ...)
  code <- str_flatten_lines(x)

  # browser()
  value <- (if (length(args)) last(x)@value) %||% Variable()
  Fortran(code, value)
}

# ---- reduction intrinsics ----

create_mask_hoist <- function() {
  .hoisted_mask <- NULL

  try_set <- function(mask) {
    stopifnot(inherits(mask, Fortran), mask@value@mode == "logical")
    # each hoist can only accept one mask.
    if (is.null(.hoisted_mask)) {
      .hoisted_mask <<- mask
      return(TRUE)
    }
    # if the mask is identical, we accept it.
    if (identical(.hoisted_mask, mask)) {
      return(TRUE)
    }
    # can't hoist this mask.
    FALSE
  }

  get_hoisted <- function() .hoisted_mask

  environment()
}

r2f_handlers[["max"]] <-
r2f_handlers[["min"]] <-
r2f_handlers[["sum"]] <-
r2f_handlers[["prod"]] <- function(args, scope, ...) {
  intrinsic <- switch(last(list(...)$calls),
                      max = "maxval",
                      min = "minval",
                      sum = "sum",
                      prod = "product")

  reduce_arg <- function(arg) {
    mask_hoist <- create_mask_hoist()
    x <- r2f(arg, scope, ..., hoist_mask = mask_hoist$try_set)
    if(x@value@rank == 0)
      return(x)
    hoisted_mask <- mask_hoist$get_hoisted()
    s <- glue(
      if (is.null(hoisted_mask))
        "{intrinsic}({x})"
      else
        "{intrinsic}({x}, mask = {hoisted_mask})"
    )
    Fortran(s, Variable(x@value@mode))
  }

  if (length(args) == 1) {
    reduce_arg(args[[1]])
  } else {
    args <- lapply(args, reduce_arg)
    mode <- reduce_promoted_mode(args)
    s <- switch(last(list(...)$calls),
      max = glue("max({str_flatten_commas(args)})"),
      min = glue("min({str_flatten_commas(args)})"),
      sum = glue("({str_flatten(args, ' + ')})"),
      prod = glue("({str_flatten(args, ' * ')})")
    )
    Fortran(s, Variable(mode))
  }
}

r2f_handlers[["which.max"]] <-
r2f_handlers[["which.min"]] <-
function(args, scope = NULL, ...) {
  stopifnot(length(args) == 1)
  x <- r2f(args[[1L]], scope, ...)
  stopifnot("Values passed to which.max()/which.min() must be 1d arrays" = x@value@rank == 1)
  valout <- Variable(mode = "integer") # integer scalar

  if (x@value@mode == "logical") {
    val <- switch(last(list(...)$calls),
                  which.max = ".true.",
                  which.min = ".false.")
    f <- glue("findloc({x}, {val}, 1)")
  } else {
    intrinsic <- switch(last(list(...)$calls),
                        which.max = "maxloc",
                        which.min = "minloc")
    f <- glue("{intrinsic}({x}, 1)")
  }

  Fortran(f, valout)
}

r2f_handlers[["["]] <-

r2f_handlers[[":"]] <- function(args, scope, ...) {
  # depending on context, this translation can vary.

  # x[a:b]    becomes   x(a:b)
  # for(i in a:b){}  becomes  do i = a,b ...
  # c(a:b)  becomes  ({tmp}, {tmp}=a,b)
  args <- whole_doubles_to_ints(args)
  .[start, end] <- lapply(args, r2f, scope, ...)
  step <- glue("sign(1, {end}-{start})")
  val <- Variable("integer", NA)
  fr <- switch(
    list(...)$calls |> drop_last() |> last(),
    "[" = glue("{start}:{end}:{step}"),
    "for" = glue("{start}, {end}, {step}"),
    {
      i <- scope@get_unique_var("integer")
      glue("[ ({i}, {i} = {start}, {end}, {step}) ]")
    }
    # default
  )
  Fortran(fr, val)
}

r2f_handlers[["seq"]] <- function(args, scope, ...) {
  args <- whole_doubles_to_ints(args) # only casts if trunc(dbl) == dbl
  if (!is.null(args$length.out) || !is.null(args$along.with)) {
    stop("seq(length.out=, along.with=) not implemented yet")
  }

  .[from, to, by] <- lapply(args, r2f, scope, ...)[c("from", "to", "by")]
  by <- by %||% Fortran(glue("sign(1, {to}-{from})"), Variable("integer"))

  # Fortran only supports integer sequences in do and implicit do contexts.
  # to make a double sequence, needs to be in via an implied map() call, like
  # seq(1, 10, .1) ->    [(x * 0.1, x = 10, 50)]
  #
  # e.g., i <- scope@get_unique_var("integer")
  # glue("[({i} * by, {i} = int(from/by), int(to/by))]")
  if (from@value@mode != "integer" ||
     to@value@mode != "integer" ||
     by@value@mode != "integer")
    stop("non-integer seq()'s not implemented yet.")

  # depending on context, this translation can vary.
  #
  # x[a:b]    becomes   x(a:b)
  # for(i in a:b){}  becomes  do i = a,b ...
  # c(a:b)  becomes  ({tmp}, {tmp}=a,b)
  val <- Variable("integer", NA)
  fr <- switch(
    list(...)$calls |> drop_last() |> last(),
    "[" = glue("{from}:{to}:{by}"),
    "for" = glue("{from}, {to}, {by}"),
    {
      i <- scope@get_unique_var("integer")
      glue("[ ({i}, {i} = {from}, {to}, {by}) ]")
    }
    # default
  )
  Fortran(fr, val)
}

r2f_handlers[["ifelse"]] <- function(args, scope, ...) {
  .[mask, tsource, fsource] <- lapply(args, r2f, scope, ...)
  # (tsource, fsource, mask)
  mode <- tsource@value@mode
  dims <- conform(mask@value, tsource@value, fsource@value)@dims
  Fortran(glue("merge({tsource}, {fsource}, {mask})"),
          Variable(mode, dims))
}

r2f_handlers[["abs"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  Fortran(glue("abs({arg})"), arg@value)
}

# ---- pure elemental unary math intrinsics ----

## real and complex intrinsics
r2f_handlers[["sin"]] <-
r2f_handlers[["cos"]] <-
r2f_handlers[["tan"]] <-
r2f_handlers[["asin"]] <-
r2f_handlers[["acos"]] <-
r2f_handlers[["atan"]] <-
r2f_handlers[["sqrt"]] <-
r2f_handlers[["exp"]] <-
r2f_handlers[["log"]] <-
r2f_handlers[["floor"]] <-
r2f_handlers[["ceiling"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  intrinsic <- last(list(...)$calls)
  Fortran(glue("{intrinsic}({arg})"), arg@value)
}

r2f_handlers[["log10"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  f <- if(arg@value@mode == "complex") {
    glue("(log({arg}) / log(10.0_c_double))")
  } else {
    glue("log10({arg})")
  }
  Fortran(f, arg@value)
}

## accepts real, integer, or complex
r2f_handlers[["abs"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  if(arg@value@mode == "complex")
    arg@value@mode <- "double"
  Fortran(glue("abs({arg})"), arg@value)
}

# ---- complex elemental unary intrinsics ----

r2f_handlers[["Re"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "double"
  Fortran(glue("real({arg})"), val)
}

r2f_handlers[["Im"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "double"
  Fortran(glue("aimag({arg})"), val)
}

# Modulus (magnitude)
r2f_handlers[["Mod"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "double"
  Fortran(glue("abs({arg})"), val)
}

# Argument (phase angle, radians)
r2f_handlers[["Arg"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "double"
  Fortran(glue("atan2(aimag({arg}), real({arg}))"), val)
}

# conjg() returns a complex value; R uses Conj()
r2f_handlers[["Conj"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  arg <- r2f(args[[1]], scope, ...)
  val <- arg@value
  val@mode <- "complex"
  Fortran(glue("conjg({arg})"), val)
}

# ---- elemental binary infix operators ----

r2f_handlers[["+"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} + {right})"), conform(left@value, right@value))
}

r2f_handlers[["-"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} - {right})"), conform(left@value, right@value))
}

r2f_handlers[["*"]] <- function(args, scope = NULL, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} * {right})"), conform(left@value, right@value))
}

r2f_handlers[["/"]] <- function(args, scope = NULL, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} / {right})"), conform(left@value, right@value))
}

r2f_handlers[["^"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  Fortran(glue("({left} ** {right})"), conform(left@value, right@value))
}

r2f_handlers[[">="]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} >= {right})"), var)
}
r2f_handlers[[">"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} > {right})"), var)
}
r2f_handlers[["<"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} < {right})"), var)
}
r2f_handlers[["<="]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} <= {right})"), var)
}
r2f_handlers[["=="]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} == {right})"), var)
}
r2f_handlers[["!="]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  var <- conform(left@value, right@value)
  var@mode <- "logical"
  Fortran(glue("({left} /= {right})"), var)
}

# ---- remainder (%%) and integer division (%/%) ----
#
# R semantics:
#   x %%  y  ==  r   where  r has the sign of y  (divisor)
#   x %/% y  ==  q   where  q = floor(x / y)
# and  x == r + y * q  (within rounding error)
#
# Fortran intrinsics:
#   - MODULO(a,p)   : remainder with sign(p)
#   - FLOOR(x)      : greatest integer ≤ x      (real)
#   - AINT(x)       : truncation toward 0       (real)

r2f_handlers[["%%"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  out_val <- conform(left@value, right@value)
  # MODULO gives result with sign(right) – matches R %% behaviour
  Fortran(glue("modulo({left}, {right})"), out_val)
}

r2f_handlers[["%/%"]] <- function(args, scope, ...) {
  .[left, right] <- lapply(args, r2f, scope, ...)
  out_val <- conform(left@value, right@value)

  expr <- switch(
    out_val@mode,
    integer = glue("int(floor(real({left}) / real({right})))"),
    double  = glue("floor({left} / {right})"),
    stop("%/% only implemented for numeric types")
  )

  Fortran(expr, out_val)
}

# TODO: the scalar || probably need some more type checking.
# TODO: gfortran supports implicit casting that of logical to integer when
# assigning a logical to a variable declared integer, converting `.true.` to `1`,
# but this is not a standard language feature, and Intel's `ifort` uses `-1` for `.true`.
# We should explicitly use
#   `merge(1_c_int, 0_c_int, <lgl>)` to cast logical to int.
r2f_handlers[["&"]] <-
r2f_handlers[["&&"]] <-
r2f_handlers[["|"]] <-
r2f_handlers[["||"]] <-
function(args, scope, ...) {
  args <- lapply(args, r2f, scope, ...)
  args <- lapply(args, function(a) {
    if (a@value@mode != "logical") {
      stop("must be logical")
    }
    a
  })
  .[left, right] <- args

  operator <- switch(last(list(...)$calls),
                     `&` = , `&&` = ".and.",
                     `|` = , `||` = ".or.")

  s <- glue("{left} {operator} {right}")
  val <- conform(left@value, right@value)
  val@mode <- "logical"
  Fortran(s, val)
}

# --- constructors  ----

r2f_handlers[["c"]] <- function(args, scope = NULL, ...) {
  ff <- lapply(args, r2f, scope, ...)
  s <- glue("[ {str_flatten_commas(ff)} ]")
  lens <- lapply(ff[order(map_int(ff, \(f) f@value@rank))], function(e) {
    rank <- e@value@rank
    if (rank == 0)
      1L
    else if (rank == 1)
      e@value@dims[[1]]
    else
      stop("all args passed to c() must be scalars or 1-d arrays")
  })
  mode <- reduce_promoted_mode(ff)
  len <- Reduce(\(l1, l2) {
    if (is_scalar_na(l1) || is_scalar_na(l2)) {
      NA
    } else if (is_wholenumber(l1) && is_wholenumber(l2)) {
      l1 + l2
    } else {
      call("+", l1, l2)
    }
  }, lens)
  Fortran(s, Variable(mode, list(len)))
}

r2f_handlers[["cbind"]] <- function(e, scope) {
  .NotYetImplemented()
  ee <- lapply(e[-1], r2f, scope)
  ncols <- lapply(ee, function(f) {
    if (f@value@rank %in% c(0, 1))
      1
    else if (f@value@rank == 2)
      f@value@dims[[2]]
  })
  ncols <- Reduce(\(a, b) call("+", a, b), ncols)
  ncols <- eval(ncols, scope@sizes)
}

r2f_handlers[["<-"]] <- function(args, scope, ...) {
  target <- args[[1]]
  if (is.call(target)) {
    # given a call like `foo(x) <- y`, dispatch to `foo<-`
    target_callable <- target[[1]]
    stopifnot(is.symbol(target_callable))
    name <- as.symbol(paste0(as.character(target_callable), "<-"))
    handler <- get_r2f_handler(name)
    return(handler(args, scope, ...)) # new hoist target
  }

  # It sure seems like it's be nice if the Fortran() constructor
  # took mode and dims as args directly,
  # without needing to go through Variable...
  stopifnot(is.symbol(target))
  name <- as.character(target)

  value <- args[[2]]
  value <- r2f(value, scope, ...)

  # immutable / copy-on-modify usage of Variable()
  if (is.null(var <- get0(name, scope))) {
    # this is a binding to a new symbol
    var <- value@value
    var@name <- name
    scope[[name]] <- var

  } else {
    # The var already exists, this assignment is a modification / reassignment
    check_assignment_compatible(var, value@value)
    var@modified <- TRUE
    # could probably drop this @modified property, and instead track
    # if the var populated by declare is identical at the end (e.g., perhaps by
    # address, or by attaching a unique id to each var, or ???)
    assign(name, var, scope)
  }

  Fortran(glue("{name} = {value}"))
}

r2f_handlers[["[<-"]] <- function(args, scope = NULL, ...) {

  # TODO: handle logical subsetting here, which must become a where a construct like:
  #   x[lgl] <- val
  # becomes
  # where (lgl)
  #   x = val
  # end where
  # ! but if {va} references {x}, it will only see the subset x, not the full {x}
  # e.g.,
  # sum(x) is not the same as `where lgl \n sum(x) \n end where`
  # ditto for ifelse() ?
  # e <- as.list(e)

  stopifnot(is_call(target <- args[[1L]], "["))
  target <- r2f(target, scope)

  value <- r2f(args[[2L]], scope)
  Fortran(glue("{target} = {value}"))
}

reduce_promoted_mode <- function(...) {

  getmode <- function(d) {
    if (inherits(d, Fortran))
      d <- d@value
    if (inherits(d, Variable))
      return(d@mode)
    if (is.list(d) && length(d))
      lapply(d, getmode)
  }
  modes <- unique(unlist(getmode(list(...))))

  if ("double" %in% modes)
    "double"
  else if ("integer" %in% modes)
    "integer"
  else if ("logical" %in% modes)
    "logical"
  else
    NULL

}

r2f_handlers[["="]] <- r2f_handlers[["<-"]]

r2f_handlers[["logical"]] <- function(args, scope, ...) {
  Fortran(".false.", Variable(mode = "logical", dims = r2dims(args, scope)))
}

r2f_handlers[["integer"]] <- function(args, scope, ...) {
  Fortran("0", Variable(mode = "integer", dims = r2dims(args, scope)))
}

r2f_handlers[["double"]] <- function(args, scope, ...) {
  Fortran("0", Variable(mode = "double", dims = r2dims(args, scope)))
}

r2f_handlers[["numeric"]] <- r2f_handlers[["double"]]

r2f_handlers[["character"]] <- r2f_handlers[["raw"]] <-
  .r2f_handler_not_implemented_yet

r2f_handlers[["matrix"]] <- function(args, scope = NULL, ...) {

  args$data %||% stop("matrix(data=) must be provided, cannot be NA")
  out <- r2f(args$data, scope, ...)
  out@value@dims <- r2dims(list(args$nrow, args$ncol), scope)
  out

  # TODO: reshape() if !passes_as_scalar(out)
}

conform <- function(..., mode = NULL) {
  var <- NULL
  # technically, types are implicit promoted, but we'll let <- handle that.
  for (var in drop_nulls(list(...))) {
    if (passes_as_scalar(var)) {
      next
    } else {
      break
    }
  }
  if (is.null(var))
    NULL
  else
    Variable(mode %||% var@mode, var@dims)
 }

# ---- printers ----

r2f_handlers[["cat"]] <- function(args, scope, ...) {
  args <- lapply(args, r2f, scope, ...)
  # can do a lot more here still, just a POC for now
  stopifnot(length(args) == 1, typeof(args[[1]]) == "character")
  label <- args[[1]]
  if (!endsWith(label, "\n"))
    stop("cat(<strings>) must end with '\n'")
  label <- substring(label, 1, nchar(label)-1)

  Fortran(glue('call labelpr("{label}", {nchar(label)})'))
}

r2f_handlers[["print"]] <- function(args, scope = NULL, ...) {
  # args <- lapply(as.list(e)[-1], r2f, scope)
  # args <- as.list(e)[-1]
  # can do alot more here still, just a POC for now
  stopifnot(length(args) == 1, typeof(args[[1]]) == "symbol")
  name <- args[[1]]
  var <- get(name, envir = scope)
  name <- as.character(name)
  if (var@mode == "logical")
    name <- sprintf("(%s/=0)", name)
  label <- ""
  # browser()
  if (passes_as_scalar(var)) {
    # } "scalar"
    # paste0(c(var@mode, scalar) collapse = "_"),
    printer <- switch(
      var@mode,
      logical = ,
      integer = "intpr1",
      double = "dblepr1",
      {print(var); stop("Unsupported type in print()")}
    )

    Fortran(glue('call {printer}("{label}", {nchar(label)}, {name})'))
  } else {
    printer <- switch(
      var@mode,
      logical = ,
      integer = "intpr",
      double = "dblepr",
      {print(var); stop("Unsupported type in print()")}
    )

    Fortran(glue('call {printer}("{label}", {nchar(label)}, {name}, size({name}))'))
  }
}

# r2f_handlers[["ifelse"]] <- function(e, scope) {
#   # TODO:
#   #   <- and [<- need to be aware of this construct for it to make sense.
#   .[test, yes, no] <- lapply(e[-1], r2f, scope)
#   Fortran(glue("where ({test}}
#                 {indent(yes)}
#                 elsewhere
#                 {indent({no})
#                 end where"))
# }

r2f_handlers[["length"]] <- function(args, scope, ...) {
  x <- r2f(args[[1]], scope, ...)
  Fortran(glue("size({x})"), Variable("integer"))
}
r2f_handlers[["nrow"]] <- function(args, scope, ...) {
  x <- r2f(args[[1]], scope, ...)
  Fortran(glue("size({x}, 1)"), Variable("integer"))
}
r2f_handlers[["ncol"]] <- function(args, scope, ...) {
  x <- r2f(args[[1]], scope, ...)
  Fortran(glue("size({x}, 2)"), Variable("integer"))
}
r2f_handlers[["dim"]] <- function(args, scope, ...) {
  x <- r2f(args[[1]], scope, ...)
  Fortran(glue("shape({x})"), Variable("integer", x@value@rank))
}

# this is just `[` handler
r2f_slice <- function(args, scope, ...) { }

# ---- control flow ----

r2f_handlers[["if"]] <- function(args, scope, ..., hoist = NULL) {
  # cond uses the current hoist context.
  cond <- r2f(args[[1]], scope, ..., hoist = hoist)

  # true and false branchs gets their own hoist target.
  true <- r2f(args[[2]], scope, ..., hoist = NULL)

  if (length(args) == 2) {
    Fortran(glue("
      if ({cond}) then
      {indent(true)}
      end if
      "))
  } else {
    false <- r2f(args[[3]], scope, ..., hoist = NULL)
    Fortran(glue("
      if ({cond}) then
      {indent(true)}
      else
      {indent(false)}
      end if
      "))
  }
}

# TODO: return

# ---- repeat ----
r2f_handlers[["repeat"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 1L)
  body <- r2f(args[[1]], scope, ...)
  Fortran(glue(
    "do
    {indent(body)}
    end do
    "))
}

# ---- break ----
r2f_handlers[["break"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 0L)
  Fortran("exit")
}

# ---- break ----
r2f_handlers[["next"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 0L)
  Fortran("cycle")
}

# ---- while ----
r2f_handlers[["while"]] <- function(args, scope, ...) {
  stopifnot(length(args) == 2L)
  cond <- r2f(args[[1]], scope, ...)
  body <- r2f(args[[2]], scope, ...) ## should we set a new hoist target here?
  Fortran(glue(
    "do while ({cond})
    {indent(body)}
    end do
    "))
}

## ---- for ----
r2f_iterable <- function(e, scope, ...) {
  .NotYetImplemented()

  if (is.symbol(e)) {
    var <- get(e, scope)
    iterable <- r2f(...)
  }

  # list(var, iterable, body_prefix)
}

r2f_handlers[["for"]] <- function(args, scope, ...) {
  .[var, iterable, body] <- args
  stopifnot(is.symbol(var))
  var <- as.character(var)
  scope[[var]] <- Variable(mode = "integer", name = var)

  iterable <- r2f_iterable_handlers[[as.character(iterable[[1]])]](iterable, scope)
  body <- r2f(body, scope, ...)

  Fortran(glue(
    "do {var} = {iterable}
    {indent(body)}
    end do
    "))
}

r2f_iterable_handlers := new.env()

r2f_iterable_handlers[["seq_len"]] <-  function(e, scope, ...) {
  x <- as.list(e)[-1]
  if (length(x) != 1) stop("too many args to seq_len()")
  x <- x[[1]]
  start <- 1L
  end <- r2f(x)
  glue("{start}, {end}")
}

r2f_iterable_handlers[["seq"]] <- function(e, scope) {

  ee <- match.call(seq.default, e)
  ee <- whole_doubles_to_ints(ee)

  start <- r2f(ee$from, scope)
  end <- r2f(ee$to, scope)
  step <- if (is.null(ee$by))
    glue("sign(1, {end}-{start})")
  else
    r2f(ee$by, scope)

  str_flatten_commas(
   start, end, step
  )
}

r2f_iterable_handlers[[":"]] <- function(e, scope) {

  ee <- whole_doubles_to_ints(e)
  .[start, end] <- as.list(ee)[-1] |> lapply(r2f, scope)

  glue("{start}, {end}, sign(1, {end}-{start})")
}

r2f_iterable_handlers[["seq_along"]] <- function(e, scope) {
  x <- as.list(e)[-1]
  if (length(x) != 1) stop("too many args to seq_along()")
  x <- x[[1]]
  start <- 1
  end <-  sprintf("size(%s)", r2f(x, scope))
  glue("{start}, {end}")
}

# ---- helpers ----

check_call <- function(e, nargs) {
  if (length(e) != (nargs+1L))
    stop("Too many args to: ", as.character(e[[1L]]))
}

function(args, scope, ..., hoist_mask = function(mask) FALSE) {
  var <- args[[1]]
  var <- r2f(var, scope, ...)
  idxs <- whole_doubles_to_ints(args[-1])
  idxs <- imap(idxs, function(idx, i) {
    if (is_missing(idx))
      Fortran(":", Variable("integer", var@value@dims[[i]]))
    else
      r2f(idx, scope, ...)
  })
  if (length(idxs) == 1 &&
      idxs[[1]]@value@mode == "logical" &&
      idxs[[1]]@value@rank == var@value@rank) {
    mask <- idxs[[1]]
    if (hoist_mask(mask))
      return(var)
    return(Fortran(glue("pack({var}, {mask})"), Variable(var@value@mode, dims = NA)))
  }
  if (length(idxs) != var@value@rank)
    stop("number of args to x[...] must match the rank of x, received:",
         deparse1(as.call(c(quote(`[`,args )))))
  drop <- args$drop %||% TRUE
  idxs <- lapply(idxs, function(subscript) {
    switch(
      paste0(subscript@value@mode, subscript@value@rank),
      logical0 = {
        Fortran(":", Variable("integer", NA))
      },
      logical1 = {
        i <- scope@get_unique_var("integer")
        f <- glue("pack([({i}, {i}=1, size({subscript}))], {subscript})")
        return(Fortran(f, Variable("int", NA)))
      },
      integer0 = {
        if (drop)
          subscript
        else
          Fortran(glue("{subscript}:{subscript}"), Variable("int", 1))
      },
      integer1 = {
        subscript
      },
      stop(
        "all args to x[...] must be logical or integer of rank 0 or 1",
        deparse1(as.call(c(quote(`[`, args ))))
        )
    )
  })
  dims <- drop_nulls(lapply(idxs, \(idx) idx@value@dims[[1]]))
  outval <- Variable(var@value@mode, dims)
  Fortran(glue("{var}({str_flatten_commas(idxs)})"), outval)
}

make_c_bridge <- function(fsub, strict = TRUE, headers = TRUE) {
  stopifnot(inherits(fsub, FortranSubroutine))

  closure <- fsub@closure
  scope <- fsub@scope

  fsub_arg_names <- fsub@signature # arg names
  closure_arg_names <- names(formals(closure))

  c_body <- character()

  if (!all(closure_arg_names %in% fsub_arg_names))
    stop("Undeclared arguments: ", str_flatten_commas(setdiff(closure_arg_names, fsub_arg_names)))

  closure_arg_vars <- mget(closure_arg_names, scope)

  # first unpack all the input vars into named C variables (including sizes and pointer)
  append(c_body) <- lapply(closure_arg_vars, closure_arg_c_defs, strict = strict) |>
    rbind("")

  ## TODO, might still need to define a length size for vars where rank>1, if in checks.

  # now do all size checks.
  append(c_body) <- lapply(closure_arg_vars, closure_arg_size_checks, scope = scope)

  # maybe define and allocate the output var
  n_protected <- 0L
  return_var <- get(closure_return_var_name(closure), scope)
  if (!return_var@name %in% closure_arg_names) {
    return_var@modified <- TRUE
    assign(return_var@name, return_var, scope)
    append(c_body) <- return_var_c_defs(return_var, fsub@scope)
    add(n_protected) <- 1L # allocated return var
    if (return_var@rank > 1)
      add(n_protected) <- 1L # allocated _dim_sexp
  }

  fsub_call_args <- fsub_arg_names |>
    lapply(\(nm) paste0(nm, if (!is_size_name(nm)) "__")) |>
    unlist()

  if (length(fsub_call_args) > 3)
    fsub_call_args <- paste0("\n  ", fsub_call_args)

  append(c_body) <- c("", glue("{fsub@name}({str_flatten_commas(fsub_call_args)});"), "")
  if (n_protected > 0)
    append(c_body) <- glue("UNPROTECT({n_protected});")
  append(c_body) <- glue("return {return_var@name};")

  c_args <- paste("SEXP", names(formals(closure)), collapse = ", ")
  c_body <- as_glue(str_flatten_lines(c_body))

  c_func_def <- glue("SEXP {fsub@name}_(SEXP _args) {c_block(c_body)}")

  fsub_extern_decl <- fsub_extern_decl(fsub)

  c_headers <- glue::trim(r"--(
     #define R_NO_REMAP
     #include <R.h>
     #include <Rinternals.h>

     )--")

  as_glue(str_flatten_lines(c(
    if (headers) c_headers,
    fsub_extern_decl, "",
    c_func_def)
  ))
}

closure_arg_c_defs <- function(var, strict = TRUE) {

  name <- var@name
  mode <- var@mode

  c_code <- character()

  name <- var@name
  SEXPTYPE <- sexptype(var@mode)
  protect <- glue("SETCAR(_args, {var@name});")

  append(c_code) <- glue(
    "// {name}
    _args = CDR(_args);
    SEXP {var@name} = CAR(_args);")

  # first maybe duplicate or coerce the SEXP if needed.
  append(c_code) <- glue("if (TYPEOF({name}) != {SEXPTYPE}) {{")
  append(c_code) <- indent(if (strict) {
    glue(r"(
      Rf_error("typeof({name}) must be '{mode}', not '%s'", R_typeToChar({name}));
      )")
  } else {
    glue("{name} = Rf_coerceVector({name}, {SEXPTYPE});
         {protect}")
  })

  if (var@modified) {
    dup <- glue('
      {name} = Rf_duplicate({name});
      {protect}
      ')

    if (strict) {
      append(c_code) <- c("}", dup)
    } else {
      append(c_code) <- sprintf("} else %s", dup)
    }

  } else {
    append(c_code) <- "}"
  }

  # define the variable that will be passed to the fsub
  append(c_code) <- glue(
    "{fsub_arg_var_c_type(var)} {name}__ = {sexpdata(var@mode)}({name});")

  if (var@rank == 1) {
    size_name <- get_size_name(var)
    append(c_code) <- glue("const R_xlen_t {size_name} = Rf_xlength({var@name});")
  } else if (var@rank > 1) {
    append(c_code) <- glue(
      'const int* const {var@name}__dim_ = ({{
         SEXP dim_ = Rf_getAttrib({var@name}, R_DimSymbol);
         if (Rf_length(dim_) != {var@rank}) Rf_error(
           "{var@name} must be a {var@rank}D-array, but length(dim({var@name})) is %i",
           (int) Rf_length(dim_));
         INTEGER(dim_);}});'
    )
    append(c_code) <- map_chr(seq_len(var@rank), \(axis) {
      size_name <- get_size_name(var, axis)
      glue("const int {size_name} = {var@name}__dim_[{axis-1}];")
    })
  } else {
    stop("bad rank")
  }

  as_glue(str_flatten_lines(c_code))
}

closure_arg_size_checks <- function(var, scope) {
  imap(var@dims, function(d, axis) {
    # axis is either:
    #  - an integer
    #  - a symbol of a size_name
    #  - a call, consisting of only size_name symbols and basic arithmetic ops.
    size_name <- get_size_name(var, axis)

    if (is_scalar_integer(d)) {
      return(glue('
          if ({size_name} != {d})
            Rf_error("{friendly_size(var, axis)} must be {d}, not %0.f",
                      (double){size_name});'
      ))
    }

    if (is.symbol(d)) {
      if (as.character(d) == size_name) {
        # self-named size_name is expected to be passed along to subroutine
        return()
      } else {
        # it's a constraint for another size
        return(glue('
            if ({d} != {size_name})
              Rf_error("{as_friendly_size_name(size_name)} must equal {as_friendly_size_name(d)},"
                       " but are %0.f and %0.f",
                        (double){size_name}, (double){d});'
        ))
      }
    }

    if (is.call(d)) {
      size.c <- dims2c(list(d), scope)
      return(glue('{{
          const R_xlen_t expected = {size.c};
          if ({size_name} != expected)
            Rf_error("{as_friendly_size_name(size_name)} must equal {as_friendly_size_expression(d)},"
                     " but are %0.f and %0.f",
                      (double){size_name}, (double)expected);
        }}'
      ))
    }

    stop("bad dim")
  })
}

return_var_c_defs <- function(var, scope) {
  # allocate the return var.
  name <- var@name
  c_dims <- dims2c(var@dims, scope)
  c_len <- c_dims2c_len(c_dims)
  len_name <- get_size_name(var)

  c_code <- c(
    glue("const R_xlen_t {len_name} = {c_len};"),
    glue(switch(
      var@mode,
      double = "
        SEXP {name} = PROTECT(Rf_allocVector(REALSXP, {len_name}));
        double* {name}__ = REAL({name});",
      integer = "
        SEXP {name} = PROTECT(Rf_allocVector(INTSXP, {len_name}));
        int* {name}__ = INTEGER({name});",
      complex = "
        SEXP {name} = PROTECT(Rf_allocVector(CPLXSXP, {len_name}));
        Rcomplex* {name}__ = COMPLEX({name});",
      logical = "
        SEXP {name} = PROTECT(Rf_allocVector(LGLSXP, {len_name}));
        int* {name}__ = LOGICAL({name});"
    )))

  if (var@rank > 1) {
    append(c_code) <- c_block(
      glue("
        const SEXP _dim_sexp = PROTECT(Rf_allocVector(INTSXP, {var@rank}));
        int* const _dim = INTEGER(_dim_sexp);"
      ),
      imap(c_dims, function(d, i) {
        glue("_dim[{i-1}] = {d};")
      }),
      glue("Rf_dimgets({var@name}, _dim_sexp);")
    )
  }

  str_flatten_lines(c_code)
}

dims2c_eval_base_env <- new.env()

dims2c_eval_base_env[["("]]   <- baseenv()[["("]]
dims2c_eval_base_env[["+"]]   <- function(e1, e2) glue("({e1} + {e2})")
dims2c_eval_base_env[["-"]]   <- function(e1, e2) glue("({e1} - {e2})")
dims2c_eval_base_env[["*"]]   <- function(e1, e2) glue("({e1} * {e2})")
dims2c_eval_base_env[["/"]]   <- function(e1, e2) glue("((double)({e1}) / (double)({e2}))")
# dividing integers truncates towards 0
dims2c_eval_base_env[["%/%"]] <- function(e1, e2) glue("((R_xlen_t){e1} / (R_xlen_t){e2})")
dims2c_eval_base_env[["%%"]]  <- function(e1, e2) glue("((R_xlen_t){e1} % (R_xlen_t){e2})")
dims2c_eval_base_env[["^"]]   <- function(e1, e2) glue("({e1}**{e2})")

dims2c <- function(dims, scope) {
  if (!length(dims) || identical(dims, list(1L))) {
    return(list(NULL, "1"))
  }

  syms <- as.character(unique(unlist(lapply(dims, all.vars))))

  syms <- mget(syms, scope, ifnotfound = syms) |>
    lapply(function(var) {
      if (is_size_name(var)) {
        return(as.character(var))
      }
      # resolve a variable from scope (i.e., some other arg var)
      if (!inherits(var, Variable))
        stop("could not resolve size: ", var)
      glue("Rf_asInteger({var@name})")
      # Should this be as double?
      # TODO: force this into a named c var, to avoid repeated calls
    })

  eval_env <- list2env(syms, parent = dims2c_eval_base_env)
  c_dims <- lapply(dims, function(d) {
    if (inherits(d, Variable))
      return(glue("Rf_asInteger({d@name})"))
    eval(d, eval_env)
  })

  c_dims
}

c_dims2c_len <- function(c_dims) {
  if (length(c_dims) == 1)
    c_dims[[1L]]
  else
    paste0("(", unlist(c_dims), ")", collapse = " * " )
  # eval(Reduce(\(a, b) { call("*", as.symbol(a@name), as.symbol(b@name)) }, dims),
  #      eval_env)
}

# --- utils ----

c_block <- function(...) {
  as_glue(paste0(c("{", indent(c(...)), "}"), collapse = "\n"))
}

# is_var_size <- function(x) inherits(x, VariableSize)

passes_as_scalar <- function(var) {
  var@rank == 0 || var@rank == 1 && identical(var@dims, list(1L))
}

passes_as_value <- function(var) {
  passes_as_scalar(var) && isFALSE(var@modified)
}

sexptype <- function(mode) {
  switch(mode,
         integer = "INTSXP",
         double = "REALSXP",
         complex = "CPLXSXP",
         logical = "LGLSXP",
         stop("Unrecognized mode: ", mode))
}

sexpdata <- function(mode) {
  switch(mode,
         integer = "INTEGER",
         double = "REAL",
         complex = "COMPLEX",
         logical = "LOGICAL",
         stop("Unrecognized mode: ", mode))
}

is_size_name <- function(name) {
  if (is.symbol(name)) {
    name <- as.character(name)
  } else if (!is_string(name)) {
    return(FALSE)
  }

  grepl("(_len_|_dim_[0-9]+_)$", name)
}

friendly_size <- function(var, axis = NULL) {
  if (is.null(axis) || var@rank == 1 && axis == 1)
    glue("length({var@name})")
  else
    glue("dim({var@name})[{axis}]")
}

as_friendly_size_name <- function(size_name) {
  size_name <- as.character(size_name)
  if (endsWith(size_name, "__len_"))
    sprintf("length(%s)", sub("__len_$", "", size_name))
  else
    sub("^(.*)__dim_([0-9]+)_$", "dim(\\1)[\\2]", size_name)
}

as_friendly_size_expression <- function(d) {
  stopifnot(is.call(d))
  nms <- all.names(d, functions = FALSE, unique = TRUE)
  friendly_substitutions <- new.env(parent = emptyenv())
  for(name in nms)
    if (is_size_name(name))
      assign(name, str2lang(as_friendly_size_name(name)), friendly_substitutions)
  d <- substitute_(d, friendly_substitutions)
  d <- call("(", d)
  deparse1(d)
}

closure_return_var_name <- function(closure) {
  return_var_name <- last(body(closure))
  if (!is.symbol(return_var_name))
    stop("return value must be a symbol")
  as.character(return_var_name)
}

fsub_arg_var_c_type <- function(var) {
  type <- switch(var@mode,
    double  = "double*",
    integer = "int*",
    complex = "Rcomplex*",
    logical = "int*",
  )

  # the first const declares that the pointed to values can't be modified
  #   (the array values are read only)
  # the second const declares that the pointer itself can't be modified
  #   (the fsub can never move/reallocate the array, so this const is always present)
  paste0(c(if (!var@modified) "const", type, "const"),
         collapse = " ")
}

fsub_extern_decl <- function(fsub) {
  fsub_arg_names <- fsub@signature # arg names
  scope <- fsub@scope

  fsub_c_sig <- map_chr(fsub_arg_names, function(name) {
    if (is_size_name(name)) {
      type <- if (endsWith("__len_", name))
        "R_xlen_t" else "R_len_t"
      glue("const {type} {name}")
    } else {
      var <- get(name, fsub@scope)
      glue("{fsub_arg_var_c_type(var)} {var@name}__")
    }
  })
  if (length(fsub_c_sig) >= 3L)
    fsub_c_sig <- paste0("\n  ", fsub_c_sig)

  glue("extern void {fsub@name}({str_flatten_commas(fsub_c_sig)});")
}

check_type_call <- function(cl) {
  if (length(cl) > 2)
    stop("only one variable can be declared per type() call")
  args <- as.list(cl)[-1]
  if (length(names(args)) != 1)
    stop("name must be provided as: type(<name> = <mode>(<<dims>>)")
  if (!is.call(args[[1]]) && as.character(args[[1]]) %in% .atomic_type_names)
    stop("only atomic modes are supported")
}

type_call_to_var <- function(cl) {
  check_type_call(cl)
  Variable(
    name = names(cl)[-1],
    mode = as.character(cl[[2L]][[1L]]),
    dims = unname(as.list(cl[[2]])[-1])
  )
}

var_to_type_call <- function(var) {
  arg <- as.call(c(as.symbol(var@mode), var@dims))
  arg <- setNames(list(arg), var@name)
  as.call(c(quote(type), arg))
}

get_flattened_args <- function(cl) {
  # flatten exprs from `{` in usage like declare({ ... })`
  args <- as.list(cl)[-1]
  args <- lapply(args, function(e) {
    if (is_missing(e))
      NULL
    else if (is_call(e, quote(`{`)))
      get_flattened_args(e)
    else
      list(e)
  })
  unlist(args, recursive = FALSE)
}

self_evaluate <- function(...) sys.call()

substitute_declared_sizes <- function(e) {
  stopifnot(is_call(e, quote(`{`)))

  aliases <- new.env(parent = emptyenv())
  eval_env <- new.env(parent = emptyenv())
  for(name in all.names(e, functions = TRUE, unique = TRUE))
    assign(name, self_evaluate, eval_env)
  eval_env <- new.env(parent = eval_env)
  for(name in all.names(e, functions = FALSE, unique = TRUE))
    assign(name, as.symbol(name), eval_env)

  eval_env$`{` <- function(...) {
    as.call(c(list(quote(`{`)), list(...)))
  }

  eval_env$declare <- function(...) {
    args <- get_flattened_args(sys.call())
    args <- lapply(args, function(e) {
      if (is_type_call(e)) {
        var <- type_call_to_var(e)
        var@dims <- imap(var@dims, function(size, axis) {
          size_name <- as.symbol(get_size_name(var, axis))
          if (is.symbol(size) && !exists(size, aliases)) {
            # user defined implicit size_name alias
            assign(as.character(size), size_name, aliases)
            size <- size_name
          } else if (is_scalar_na(size)) {
            size <- size_name
          } else if (is_wholenumber(size)) {
            size <- as.integer(size)
          }
          size
        })
        e <- var_to_type_call(var)
      }
      e
    })

    as.call(c(quote(declare), args))
  }

  e <- eval(e, eval_env)

  # Now the 'aliases' env is populated; go through and substitute
  # size aliases with the actual size name.
  eval_env$declare <- function(...) {
    as.call(lapply(sys.call(), function(e) {
      if (is_type_call(e))
        e <- substitute_(e, aliases)
      e
    }))
  }

  eval(e, eval_env)

}

r2size <- function(r, scope) {
  typeof(r) |> switch(
    integer = r,
    double = {
      if (is_wholenumber(r))
        as.integer(r)
      else
        stop("size must be an integer, found: ", r)
    },
    symbol = {
      if (is_size_name(r))
        return(r)
      var <- get(r, scope)
      if (var@mode != "integer" || !passes_as_scalar(var))
        warning("size is not an integer:", as.character(r))
      if (var@is_arg && !var@modified)
        return(r)
      # TODO: add specific unit tests here
      if (identical(var@r, r))
        return(r)
      # make a best effort to use the r expression last assigned to the
      # symbol, or fail gracefully and return NA.
      # closure-locals with unspecified shape are declared allocatable
      # input and/or output args with unspecified shape signal an error.
      r2size(var@r, scope)
    },
    language = {
      as.character(r[[1]]) |> switch(
        `+` = , `-` = , `/` = , `*` = , `^` = , `%/%` = , `%%` = {
          args <- as.list(r)[-1]
          args <- lapply(args, r2size, scope)
          if (anyNA(rapply(args, as.list)))
            return(NA_integer_)
          cl <- as.call(c(r[[1]], args))
          if (all(map_lgl(args, is.atomic)))
            cl <- eval(cl, baseenv())
          cl
        },
        length = {
          var <- get(r[[2L]], scope)
          if (var@rank == 1)
            return(var@dims[[1L]])
          len <- reduce(var@dims, \(d1, d2) call("*", d1, d2))
          r2size(len, scope)
        },
        `[` = {
          # [ only works when paired with dim()
          if (!is_call(r[[2L]], quote(dim)))
            return(NA_integer_)
          var <- get(r[[2L]][[2L]], scope)
          axis <- r[[3]]
          if (!is_wholenumber(axis))
            return(NA_integer_)
          if (axis > var@rank)
            stop("insufficient rank of variable in ", deparse1(r))
          var@dims[[axis]]
        },
        # dim = {
        #
        # },
        nrow = {
          var <- get(r[[2L]], scope)
          var@dims[[1]]
        },
        ncol = {
          var <- get(r[[2L]], scope)
          var@dims[[2]]
        },
        NA_integer_)
    },
    NA_integer_
  )
}

r2dims <- function(r, scope) {
  if (is.call(r)) {
    as.character(r[[1]]) |> switch(
      dim = {
        var <- get(r[[2L]], scope)
        return(var@dims)
      },
      c = {
        args <- lapply(r[-1], r2dims, scope)
        dims <- unlist(args, recursive = FALSE)
        return(as.list(dims))
      },
      r <- list(r))
  }
  lapply(r, r2size, scope)
}

get_size_name <- function(var, axis = NULL, name = var@name, rank = var@rank) {
  stopifnot(is.null(axis) || is_wholenumber(axis) && axis > 0)
  if (is.null(axis) || rank == 1 && axis == 1)
    sprintf("%s__len_", name)
  else {
    if (axis > rank) stop("axis must not be > rank")
    sprintf("%s__dim_%i_", name, axis)
  }
}

# TODO: allow syntax like:
#   declare(type(a, b, c = integer(1)))
# or:
#   declare(type(a = , b = , c = integer(1)))

new_fortran_subroutine <- function(name, closure, parent = emptyenv()) {

  check_all_var_names_valid(closure)

  # translate body, and populate scope with variables
  body <- body(closure)

  # defuse calls like `-1` and `1+1i`. Not really necessary, but simplifies downstream a little.
  body <- defuse_numeric_literals(body)

  # TODO: try harder here to use one of the input vars as the output var
  body <- ensure_last_expr_sym(body)

  # update closure with sym return value
  base::body(closure) <- body
  # body <- rlang::zap_srcref(body)

  scope <- new_scope(closure, parent)

  # inject symbols for var sizes in declare calls, so like:
  #   declare(type(foo = integer(nr, NA)),
  #           type(bar = integer(nr, 3)))
  # become:
  #   declare(type(foo = integer(foo_dim_1_, foo_dim_2_)),
  #           type(bar = integer(foo_dim_1_, 3L)))
  body <- substitute_declared_sizes(body)
  body <- r2f(drop_last(body), scope)

  # check all input vars were declared
  # TODO: this check might be too late, because r2f() might throw cryptic errors
  # when handling undeclared variables. Either throw better errors from r2f(), or
  # handle all declares first
  for(arg_name in names(formals(closure))) {
    if (is.null(var <- get0(arg_name, scope)))
      stop("arg not declared: ", arg_name)
  }

  # figure out the return variable.
  if (is.symbol(last_expr <- last(body(closure)))) {
    return_var <- get(last_expr, scope)
    return_var@is_return <- TRUE
    scope[[as.character(last_expr)]] <- return_var
  } else {
    # lots we can still do here, just not implemented yet.
    stop("last expression in the function must be a bare symbol")
  }

  manifest <- r2f.scope(scope)
  fsub_arg_names <- attr(manifest, "signature", TRUE)

  used_iso_bindings <- unique(unlist(use.names = FALSE, list(
    lapply(scope, function(var) {
      list(
        switch(
          var@mode,
          double = "c_double",
          integer = "c_int",
          logical = if (var@name %in% fsub_arg_names)
            "c_int",
          complex = "c_double_complex",
          raw = "c_int8_t"
        ),
        lapply(var@dims, function(size) {
          syms <- all.vars(size)
          c(if (any(grepl("__len_$", syms))) "c_ptrdiff_t",
            if (any(grepl("__dim_[0-9]+_$", syms))) "c_int")
        })
      )
    }))))

  # check for literal kinds
  if (!"c_int" %in% used_iso_bindings) {
    if (grepl("\\b[0-9]+_c_int\\b", body))
      append(used_iso_bindings) <- "c_int"
  }
  if (!"c_double" %in% used_iso_bindings) {
    if (grepl("\\b[0-9]+\\.[0-9]+_c_double\\b", body))
      append(used_iso_bindings) <- "c_double"
  }
  used_iso_bindings <- sort(used_iso_bindings, method = "radix")

  subroutine <- glue("
    subroutine {name}({str_flatten_commas(fsub_arg_names)}) bind(c)
      use iso_c_binding, only: {str_flatten_commas(used_iso_bindings)}
      implicit none

    {indent(manifest)}

    {indent(body)}
    end subroutine
    ")

  subroutine <- insert_fortran_line_continuations(subroutine)

  FortranSubroutine(
    subroutine,
    name = name,
    signature = fsub_arg_names,
    scope = scope,
    closure = closure
  )
}

insert_fortran_line_continuations <- function(code, preserve_attributes = TRUE) {
  attrs_in <- attributes(code)

  code <- as.character(code)
  lines <- str_split_lines(code)
  lines <- trimws(lines, "right")

  if (any(too_long <- nchar(lines) > 132)) {
    # remove leading indentation
    lines[too_long] <- trimws(lines[too_long], "left")

    # move trailing comment at the end
    lines[too_long] <- sub("^(.*)!(.*)$", "!\\2\n\\1", lines[too_long])
    lines <- str_split_lines(lines)

    # maximum 255 continuations are allowed
    for (i in 1:256) {
      if (!any(too_long <- nchar(lines) > 132))
        break
      lines[too_long] <- sub("^(.{1,130})\\s", "\\1 &\n", lines[too_long])
      lines <- str_split_lines(lines)
    }
    if (i > 255L)
      stop("Too long line encountered. Please split long expressions into a sequence of smaller expressions.")
  }

  code <- str_flatten_lines(lines)
  if (preserve_attributes)
    attributes(code) <- attrs_in
  code
}

#' @importFrom glue glue glue_data trim as_glue glue_collapse single_quote
#' @importFrom dotty .
#' @importFrom stats setNames
#' @importFrom utils gethash hashtab remhash sethash str
NULL

# @export
# This will be exported by S7 next release.
`:=` <- function(left, right) {
  name <- substitute(left)
  if (!is.symbol(name))
    stop("left hand side must be a symbol")

  right <- substitute(right)
  if (!is.call(right))
    stop("right hand side must be a call")

  if (is.symbol(cl <- right[[1L]]) &&
      as.character(cl) %in% c("function", "new.env")) {
    # attach "name" attr for usage like:
    # foo := function(){}
    # foo := new.env()
    right <- eval(right, parent.frame())
    attr(right, "name") <- as.character(name)
  } else {
    # for all other usage,
    # inject name as a named arg, so that
    #   foo := new_class(...)
    # becomes
    #   foo <- new_class(..., name = "foo")

    right <- as.call(c(as.list(right), list(name = as.character(name))))

    ## skip check; if duplicate 'name' arg is an issue the call itself will signal an error.
    # if (hasName(right, "name")) stop("duplicate `name` argument.")

    ## alternative code path that injects `name` as positional arg instead
    # right <- as.list(right)
    # right <- as.call(c(right[[1L]], as.character(name), right[-1L]))
  }

  eval(call("<-", name, right), parent.frame())
}

`%error%` <- function(x, y) tryCatch(x, error = function(e) y)

`append<-` <- function(x, after, value) {
  if (missing(after))
    c(x, value)
  else
    append(x, value, after = after)
}

`append1<-` <- function (x, value) {
  stopifnot(is.list(x) || identical(mode(x), mode(value)))
  x[[length(x) + 1L]] <- value
  x
}

`prepend<-` <- function(x, value) {
  c(vector(typeof(x)), value, x)
}

`add<-` <- `+` #function(x, value) x + value

map_int <- function(.x, .f, ...) vapply(X = .x, FUN = .f, FUN.VALUE = 0L, ...)
map_lgl <- function(.x, .f, ...) vapply(X = .x, FUN = .f, FUN.VALUE = TRUE, ...)
map_chr <- function(.x, .f, ...) vapply(X = .x, FUN = .f, FUN.VALUE = "", ...)

imap <- function (.x, .f, ...) {
  out <- .mapply(.f, list(.x, names(.x) %||% seq_along(.x)),
                 list(...))
  names(out) <- names(.x)
  out
}

map2 <- function (.x, .y, .f, ...) {
  if (length(.x) != length(.y) && length(.x) != 1L && length(.y) != 1L)
    stop(".x and .y must have the same length, or one of them must have length 1")
  out <- .mapply(.f, list(.x, .y), list(...))
  if (length(.x) == length(out))
    names(out) <- names(.x)
  out
}

discard <- function(.x, .f, ...)
  .x[!vapply(X = .x, FUN = .f, FUN.VALUE = TRUE, ...)]

keep <- function(.x, .f, ...)
  .x[vapply(X = .x, FUN = .f, FUN.VALUE = TRUE, ...)]

compact <- function(.x)
  .x[as.logical(lengths(.x, use.names = FALSE))]

drop_nulls <- function(x, i) {
  if (missing(i))
    x[!vapply( X = x, FUN = is.null, FUN.VALUE = FALSE, USE.NAMES = FALSE)]
  else {
    drop <- logical(length(x))
    names(drop) <- names(x)
    drop[i] <- vapply(X = x[i], FUN = is.null, FUN.VALUE = FALSE, USE.NAMES = FALSE)
    x[!drop]
  }
}

last <- function(x) x[[length(x)]]
drop_last <- function(x) x[-length(x)]

is_scalar_na      <- function(x) is.atomic(x)    && !is.object(x) && length(x) == 1L && is.na(x)
is_scalar_atomic  <- function(x) is.atomic(x)    && !is.object(x) && length(x) == 1L && !is.na(x)
is_scalar_integer <- function(x) is.integer(x)   && !is.object(x) && length(x) == 1L && !is.na(x)
is_string         <- function(x) is.character(x) && length(x) == 1L && !is.na(x) # could also be 'glue' class.
is_bool           <- function(x) is.logical(x)   && !is.object(x) && length(x) == 1L && !is.na(x)
is_number         <- function(x) is.numeric(x)   && !is.object(x) && length(x) == 1L && !is.na(x)
is_wholenumber    <- function(x) is.numeric(x)   && !is.object(x) && length(x) == 1L && !is.na(x) &&
  x >= 0L && (is.integer(x) || is.double(x) && trunc(x) == x)

new_function <- function(args = NULL, body = NULL, env = parent.frame()) {
  as.function.default(c(args, body %||% list(NULL)), env)
}

is_call <- function(x, name = NULL) {
  is.call(x) && (is.null(name) || identical(as.symbol(name), x[[1L]]))
}

str_flatten <- function(x, collapse = "") {
  paste0(as.character(unlist(x, use.names = FALSE)), collapse = collapse)
}

str_flatten_lines <- function(...) {
  paste0(unlist(c(character(), ...), use.names = FALSE), collapse = "\n")
}

str_flatten_commas <- function(...) {
  paste0(unlist(c(character(), ...), use.names = FALSE), collapse = ", ")
}

str_flatten_args <- function(..., multiline = length(dots) >= 3) {
  dots <- unlist(c(character(), ...), use.names = FALSE)
  if (multiline) {
    dots <- paste0("\n  ", dots, collapse = ",")
    paste(dots, "\n")
  } else {
    paste0(dots, collapse = ",")
  }
}

interleave <- function(x, y) {
  stopifnot(is.atomic(x), is.atomic(y), length(y) == 1L, typeof(x) == typeof(y))
  drop_last(as.vector(rbind(x, y, deparse.level = 0L)))
}

str_split_lines <- function(...) {
  x <- c(...) |>
    unlist(use.names = FALSE) |>
    strsplit("\n", fixed = TRUE)
  x[!lengths(x)] <- ""
  x |>
    unlist(use.names = FALSE) |>
    trimws("right")
}

indent <- function(x, n = 2L) {
  x <- str_split_lines(x)
  x <- sub("[ \t\r]+$", "", x, perl = TRUE) # trim trailing whitespace
  paste0(strrep(" ", n), x, collapse = "\n")
}

parent.pkg <- function(env = parent.frame(2)) {
  if (isNamespace(env <- topenv(env)))
    as.character(getNamespaceName(env)) # unname
  else
    NULL # print visible
}

set_names <- function(x, nm = x, ...) {
  names(x) <-  as.character(
    if (is.function(nm)) nm(names(x), ...)
    else unlist(list(nm, ...), use.names = FALSE)
  )
  x
}

zip_lists <- function(...) {
  x <- if (...length() == 1L) ..1 else list(...)

  if (is.character(nms.1 <- names(x.1 <- x[[1L]])))
    if (anyDuplicated(nms.1) || anyNA(nms.1) || any(nms.1 == ""))
      stop("All names must be unique.",
           " (Use `unname()` for positional matching.)")

  if (length(setdiff(lengths(x), 1L)) != 1L)
    stop("all elements must have the same length")

  for (i in seq_along(x)) {
    if (identical(nms.1, nms.i <- names(x[[i]])))
      next
    if (setequal(nms.1, nms.i)) {
      x[[i]] <- x[[i]][nms.1]
      next
    }
    stop("All names of arguments provided to `zip_lists()` must match.",
         " Call `unname()` on each argument if you want positional matching")
  }
  ans <- .mapply(list, x, NULL)
  names(ans) <- nms.1
  ans
}

is_missing <- function(x) missing(x) || identical(x, quote(expr = ))

is_type_call <- function(e) {
  is.call(e) && identical(e[[1]], quote(type))
}

reduce <- function (.x, .f, ..., .init) {
  f <- function(x, y) .f(x, y, ...)
  Reduce(f, .x, init = .init)
}

substitute_ <- function(expr, env) {
  do.call(base::substitute, list(expr, env))
}

defer <- function (expr, env = parent.frame(), after = FALSE) {
  thunk <- as.call(list(function() expr))
  do.call(on.exit, list(thunk, TRUE, after), envir = env)
}

is_scalar <- function(x) identical(length(x), 1L)

#' @import S7
NULL

new_setter <- function(coerce = NULL, coerce_null = FALSE, set_once = FALSE, env = parent.frame(2L)) {

  if (is.null(coerce) || isFALSE(coerce) && isFALSE(set_once))
    return()

  bind_name <- quote(name <- as.character(last(attr(self, ".setting_prop", TRUE))))

  check_set_once <- if (set_once) {
    quote(if (!is.null(prop(self, name)))
      stop(name, " can only be set once"))
  }

  rebind_coerced_value <-
    if (is.null(coerce) || isFALSE(coerce)) {
      NULL
    } else if (isTRUE(coerce)) {
      quote(value <- convert(
        from = value,
        to = S7_class(self)@properties[[as.character(name)]]$class
      ))
    } else if (is.function(coerce) || is.symbol(coerce)) {
      bquote(value <- .(coerce)(value))
    } else if (is.language(coerce)) {
      bquote(value <- .(coerce))
    } else {
      stop("coerce must be TRUE, FALSE, NULL, a function, a symbol, or a call")
    }

  if (!coerce_null && !is.null(rebind_coerced_value)) {
    rebind_coerced_value <- bquote(if (!is.null(value)) .(rebind_coerced_value))
  }

  set <- quote(`prop<-`(
    object = self,
    name = name,
    check = FALSE,
    value = value
  ))

  new_function(
    args = alist(self = , value = ),
    body = as.call(c(quote(`{`),
      bind_name,
      check_set_once,
      rebind_coerced_value,
      set)),
    env = env
  )
}

new_scalar_validator <- function(allow_null = FALSE,
                                 allow_na = FALSE,
                                 additional_checks = NULL,
                                 env = parent.frame(2L)) {
  checks <- c(
    if (allow_null) quote(if (is.null(value)) return()),
    quote(if (length(value) != 1L) return("must be a scalar")),
    if (!allow_na) quote(if (anyNA(value)) return("must not be NA")),
    additional_checks
  )

  new_function(
    args = alist(value = ),
    body = as.call(c(quote(`{`), checks)),
    env = parent.frame(2L)
  )
}

prop_bool <- function(default, allow_null = FALSE, allow_na = FALSE, set_once = FALSE) {
  stopifnot(is_bool(set_once), is_bool(allow_null), is_bool(allow_na))

  new_property(
    class = if (allow_null) NULL | class_logical else class_logical,
    setter = new_setter(set_once = set_once),
    validator = new_scalar_validator(allow_null = allow_null,
                                     allow_na = allow_na),
    default = default
  )
}

prop_string <- function(default = NULL,
                        allow_null = FALSE,
                        allow_na = FALSE,
                        coerce = FALSE,
                        set_once = FALSE) {
  stopifnot(is_bool(set_once), is_bool(allow_null), is_bool(allow_na))

  if (isTRUE(coerce))
    coerce <- quote(as.character)

  new_property(
    class = if (allow_null) NULL | class_character else class_character,
    default = default,
    validator = new_scalar_validator(allow_null = allow_null),
    setter = new_setter(coerce = coerce,
                        coerce_null = !allow_null,
                        set_once = set_once)
  )
}

prop_wholenumber <- function(default = NULL,
                             allow_null = FALSE,
                             allow_na = FALSE,
                             coerce = TRUE,
                             set_once = FALSE) {
  stopifnot(is_bool(set_once), is_bool(allow_null), is_bool(allow_na))

  if (isTRUE(coerce))
    coerce <- quote(
      if (is_wholenumber(value)) as.integer(value)
      else stop("@", name, " must be a whole number, but received: ", value)
      )

  new_property(
    class = if (allow_null) NULL | class_integer else class_integer,
    default = as.integer(default),
    setter = new_setter(coerce = coerce,
                        coerce_null = !allow_null,
                        set_once = set_once),
    validator = new_scalar_validator(allow_null = allow_null)
  )
}

prop_enum <- function(values,
                      nullable = FALSE,
                      default = if (nullable) NULL else values[1],
                      exact = FALSE,
                      set_once = FALSE) {

  stopifnot(
    "values must be a character vector of length >= 2 without any NA" =
      is.character(values) && length(values) >= 2 && !anyNA(values)
  )

  coerce <- if (exact) NULL else {
    bquote(if (length(value) == 1L && !anyNA(i <- charmatch(value, .(values))))
      .(values)[i] else value)
  }

  display_values <- glue_collapse(single_quote(values), sep = ", ", last = ", or ")
  msg <- sprintf("must be either %s, not '", display_values)
  validator <- new_scalar_validator(allow_null = nullable,
                                    additional_checks = bquote(
    if (!match(value, .(values), nomatch = 0L))
      return(paste0(.(msg), value, "'."))
  ))

  new_property(
    class = if (nullable) NULL | class_character else class_character,
    setter =  new_setter(coerce = coerce, coerce_null = !nullable, set_once = set_once),
    validator = validator,
    default = default
  )
}

.atomic_type_names <- c("integer", "logical", "double",
                        "character", "raw", "complex")

# the print method for this should only print non-null values
Variable := new_class(
  properties = list(

    mode = prop_enum(.atomic_type_names, nullable = TRUE, set_once = FALSE),

    dims = new_property(
      # NULL means scalar
      NULL | class_list,
      setter = function(self, value) {
        if (!length(value))
          return(self)

        value <- switch(typeof(value),
          logical = , integer = , double = as.list(value),
          language = , symbol = list(value), # implicit rank-1
          list = value,
          stop("@dims must be a list")
        )

        value <- lapply(value, \(axis) {
          if (is.language(axis)) {
            axis
          } else if (is_wholenumber(axis) || is_scalar_na(axis)) {
            as.integer(axis)
          } else {
            stop(sprintf(
              "%s@dims must be a list of language or scalar integers, not %s",
              self@name %||% '', axis
            ))
          }
        })

        self@dims <- value
        self
      } # dims$setter
    ), # dims = new_property()

    name = prop_string(
      allow_null = TRUE,
      coerce = quote(switch(typeof(value), symbol = as.character(value), value)),
      set_once = FALSE #TRUE
    ),

    rank = new_property(
      class_integer,
      getter = function(self) {
        length(self@dims)
      }),

    modified = prop_bool(default = FALSE),

    r = new_property(
      NULL | class_language | class_atomic,
      setter = function(self, value) {
        # custom setter to workaround https://github.com/RConsortium/S7/issues/511
        attr(self, "r") <- value
        self
      }
    ),

    is_arg = prop_bool(default = FALSE),

    is_return = prop_bool(default = FALSE),

    # TRUE for closure args and return values, FALSE for all other vars.
    is_external = new_property(
      class_logical,
      getter = function(self)
        self@is_arg || self@is_return
    ),

    is_scalar = new_property(
      class_logical,
      getter = function(self) {
        self@rank == 0 || identical(self@dims, list(1L))
      }
    )

    )
)

# method(print, Variable) <- function(x, ...) {
#
# }

Fortran := new_class(
  class_character,

  properties = list(

    value = NULL | Variable,

    r = new_property(
      # custom setter only to workaround https://github.com/RConsortium/S7/issues/511
      NULL | class_language | class_atomic,
      setter = function(self, value) {
        attr(self, "r") <- value
        self
      }
    )
  ),

  validator = function(self) {
    if (length(self) != 1L)
      "must be a length 1 string"
  }
)

FortranSubroutine := new_class(Fortran, properties = list(
  name = prop_string(),
  signature = class_character,
  closure = class_function,
  scope = NULL | class_environment,
  c_bridge = S7::new_property(
    NULL | class_character,
    getter = function(self) {
      make_c_bridge(self) %error% NULL
    })
))

`%error%` <- function(x, y) tryCatch(x, error = function(e) y)

try_prop <- function(object, name) S7::prop(object, name) %error% NULL

emit <- function(..., sep = "", end = "\n") cat(..., end, sep = sep)

method(format, Variable) <- function(x, ...) {
  capture.output(str(x))
}

method(as.character, Variable) <- function(x, ...)
  x@name %||% stop("Variable does not have a name")

method(print, Fortran) <- function(x, ...) {
  emit(trimws(x), end = "\n\n")
  for(prop_name in c("value", "r", "c_bridge"))
    if (!is.null(prop_val <- try_prop(x, prop_name))) {
      emit("@", prop_name, ": ", trimws(indent(format(prop_val))));
    }
}

#' Compile a Quick Function
#'
#' Compile an R function.
#'
#' @param fun An R function
#' @param name Optional string, name to use for the function.
#'
#' @details
#'
#' ## `declare(type())` syntax:
#'
#' The shape and mode of all function arguments must be declared. Local and
#' return variables may optionally also be declared.
#'
#' `declare(type())` also has support for declaring size constraints, or size
#' relationships between variables. Here are some examples of declare calls:
#'
#' ```r
#' declare(type(x = double(NA))) # x is a 1-d double vector of any length
#' declare(type(x = double(10))) # x is a 1-d double vector of length 10
#' declare(type(x = double(1)))  # x is a scalar double
#'
#' declare(type(x = integer(2, 3)))  # x is a 2-d integer matrix with dim (2, 3)
#' declare(type(x = integer(NA, 3))) # x is a 2-d integer matrix with dim (<any>, 3)
#'
#' # x is a 4-d logical matrix with dim (<any>, 24, 24, 3)
#' declare(type(x = logical(NA, 24, 24, 3)))
#'
#' # x and y are 1-d double vectors of any length
#' declare(type(x = double(NA)),
#'         type(y = double(NA)))
#'
#' # x and y are 1-d double vectors of the same length
#' declare(
#'   type(x = double(n)),
#'   type(y = double(n)),
#' )
#'
#' # x and y are 1-d double vectors, where length(y) == length(x) + 2
#' declare(type(x = double(n)),
#'         type(y = double(n+2)))
#' ```
#'
#' You can provide declarations to `declare()` as:
#'
#' - Multiple arguments to a single `declare()` call
#' - Separate `declare()` calls
#' - Multiple arguments within a code block (`{}`) inside `declare()`
#'
#' ```r
#' declare(
#'   type(x = double(n)),
#'   type(y = double(n)),
#' )
#'
#' declare(type(x = double(n)))
#' declare(type(y = double(n)))
#'
#' declare({
#'   type(x = double(n))
#'   type(y = double(n))
#' })
#' ```
#'
#' ## Return values
#'
#' The shape and type of a function return value must be known at compile time.
#' In most situations, this will be automatically inferred by `quick()`. However,
#' if the output is dynamic, then you may need to provide a hint.
#' For example, returning the result of `seq()` will fail because the output shape
#' cannot be inferred.
#'
#' ```r
#' # Will fail to compile:
#' quick_seq <- quick(function(start, end) {
#'   declare({
#'     type(start = integer(1))
#'     type(end = integer(1))
#'   })
#'   out <- seq(start, end)
#'   out
#' })
#' ```
#'
#' However, if the output size can be declared as a dynamic expression using other
#' values known at runtime, compilation will succeed:
#'
#' ```r
#' # Succeeds:
#' quick_seq <- quick(function(start, end) {
#'   declare({
#'     type(start = integer(1))
#'     type(end = integer(1))
#'     type(out = integer(end - start + 1))
#'   })
#'   out <- seq(start, end)
#'   out
#' })
#' quick_seq(1L, 5L)
#' ```
#'
#' @returns A quicker R function.
#' @export
#' @examples
#' add_ab <- quick(function(a, b) {
#'   declare(type(a = double(n)),
#'           type(b = double(n)))
#'   out <- a + b
#'   out
#' })
#' add_ab(1, 2)
quick <- function(fun, name = NULL) {
  if (is.null(name)) {
    name <- if (is.symbol(substitute(fun)))
      deparse(substitute(fun))
    else
      make_unique_name(prefix = "anonymous_quick_function_")
  }

  if (nzchar(pkgname <- Sys.getenv("DEVTOOLS_LOAD"))) {
    if (!collector$is_active()) {
      if (!requireNamespace("pkgload", quietly = TRUE)) {
        stop("Please install 'pkgload'")
      }
      for (i in seq_along(sys.calls())) {
        if (identical(sys.function(i), pkgload::load_code)) {
          collector$activate(paste0(pkgname, ":quick_funcs"))
          defer(dump_collected(), sys.frame(i), after = TRUE)
          break
        }
      }
    }
  }

  if (collector$is_active()) {
    # we are in a quickr::compile_package() or a devtools::load_all() call,
    # merely collecting functions at this point.
    quick_closure <- create_quick_closure(name, fun)
    collector$add(name = name, closure = fun, quick_closure = quick_closure)
    return(quick_closure)
  }

  pkgname <- parent.pkg()
  if (!is.null(pkgname) && pkgname != "quickr") {
    # we are in a package - but outside a quickr::compile_package() call.
    return(create_quick_closure(name, fun))
  }

  # not in a package. Compile and load eagerly.
  attr(fun, "name") <- name
  fun <- compile(r2f(fun))
  attr(fun, "name") <- NULL

  fun
}

compile <- function(fsub, build_dir = tempfile(paste0(fsub@name, "-build-"))) {
  stopifnot(inherits(fsub, FortranSubroutine))

  name <- fsub@name
  c_wrapper <- make_c_bridge(fsub)

  if (dir.exists(build_dir)) unlink(build_dir, recursive = T)
  if (!dir.exists(build_dir))
    dir.create(build_dir)
  owd <- setwd(build_dir)
  on.exit(setwd(owd))

  fsub_path <- paste0(name, "_fsub.f90")
  c_wrapper_path <- paste0(name, "_c_wrapper.c")
  dll_path <- paste0(name, .Platform$dynlib.ext)
  writeLines(fsub, fsub_path)
  writeLines(c_wrapper, c_wrapper_path)

  suppressWarnings({
    result <- system2(
      R.home("bin/R"),
      c("CMD SHLIB --use-LTO", "-o", dll_path, fsub_path, c_wrapper_path),
      stdout = TRUE, stderr = TRUE
    )
  })
  if (!is.null(attr(result, "status"))) {
    writeLines(result, stderr())
    str(attributes(result))
    stop("Compilation Error")
  }

  # tryCatch(dyn.unload(dll_path), error = identity)
  dll <- dyn.load(dll_path)
  c_wrapper_name <- paste0(fsub@name, "_")
  ptr <- getNativeSymbolInfo(c_wrapper_name, dll)$address

  create_quick_closure(fsub@name, fsub@closure, native_symbol = ptr)
}

create_quick_closure <- function(name, closure,
                                 native_symbol = as.name(paste0(name, "_"))) {
  body(closure) <- as.call(c(quote(.External), native_symbol,
                             lapply(names(formals(closure)), as.name)))
  closure
}

check_all_var_names_valid <- function(fun) {
  nms <- unique(c(names(formals(fun)), all.vars(body(fun), functions = FALSE)))
  invalid <- endsWith(nms, "_") | startsWith(nms, "_") | nms %in% c(

    # clashes with Fortran subroutine symbols
    "c_int", "c_double", "c_ptrdiff_t",

    # clashes with C bridge symbols
    "int" #, "double",

    # ??? (clashes with R symbols?)
    # "double", "integer"
  )
  if (any(invalid)) {
    stop("symbols cannot start or end with '_', but found: ",
         glue_collapse(invalid, ", ", last = ", and "))
  }
}

# ---- utils ----

make_unique_name <- local({
  i <- 0L
  function(prefix = "tmp") {
    paste0(prefix, i <<- i + 1L)
  }
})

#' Compile all `quick()` functions in a package.
#'
#' This will compile all `quick()` functions in an R package, and
#' generate source files in the `src/` directory.
#'
#' Note, this function is automatically invoked during a `pkgload::load_all()` call.
#'
#' @param path Path to an R package
#'
#' @returns Called for its side effect.
#' @export
compile_package <- function(path = ".") {
  if (path != ".") {
    owd <- setwd(path)
    on.exit(setwd(owd), add = TRUE)
  }

  if (!dir.exists("R") || !file.exists("DESCRIPTION"))
    stop(path, " does not appear to be an R package.")

  pkgname <- read.dcf("DESCRIPTION", "Package")
  if (length(pkgname) != 1)
    stop(sprintf("path '%s' does not point to an R package", path))
  pkgname <- as.character(pkgname)

  # collect all `quick()` calls in the package
  collector$activate(paste0(pkgname, ":quick_funcs"))

  # TODO: need to unset various R_* env vars, or just
  # take a dep on callr
  system2(file.path(R.home("bin"), "R"),
          c("-q", "-e", shQuote("pkgload::load_all()")))
}

dump_collected <- function() {

  collected <- collector$get_collected()

  # try to resolve closure names for anonymous functions
  pkg_ns <- topenv(environment(collected[[1L]]$closure))
  pkg_funcs <- as.list.environment(pkg_ns, all.names = TRUE)
  tab <- hashtab("address", length(collected))
  for (i in seq_along(pkg_funcs)) {
    if (typeof(fn <- pkg_funcs[[i]]) == "closure")
      # if is quick closure ...
      sethash(tab, pkg_funcs[[i]], names(pkg_funcs)[i])
  }

  quick_funcs <- unlist(recursive = FALSE, lapply(collected, function(x) {
    if (!startsWith(x$name, "anonymous_quick_function_"))
      return(setNames(list(x$closure), x$name))
    true_name <- gethash(tab, x$quick_closure)
    if (is.null(true_name))
      return(setNames(list(x$closure), x$name))
    # update pkg_ns with true name
    quick_closure <- create_quick_closure(true_name, x$closure)
    pkg_ns[[true_name]] <- quick_closure
    remhash(tab, x$quick_closure)
    setNames(list(x$closure), true_name)
  }))

  pkgname <- basename(normalizePath("."))

  # check if we have a useDynLib line in NAMESPACE.
  if (!any(sapply(parse(file = "NAMESPACE"), function(e) {
    identical(e[[1]], quote(useDynLib)) && isTRUE(e$.registration)
  })))
    message("- Please add this roxygen directive somewhere in the Package R sources:\n  ",
            glue("#' @useDynLib {pkgname}, .registration = TRUE"), "\n",
            "- Then run `devtools::document()`\n")

  sources <- zip_lists(imap(quick_funcs, function(func, name) {
    fsub <- new_fortran_subroutine(name, func)
    cbridge <- make_c_bridge(fsub, headers = name == names(quick_funcs)[1])
    list(f90 = fsub, c = cbridge)
  })) |> lapply(\(x) x |> unlist() |> interleave("\n"))

  entries <- paste0(sprintf('  {"%1$s", (DL_FUNC) &%1$s, -1}',
                            paste0(names(quick_funcs), "_")),
                    collapse = ",\n")
  entries <- sprintf("static const R_ExternalMethodDef QuickrEntries[] = {\n%s\n};",
                     entries)

  append(sources$c) <- c("", entries, "")

  R_init_pkg <- paste0("R_init_", pkgname, "(")
  has_pkg_init_fn <- list.files("src", pattern = "\\.(c|cpp|h|hpp|c\\+\\+)$",
                                recursive = TRUE, all.files = TRUE,
                                full.names = TRUE) |>
    setdiff("src/quickr_entrypoints.c") |>
    lapply(function(f) {
      any(grepl(R_init_pkg, readLines(f, warn = FALSE), fixed = TRUE))
    }) |> unlist() |> any()

  append(sources$c) <- c("#include <R_ext/Rdynload.h>", "")

  init_fn <- if (has_pkg_init_fn) {
    glue("
      void R_init_{pkgname}_quick_functions(DllInfo *dll) {{
        R_registerRoutines(dll, NULL, NULL, NULL, QuickrEntries);
      }}")
  } else {
    init_pkgname <- gsub(".", "_", pkgname, fixed = TRUE)
    glue("
      void R_init_{init_pkgname}(DllInfo *dll) {{
        R_registerRoutines(dll, NULL, NULL, NULL, QuickrEntries);
        R_useDynamicSymbols(dll, FALSE);
      }}")
  }

  append(sources$c) <- init_fn

  sources <- lapply(sources, str_split_lines)

  src_files_written <- FALSE
  if (!file.exists("src")) dir.create("src")
  cbridges_filepath <- "src/quickr_entrypoints.c"
  if (!file.exists(cbridges_filepath) || !identical(sources$c, readLines(cbridges_filepath))) {
    unlink(sprintf("%s.o", tools::file_path_sans_ext(cbridges_filepath)))
    unlink(pkg_dll_path(pkgname)) # TODO: this might fail on windows - need a fallback.
    writeLines(sources$c, cbridges_filepath)
    cli::cli_inform(c(i = "Updated {.file {cbridges_filepath}}"))
    src_files_written <- TRUE
  }

  fsubs_filepath <- "src/quickr_sub_routines.f90"
  if (!file.exists(fsubs_filepath) || !identical(sources$f90, readLines(fsubs_filepath))) {
    unlink(sprintf("%s.o", tools::file_path_sans_ext(fsubs_filepath)))
    unlink(pkg_dll_path(pkgname)) # TODO: this might fail on windows - need a fallback.
    writeLines(sources$f90, fsubs_filepath)
    cli::cli_inform(c(i = "Updated {.file {fsubs_filepath}}"))
    src_files_written <- TRUE
  }

  if (src_files_written) {
    for (i in seq_along(sys.calls())) {
      if (identical(sys.function(i), pkgload::load_all)) {
        defer(pkgload::load_all(), sys.frame(i), after = TRUE)
        rlang::return_from(sys.frame(i), value = invisible())
        break
      }
    }
  }
  invisible()
}

pkg_dll_path <- function (pkgname) {
  file.path("src", paste0(pkgname, .Platform$dynlib.ext))
}

collector <- local({

  .collected <- NULL

  activate <- function(name = NULL) {
    .collected <<- list()
    attr(.collected, "name") <<- name
  }

  is_active <- function() {
    is.list(.collected)
  }

  add <- function(...) {
    .collected[[length(.collected)+1L]] <<- list(...)
  }

  get_collected <- function(clear = TRUE) {
    if (clear)
      on.exit(.collected <<- NULL)
    .collected
  }

  environment()
})

new_ordered_env <- function(parent = emptyenv()) {
  env <- new.env(parent = parent)
  class(env) <- "quickr_ordered_env"
  env
}

#' @export
`[[<-.quickr_ordered_env` <- function(x, name, value) {
  attr(x, "ordered_names") <- unique(c(attr(x, "ordered_names", TRUE), name))
  assign(name, value, envir = x)
  x
  # NextMethod()
}

#' @export
`[[.quickr_ordered_env` <- function(x, name) {
  get0(name, x) # name can be a symbols too
}

#' @export
names.quickr_ordered_env <- function(x) {
  all_names <- ls(envir = x, sorted = FALSE)
  ordered_names <- attr(x, "ordered_names", TRUE)
  if (!setequal(all_names, ordered_names)) {
    warning("untracked name")
    stop("untracked name")
  }
  ordered_names
}

#' @export
as.list.quickr_ordered_env <- function(x, ...) {
  out <- as.list.environment(x, all.names = TRUE, ...)
  out[names.quickr_ordered_env(x)]
}

#' @export
print.quickr_ordered_env <- function(x, ...) {
  emit("env (class: ", str_flatten_commas(class(x)), ") with bindings:")
  str(as.list.quickr_ordered_env(x), no.list = TRUE)
}

check_assignment_compatible <- function(target, value) {
  if (is.null(value)) return()
  stopifnot(exprs = {
    inherits(target, Variable)
    inherits(value, Variable)
    passes_as_scalar(target) || passes_as_scalar(value) || target@rank == value@rank
  })
}

new_scope <- function(closure, parent = emptyenv()) {
  scope <- new_ordered_env(parent = parent)
  class(scope) <- unique(c("quickr_scope", class(scope)))
  attr(scope, "closure") <- closure

  attr(scope, "get_unique_var") <- local({
    i <- 0L
    function(...) {
      name <- paste0("tmp", i <<- i + 1L, "_")
      (scope[[name]] <- Variable(..., name = name))
    }
  })
  attr(scope, "assign") <- function(name, value) {
    stopifnot(inherits(value, Variable), is.symbol(name) || is_string(name))
    name <- as.character(name)
    if (exists(name, scope))
      check_assignment_compatible(get(name, scope), value)
    value@name <- name
    assign(name, value, scope)
  }
  scope
}

#' @export
`@.quickr_scope` <- function(x, name) attr(x, name, exact = TRUE)

#' @export
`@<-.quickr_scope` <- function(x, name, value) `attr<-`(x, name, value = value)

#' @importFrom utils .AtNames findMatches
#' @export
.AtNames.quickr_scope <- function(x, pattern = "")
  findMatches(pattern, names(attributes(x)))

defuse_numeric_literals <- function(e) {
  if (is.call(e)) {
    e <- as.call(lapply(e, defuse_numeric_literals))
    if (is.symbol(e1 <- e[[1L]]) &&
        as.character(e1) %in% c("+", "-", "*", "/", "%%", "%/%", "^") &&
        all(map_lgl(e[-1L], is.atomic))) {
      e <- eval(e, baseenv())
    }
  }
  e
}

ensure_last_expr_sym <- function(bdy) {
  if (!is_call(bdy, quote(`{`)))
    stop("bad body, needs {")
  if (!is.symbol(last_expr <- last(bdy))) {
    bdy[[length(bdy)]] <- call("<-", quote(out_), last_expr)
    bdy[[length(bdy) + 1L]] <- quote(out_)
  }
  bdy
}

whole_doubles_to_ints <- function(x) {
  walker <- function(x) {
    switch(
      typeof(x),
      double = if (trunc(x) == x) as.integer(x),
      language =  as.call(lapply(x, walker)),
      list = lapply(x, walker),
      x
    )
  }
  walker(x)
}

# # ' @export
# `@.default` <- function(x, name) {
#   if (isS4(x))
#     methods::slot(x, name)
#   else
#     attr(x, name, TRUE)
# }
#
# # ' @export
# `@<-.default` <- function(x, name, value) {
#   if (isS4(x))
#     methods::`slot<-`(x, name, value = value)
#   else
#     `attr<-`(x, name, value)
# }
#
# # ' @importFrom utils .AtNames findMatches
# .AtNames.default <- function(x, pattern = "") {
#   if (isS4(x))
#     findMatches(pattern, methods::slotNames(x))
#   else
#     findMatches(pattern, names(attributes(x)))
# }
#
# on_load_register_.AtNames.default <- function() {
#   # if we register via NAMESPACE, we get warning
#   # about overwriting utils:::.AtNmaes.default
#   registerS3method(".AtNames", "default", .AtNames.default)
# }

.onLoad <- function(...) {
  S7::methods_register()
  asNamespace("dotty")$dotify()
  # on_load_register_.AtNames.default()
}

function(args, scope, ..., hoist_mask = function(mask) FALSE) {}

This code segment functions to: Translate array indexing operations by processing subscript expressions, handling logical and integer indices, converting missing arguments to full range selectors, and generating appropriate Fortran array access syntax while managing dimension preservation rules.

```r
[TASK_BEGIN]
r2f_handlers[["["]] <- function(args, scope, ..., hoist_mask = function(mask) FALSE) {
  # Handle array subsetting syntax
  array_expr <- r2f(args[[1]], scope, ...)
  indices <- lapply(args[-1], function(idx) {
    if (is_missing(idx)) {
      # Empty index means whole dimension in Fortran
      return(Fortran(":"))
    }
    r2f(idx, scope, ...)
  })

  # Handle different dimension cases
  index_str <- str_flatten_commas(indices)
  fortran_code <- glue("{array_expr}({index_str})")

  # Determine output dimensions
  original_dims <- array_expr@value@dims
  new_dims <- if (length(indices) == 1 && array_expr@value@rank > 1) {
    # Single index for multidimensional array becomes vector
    list(original_dims[[1]] * original_dims[[2]])
  } else {
    # Preserve remaining dimensions
    original_dims[-seq_along(indices)]
  }

  Fortran(fortran_code, Variable(array_expr@value@mode, new_dims))
}
[TASK_END]
```

r2f_handlers[["["]] <- function(args, scope, ..., hoist_mask = function(mask) FALSE) {
  array_expr <- r2f(args[[1]], scope, ...)
  indices <- lapply(args[-1], function(idx) {
    if (is_missing(idx)) {
      return(Fortran(":"))
    }
    r2f(idx, scope, ...)
  })
  index_str <- str_flatten_commas(indices)
  fortran_code <- glue("{array_expr}({index_str})")
  original_dims <- array_expr@value@dims
  new_dims <- if (length(indices) == 1 && array_expr@value@rank > 1) {
    list(original_dims[[1]] * original_dims[[2]])
  } else {
    original_dims[-seq_along(indices)]
  }
  Fortran(fortran_code, Variable(array_expr@value@mode, new_dims))
}