PARSER_SETTINGS <- rlang::env(
  parentheses.as.string = FALSE
)


evalToken <- function(token, lhs, rhs) {
  UseMethod("evalToken")
}


#' @export
evalToken.LavOperator <- function(token, lhs, rhs) {
  if (is.LavToken(rhs)) rhs <- list(rhs)
  if (is.LavToken(lhs)) lhs <- list(lhs)

  mod_stopif(!is.atomic(lhs) && is.LavOperator(lhs$op),
    paste0("Unexpected operator ", highlightErrorToken(lhs$op)),
    only.format.header = TRUE
  )

  mod_stopif(!is.atomic(rhs) && is.LavOperator(rhs$op),
    paste0("Unexpected operator ", highlightErrorToken(rhs$op)),
    only.format.header = TRUE
  )

  list(lhs = lhs, op = token, rhs = rhs)
}


#' @export
evalToken.LavToken <- function(token, lhs, rhs) {
  token
}


#' @export
evalToken.LavName <- function(token, lhs, rhs) {
  mod_stopif(is.LavToken(rhs),
    paste0("Unexpected token ", highlightErrorToken(rhs)),
    only.format.header = TRUE
  )
  mod_stopif(is.LavToken(lhs),
    paste0("Unexpected token ", highlightErrorToken(lhs)),
    only.format.header = TRUE
  )
  token
}


#' @export
evalToken.LavNumeric <- function(token, lhs, rhs) {
  mod_stopif(is.LavToken(rhs),
    "Unexpected token:\n",
    highlightErrorToken(rhs),
    only.format.header = TRUE
  )

  mod_stopif(is.LavToken(lhs),
    "Unexpected token:\n",
    highlightErrorToken(lhs),
    only.format.header = TRUE
  )

  token
}


#' @export
evalToken.LavAdd <- function(token, lhs, rhs) {
  if (is.null(rhs)) {
    mod_msg_stop(
      paste0("Expected token after `+` ", highlightErrorToken(token)),
      only.format.header = TRUE
    )

  } else if (is.null(lhs)) {
    mod_msg_stop(
      paste0("Expected token before `+` ", highlightErrorToken(token)),
      only.format.header = TRUE
    )
  }

  if (is.LavToken(rhs)) {
    rhs <- list(rhs)
  }
  if (is.LavToken(lhs)) {
    lhs <- list(lhs)
  }
  c(lhs, rhs)
}


#' @export
evalToken.LavModify <- function(token, lhs, rhs) {
  structure(rhs, modifier = lhs)
}


#' @export
evalToken.LavSubtract <- function(token, lhs, rhs) {
  out <- paste0(token, rhs)
  attributes(out) <- attributes(rhs)

  out
}


#' @export
evalToken.LavBlank <- function(token, lhs, rhs) {
  NULL
}


#' @export
evalToken.LavInteraction <- function(token, lhs, rhs) {
  if (!"LavName" %in% class(lhs) || !"LavName" %in% class(rhs)) {
    mod_msg_stop(
      paste0("Interactions are reserved for objects ", highlightErrorToken(token)),
      only.format.header = TRUE
    )
  }
  out <- paste0(lhs, token, rhs)
  attributes(out) <- attributes(lhs)
  out
}


#' @export
evalToken.LavComment <- function(token, lhs, rhs) {
  NULL
}


#' @export
evalToken.LavFunction <- function(token, lhs, rhs) {
  functionCall <- paste0(token, stringr::str_c(unlist(rhs), collapse = ","), ")")
  out <- eval(rlang::parse_expr(functionCall), envir = modEnv)
  attributes(out) <- attributes(token)
  out
}


#' @export
evalToken.LeftBracket <- function(token, lhs, rhs) {
  if (PARSER_SETTINGS$parentheses.as.string)
    return(paste0("(", stringifyTokens(rhs), ")"))

  rhs
}


#' @export
evalToken.RightBracket <- function(token, lhs, rhs) {
  lhs
}


stringifyTokens <- function(tokens) {
  if (all(c("lhs", "op", "rhs") %in% names(tokens))) {
    lhs <- paste0(unlist(tokens$lhs), collapse = "+")
    op  <- unlist(tokens$op)[[1L]]
    rhs <- paste0(unlist(tokens$rhs), collapse = "+")
    out <- paste0(lhs, op, rhs)

  } else {
    out <- paste0(unlist(tokens), collapse="")
  }

  # This code is ugly as f*
  class(out) <- c("LavObject", "LavName", "LavToken")
  attr(out, "pos") <- attr(unlist(tokens)[[1L]], "pos")
  attr(out, "priority") <- 13
  attr(out, "lineNumber") <- attr(unlist(tokens)[[1L]], "lineNumber")

  out
}


#' @export
evalToken.LavSeperator <- function(token, lhs, rhs) {
  if ("LavToken" %in% class(rhs)) {
    rhs <- list(rhs)
  }
  if ("LavToken" %in% class(lhs)) {
    lhs <- list(lhs)
  }
  c(lhs, rhs)
}


evalTokens <- function(syntaxTree) {
  if (is.null(syntaxTree) || length(syntaxTree) == 0) {
    return(NULL)
  }

  lhs <- evalTokens(syntaxTree$lhs)
  rhs <- evalTokens(syntaxTree$rhs)

  return(evalToken(syntaxTree$node,
                   lhs = lhs,
                   rhs = rhs))
}


parseSyntaxTrees <- function(syntaxTrees) {
  lapply(syntaxTrees, evalTokens)
}


createParTableBranch <- function(syntaxTree) {
  if (is.null(syntaxTree)) {
    return(NULL)
  }
  rhs <- vector("character", length(syntaxTree[["rhs"]]))
  mod <- rhs

  for (i in seq_along(syntaxTree[["rhs"]])) {
    rhs[[i]] <- getTokenString(syntaxTree[["rhs"]][[i]])
    modifier <- getTokenString(attr(syntaxTree[["rhs"]][[i]], "modifier"))
    if (!is.null(modifier)) {
      mod[[i]] <- modifier
    }
  }
  lhs <- vapply(syntaxTree[["lhs"]], FUN.VALUE = character(1L),
                FUN = getTokenString)
  lhs <- vapply(lhs, FUN.VALUE = character(length(rhs)),
                FUN = function(x, len)
                  rep(x, len),
                len = length(rhs)) |> as.vector()
  op <- rep(getTokenString(syntaxTree$op), length(rhs))
  parTable <- data.frame(lhs = lhs, op = op, rhs = rhs, mod = mod)

  # post-processing
  parTable[parTable$op == ":=", "mod"] <- parTable[parTable$op == ":=", "lhs"]
  intercepts <- parTable$op == "~" & parTable$rhs == "1"
  parTable[intercepts, "op"]  <- "~1"
  parTable[intercepts, "rhs"] <- ""

  parTable
}


#' Generate parameter table for \code{lavaan} syntax
#'
#' @param syntax model syntax
#' @param parentheses.as.string Should parentheses be read parsed as literal strings?
#'
#' @return \code{data.frame} with columns \code{lhs, op, rhs, mod}
#' @export modsemify
#'
#' @examples
#' library(modsem)
#' m1 <- '
#'   # Outer Model
#'   X =~ x1 + x2 +x3
#'   Y =~ y1 + y2 + y3
#'   Z =~ z1 + z2 + z3
#'
#'   # Inner model
#'   Y ~ X + Z + X:Z
#''
#' modsemify(m1)
modsemify <- function(syntax, parentheses.as.string = FALSE) {
  if (is.null(syntax)) return(NULL)

  mod_stopif(!is.character(syntax) && length(syntax) > 1,
    "Syntax is not a string og length 1"
  )

  on.exit({
    PARSER_SETTINGS$parentheses.as.string <- FALSE
  })

  if (parentheses.as.string)
    PARSER_SETTINGS$parentheses.as.string <- TRUE

  syntaxTrees <- createSyntaxTreesSyntax(syntax)
  parsedTrees <- parseSyntaxTrees(syntaxTrees)
  purrr::list_rbind(lapply(parsedTrees,
                           FUN = createParTableBranch))
}


ungroupParTable <- function(parTable) {
  if (!"group" %in% colnames(parTable) || length(getGroupsParTable(parTable)) <= 1L)
    return(parTable)

  parUnique <- unique(parTable[c("lhs", "op", "rhs")])
  parTableUngrouped <- NULL

  for (i in seq_len(NROW(parUnique))) {
    lhs <- parUnique[i, "lhs"]
    op  <- parUnique[i, "op"]
    rhs <- parUnique[i, "rhs"]

    modifiers <- parTable[parTable$lhs == lhs &
                          parTable$op  == op  &
                          parTable$rhs == rhs, "mod"]

    modifiers[modifiers == ""] <- NA

    if (all(is.na(modifiers)))
      mod <- ""
    else
      mod <- sprintf("c(%s)", paste0(modifiers, collapse = ", "))

    parTableUngrouped <- rbind(
      parTableUngrouped,
      data.frame(lhs = lhs, op = op, rhs = rhs, mod = mod)
    )
  }

  parTableUngrouped
}


parTableToSyntax <- function(parTable, removeColon = FALSE) {
  if (is.null(parTable)) return(NULL)

  parTable <- ungroupParTable(parTable)

  intercepts <- parTable$op == "~1"
  parTable[intercepts, "rhs"] <- "1"
  parTable[intercepts, "op"]  <- "~"

  out <- ""
  if (removeColon) {
    parTable$lhs <- stringr::str_remove_all(parTable$lhs, ":")
    parTable$rhs <- stringr::str_remove_all(parTable$rhs, ":")
    parTable$mod <- stringr::str_remove_all(parTable$mod, ":")
  }

  for (i in seq_len(NROW(parTable))) {
    if (parTable[["mod"]][[i]] != "" && parTable[["op"]][[i]] != ":=")
      modifier <- paste0(parTable[["mod"]][[i]], "*")
    else
      modifier <- ""

    line <- paste0(parTable[["lhs"]][[i]], " ",
                   parTable[["op"]][[i]], " ",
                   modifier,
                   parTable[["rhs"]][[i]], "\n")
    out <- paste0(out, line)
  }

  out
}


mergeTokens <- function(x, y) {
  mod_stopif(!"LavName" %in% class(x) || !"LavName" %in% class(x),
    paste0("Interactions are reserved for objects ", highlightErrorToken(x)),
    only.format.header = TRUE
  )

  out <- paste0(x, y)
  attributes(out) <- attributes(x)
  out

}
