# hooks.R
# Copyright (C) 2020-2022 Posit Software, PBC

# inline knitr:::merge_list()
merge_list <- function(x, y) {
  x[names(y)] <- y
  x
}

# inline from knitr:::create_fence() from version 1.38
# calculate correct number of fences based on content for correct escaping
create_fence <- function(x, char = "`") {
  r <- paste0("\n", char, "{3,}")
  l <- max(if (grepl(r, x)) attr(gregexpr(r, x)[[1]], "match.length"), 3)
  paste(rep(char, l), collapse = "")
}

# inline from knitr:::eng2lang() from version 1.38
# convert some engine names to language names
eng2lang <- function(x) {
  d <- c(
    asy = "cpp",
    mysql = "sql",
    node = "javascript",
    psql = "sql",
    rscript = "r",
    rcpp = "cpp",
    tikz = "tex"
  )
  x <- tolower(x)
  if (x %in% names(d)) d[x] else x
}


knitr_hooks <- function(format, resourceDir, handledLanguages) {
  knit_hooks <- list()
  opts_hooks <- list()

  # options in yaml (save last yaml.code for source hook)
  lastYamlCode <- NULL
  opts_hooks[["code"]] <- function(options) {
    lastYamlCode <<- options[["yaml.code"]]
    options <- knitr_options_hook(options)
    if (is.null(lastYamlCode)) {
      lastYamlCode <<- options[["yaml.code"]]
    }
    options
  }

  # force eval to 'FALSE' for all chunks if execute: enabled: false
  executeEnabled <- format$execute[["enabled"]]
  if (!is.null(executeEnabled) && executeEnabled == FALSE) {
    opts_hooks[["eval"]] <- function(options) {
      options$eval <- FALSE
      options
    }
  }

  # propagate echo: fenced to echo: true / fenced.echo
  opts_hooks[["echo"]] <- function(options) {
    if (identical(options[["echo"]], "fenced")) {
      options[["echo"]] <- TRUE
      options[["fenced.echo"]] <- TRUE
    } else if (isTRUE(options[["chunk.echo"]])) {
      options[["fenced.echo"]] <- FALSE
    }
    # fenced.echo implies hold (if another explicit override isn't there)
    if (isTRUE(options[["fenced.echo"]])) {
      if (identical(options[["fig.show"]], "asis")) {
        options[["fig.show"]] <- "hold"
      }
      if (identical(options[["results"]], "markup")) {
        options[["results"]] <- "hold"
      }
    }
    # for source-only engine, always set `echo: TRUE`
    if (options[["engine"]] %in% c("embed", "verbatim")) {
      options[["echo"]] <- TRUE
    }

    options
  }

  # forward 'output' to various options. For mainline output, TRUE means flip them
  # from hide, FALSE means hide. For message/warning TRUE means use the
  # global default, FALSE means shut them off entirely)
  opts_hooks[["output"]] <- function(options) {
    output <- options[["output"]]
    if (isFALSE(output)) {
      options[["results"]] <- "hide"
      options[["fig.show"]] <- "hide"
    } else if (identical(output, "asis")) {
      options[["results"]] <- "asis"
    } else {
      if (identical(options[["results"]], "hide")) {
        options[["results"]] <- "markup"
      }
      if (identical(options[["fig.show"]], "hide")) {
        options[["fig.show"]] <- "asis"
      }
    }
    options[["message"]] <- ifelse(
      !isFALSE(output),
      knitr::opts_chunk$get("message"),
      FALSE
    )
    options[["warning"]] <- ifelse(
      !isFALSE(output),
      knitr::opts_chunk$get("warning"),
      FALSE
    )
    options
  }

  # automatically set gifski hook for fig.animate
  opts_hooks[["fig.show"]] <- function(options) {
    # get current value of fig.show
    fig.show <- options[["fig.show"]]

    # use gifski as default animation hook for non-latex output
    if (identical(fig.show, "animate")) {
      if (
        !is_pandoc_latex_output(format) && is.null(options[["animation.hook"]])
      ) {
        options[["animation.hook"]] <- "gifski"
      }

      # fig.show "asis" -> "hold" for fig: labeled chunks
    } else if (identical(fig.show, "asis")) {
      if (is_figure_label(output_label(options))) {
        options[["fig.show"]] <- "hold"
      }
    }

    # return options
    options
  }

  # coalesce echos so that all code is displayed for renderings: [light, dark]
  opts_hooks[["renderings"]] <- function(options) {
    options$fig.show = 'hold'
    options
  }

  opts_hooks[["collapse"]] <- function(options) {
    if (isTRUE(options[["collapse"]])) {
      comment <- options[["comment"]]
      if (is.null(comment) || is.na(comment)) {
        options[["comment"]] <- "##"
      }
    }

    # return options
    options
  }

  # opts hooks for implementing keep-hidden
  register_hidden_hook <- function(option, hidden = option) {
    opts_hooks[[option]] <<- function(options) {
      if (identical(options[[option]], FALSE)) {
        options[[option]] <- TRUE
        for (hide in hidden) {
          options[[paste0(hide, ".hidden")]] <- TRUE
        }
      }
      options
    }
  }
  if (isTRUE(format$render[["keep-hidden"]])) {
    register_hidden_hook("echo", c("source"))
    register_hidden_hook("output", c("output", "plot"))
    register_hidden_hook("include")
    register_hidden_hook("warning")
    register_hidden_hook("message")
  }

  # hooks for marking up output
  default_hooks <- knitr::hooks_markdown()
  delegating_hook <- function(name, hook) {
    function(x, options) {
      x <- default_hooks[[name]](x, options)
      hook(x, options)
    }
  }
  delegating_output_hook = function(type, classes) {
    delegating_hook(type, function(x, options) {
      if (
        identical(options[["results"]], "asis") ||
          isTRUE(options[["collapse"]])
      ) {
        x
      } else {
        # prefix for classes
        classes <- c("cell-output", paste0("cell-output-", classes))
        # add .hidden class if keep-hidden hook injected an option
        if (isTRUE(options[[paste0(type, ".hidden")]])) {
          classes <- c(classes, "hidden")
        }
        output_div(x, NULL, classes)
      }
    })
  }

  # entire chunk
  knit_hooks$chunk <- delegating_hook("chunk", function(x, options) {
    # Do nothing more for some specific chunk content -----

    # Quarto language handler
    if (
      any(as.logical(lapply(handledLanguages, function(lang) {
        prefix <- paste0("```{", lang, "}")
        startsWith(x, prefix)
      }))) &&
        endsWith(x, "```")
    ) {
      return(x)
    }

    # ojs engine should return output unadorned
    if (startsWith(x, "```{ojs}") && endsWith(x, "```")) {
      return(x)
    }

    # verbatim-like and comment knitr's engine should do nothing
    if (options[["engine"]] %in% c("verbatim", "embed", "comment")) {
      return(x)
    }

    # For any other, adding a cell output div -----

    # read some options

    label <- output_label(options)
    fig.cap <- options[["fig.cap"]]
    cell.cap <- NULL
    fig.subcap = options[["fig.subcap"]]

    # If we're preserving cells, we need provide a cell id
    cellId <- NULL
    if (isTRUE(format$render$`notebook-preserve-cells`) && !is.null(label)) {
      cellId <- paste0("cell-", label)
    }

    # fixup duplicate figure labels
    placeholder <- output_label_placeholder(options)
    if (!is.null(placeholder)) {
      figs <- length(regmatches(x, gregexpr(placeholder, x, fixed = TRUE))[[1]])
      for (i in 1:figs) {
        suffix <- ifelse(figs > 1, paste0("-", i), "")
        x <- sub(placeholder, paste0(label, suffix), fixed = TRUE, x)
      }
    }

    # caption output
    if (!is.null(fig.cap) && !is.null(fig.subcap)) {
      cell.cap <- paste0("\n", fig.cap, "\n")
    } else {
      label <- NULL
    }

    # synthesize layout if we have fig.sep
    fig.sep <- options[["fig.sep"]]
    fig.ncol <- options[["fig.ncol"]]
    if (!is.null(fig.sep)) {
      # recycle fig.sep
      fig.num <- options[["fig.num"]] %||% 1L
      fig.sep <- rep_len(fig.sep, fig.num)

      # recyle out.width
      out.width <- options[["out.width"]]
      if (is.null(out.width)) {
        out.width <- 1
      }
      out.width <- rep_len(out.width, fig.num)

      # build fig.layout
      fig.layout <- list()
      fig.row <- c()
      for (i in 1:fig.num) {
        fig.row <- c(fig.row, out.width[[i]])
        if (nzchar(fig.sep[[i]])) {
          fig.layout[[length(fig.layout) + 1]] <- fig.row
          fig.row <- c()
        }
      }
      if (length(fig.row) > 0) {
        fig.layout[[length(fig.layout) + 1]] <- fig.row
      }
      options[["layout"]] <- fig.layout

      # populate layout-ncol from fig.ncol
    } else if (!is.null(fig.ncol)) {
      options[["layout-ncol"]] = fig.ncol
    }

    # alias fig.align to layout-align
    fig.align = options[["fig.align"]]
    if (!is.null(fig.align) && !identical(fig.align, "default")) {
      options["layout-align"] = fig.align
    }

    # alias fig.valign to layout-valign
    fig.valign = options[["fig.valign"]]
    if (!is.null(fig.valign) && !identical(fig.valign, "default")) {
      options["layout-valign"] = fig.valign
    }

    # forward selected attributes
    forward <- c(
      "layout",
      "layout-nrow",
      "layout-ncol",
      "layout-align",
      "layout-valign"
    )
    forwardAttr <- character()
    for (attr in forward) {
      value = options[[attr]]
      if (!is.null(value)) {
        if (identical(attr, "layout")) {
          if (!is.character(value)) {
            value = jsonlite::toJSON(value)
          }
        }
        if (!is.null(value)) {
          forwardAttr <- c(forwardAttr, sprintf("%s=\"%s\"", attr, value))
        }
      }
    }

    # forward any other unknown attributes
    # From knitr 1.44, knitr:::opts_chunk_attr and knitr::opts_chunk$get()
    # should cover all options and knitr will only normalize
    # to their . version the known knitr options.
    # Other options (like quarto specific ones) will keep there original values
    # with - separator.
    knitr_default_opts <- unique(c(
      names(knitr:::opts_chunk_attr),
      names(knitr::opts_chunk$get())
    ))
    # quarto options common with knitr and that will be normalized to
    # fmt: skip
    quarto_knitr_opts <- c(
      "fig.cap", "fig.subcap", "fig.scap", "fig.link", "fig.alt",
      "fig.align", "fig.env", "fig.pos", "fig.num", "out.width"
    )
    # fmt: skip
    quarto_opts <- c(
      "label", "lst-cap", "lst-label", "classes", "panel", "column",
      "tbl-column", "tbl-cap-location", "cap-location", "code-fold",
      "code-summary", "code-overflow", "code-line-numbers",
      "layout", "layout-nrow", "layout-ncol", "layout-align", "layout-valign",
      "output", "html-table-processing",
      # duplicating options as they were normalized in knitr < 1.44
      "fig-column", "fig.column", "fig-cap-location", "fig.cap-location",
      # those options have been aliased in knitr 1.44
      "fig-format", "fig.format", "fig-dpi", "fig.dpi",
      # options created by quarto when `keep-hidden`
      "include.hidden", "source.hidden", "plot.hidden",
      "output.hidden", "warning.hidden", "message.hidden"
    )
    # Other knitr option possibly not in knitr_default_opts
    # fmt: skip
    other_opts <- c(
      "eval", "yaml.code", "code", "file", "params.src", "original.params.src",
      "fenced.echo", "chunk.echo", "lang", "out.width.px", "out.height.px",
      "indent", "class.source", "class.output", "class.message",
      "class.warning", "class.error", "attr.source", "attr.output",
      "attr.message", "attr.warning", "attr.error", "connection", "hash"
    )
    known_opts <- c(
      knitr_default_opts,
      quarto_knitr_opts,
      quarto_opts,
      other_opts
    )
    unknown_opts <- setdiff(names(options), known_opts)
    unknown_opts <- Filter(Negate(is.null), unknown_opts)
    unknown_opts <- Filter(function(opt) !startsWith(opt, "."), unknown_opts)
    # json encode if necessary
    unknown_values <- lapply(
      options[unknown_opts],
      function(value) {
        if (!is.character(value) || length(value) > 1) {
          value <- jsonlite::toJSON(value, auto_unbox = TRUE)
        }
        # will be enclosed in single quotes so escape
        gsub("'", "\\\'", value, fixed = TRUE)
      }
    )
    # append to forward list
    forwardAttr <- c(
      forwardAttr,
      sprintf("%s='%s'", unknown_opts, unknown_values)
    )
    if (length(forwardAttr) > 0) {
      forwardAttr <- paste0(" ", paste(forwardAttr, collapse = " "))
    } else {
      forwardAttr <- ""
    }

    # handle classes
    classes <- c("cell", options[["classes"]])
    if (is.character(options[["panel"]])) {
      classes <- c(classes, paste0("panel-", options[["panel"]]))
    }
    if (is.character(options[["column"]])) {
      classes <- c(classes, paste0("column-", options[["column"]]))
    }
    if (is.character(options[["fig-column"]])) {
      classes <- c(classes, paste0("fig-column-", options[["fig-column"]]))
    } else if (is.character(options[["fig.column"]])) {
      # knitr < 1.44 compatibility where fig- -> fig.
      classes <- c(classes, paste0("fig-column-", options[["fig.column"]]))
    }
    if (is.character(options[["tbl-column"]])) {
      classes <- c(classes, paste0("tbl-column-", options[["tbl-column"]]))
    }
    if (is.character(options[["cap-location"]])) {
      classes <- c(classes, paste0("caption-", options[["cap-location"]]))
    }
    if (is.character(options[["fig-cap-location"]])) {
      classes <- c(
        classes,
        paste0("fig-cap-location-", options[["fig-cap-location"]])
      )
    } else if (is.character(options[["fig.cap-location"]])) {
      # knitr < 1.44 compatibility where fig- -> fig.
      classes <- c(
        classes,
        paste0("fig-cap-location-", options[["fig.cap-location"]])
      )
    }
    if (is.character(options[["tbl-cap-location"]])) {
      classes <- c(
        classes,
        paste0("tbl-cap-location-", options[["tbl-cap-location"]])
      )
    }

    if (isTRUE(options[["include.hidden"]])) {
      classes <- c(classes, "hidden")
    }
    classes <- sapply(
      classes,
      function(clz) ifelse(startsWith(clz, "."), clz, paste0(".", clz))
    )

    # allow table label through
    if (is_table_label(options[["label"]])) {
      label <- options[["label"]]
    }

    if (is.null(label) && !is.null(cellId)) {
      label <- cellId
    }

    if (!is.null(label)) {
      label <- paste0(label, " ")
    }

    # if there is a label, additional classes, a forwardAttr, or a cell.cap
    # then the user is deemed to have implicitly overridden results = "asis"
    # (as those features don't work w/o an enclosing div)
    needCell <- isTRUE(nzchar(label)) ||
      length(classes) > 1 ||
      isTRUE(nzchar(forwardAttr)) ||
      isTRUE(nzchar(cell.cap))
    if (identical(options[["results"]], "asis") && !needCell) {
      x
    } else {
      # Newline first and after to ensure Pandoc Fenced Div is correctly parsed
      paste0(
        "\n",
        options[["indent"]],
        "::: {",
        labelId(label),
        paste(classes, collapse = " "),
        forwardAttr,
        "}\n",
        x,
        "\n",
        cell.cap,
        options[["indent"]],
        ":::\n"
      )
    }
  })
  knit_hooks$source <- function(x, options) {
    # How knitr handles the prompt option for R chunks
    x <- knitr:::hilight_source(x, "markdown", options)
    x <- knitr:::one_string(c('', x))

    class <- options$class.source
    attr <- options$attr.source
    id <- NULL

    # leave some specific engine alone
    if (!options[["engine"]] %in% c("verbatim", "embed")) {
      # Add classes and attributes required for quarto specific features
      class <- paste(class, "cell-code")
      if (isTRUE(options[["source.hidden"]])) {
        class <- paste(class, "hidden")
      }
      if (!identical(format$metadata[["crossref"]], FALSE)) {
        id <- options[["lst-label"]]
        if (!is.null(options[["lst-cap"]])) {
          attr <- paste(attr, paste0('lst-cap="', options[["lst-cap"]], '"'))
        }
      }
      if (identical(options[["code-overflow"]], "wrap")) {
        class <- paste(class, "code-overflow-wrap")
      } else if (identical(options[["code-overflow"]], "scroll")) {
        class <- paste(class, "code-overflow-scroll")
      }
      fold <- options[["code-fold"]]
      if (!is.null(fold)) {
        attr <- paste(
          attr,
          paste0('code-fold="', tolower(as.character(fold)), '"')
        )
      }
      fold <- options[["code-summary"]]
      if (!is.null(fold)) {
        attr <- paste(attr, paste0('code-summary="', as.character(fold), '"'))
      }
      lineNumbers <- options[["code-line-numbers"]]
      if (!is.null(lineNumbers)) {
        attr <- paste(
          attr,
          paste0('code-line-numbers="', tolower(as.character(lineNumbers)), '"')
        )
      }
    }

    # handles same knitr options
    lang <- tolower(options$lang %||% eng2lang(options$engine))

    if (isTRUE(options[["fenced.echo"]])) {
      lang <- NULL
      yamlCode <- lastYamlCode
      if (!is.null(yamlCode)) {
        yamlCode <- Filter(
          function(line) !grepl("\\|\\s+echo:\\s+fenced\\s*$", line),
          yamlCode
        )
        yamlCode <- paste(yamlCode, collapse = "\n")
        if (!nzchar(yamlCode)) {
          x <- trimws(x, "left")
        }
      } else {
        x <- trimws(x, "left")
      }
      ticks <- create_fence(x, "`")
      x <- paste0(
        "\n",
        ticks,
        "{{",
        options[["original.params.src"]],
        "}}\n",
        yamlCode,
        x,
        "\n",
        ticks
      )
    } else {
      # If requested, preserve the code yaml and emit it into the code blocks
      if (isTRUE(format$render$`produce-source-notebook`)) {
        yamlCode <- lastYamlCode
        if (!is.null(yamlCode)) {
          yamlCode <- paste(yamlCode, collapse = "\n")
          if (!nzchar(yamlCode)) {
            x <- trimws(x, "left")
          }
          x <- paste0("\n", yamlCode, x)
        }
      }
    }

    ticks <- create_fence(x, "`")
    attrs <- block_attr(
      id = id,
      lang = lang,
      class = trimws(class),
      attr = attr
    )

    paste0("\n\n", ticks, attrs, x, "\n", ticks, "\n\n")
  }
  knit_hooks$output <- delegating_output_hook("output", c("stdout"))
  knit_hooks$warning <- delegating_output_hook("warning", c("stderr"))
  knit_hooks$message <- delegating_output_hook("message", c("stderr"))
  knit_hooks$plot <- knitr_plot_hook(format)
  knit_hooks$error <- delegating_output_hook("error", c("error"))

  list(
    knit = knit_hooks,
    opts = opts_hooks
  )
}

knitr_plot_hook <- function(format) {
  htmlOutput <- knitr:::is_html_output(format$pandoc$to)
  latexOutput <- is_pandoc_latex_output(format)
  defaultFigPos <- format$render[["fig-pos"]]

  function(x, options) {
    # are we using animation (if we are then ignore all but the last fig)
    fig.num <- options[["fig.num"]] %||% 1L
    fig.cur = options$fig.cur %||% 1L
    tikz <- knitr:::is_tikz_dev(options)
    animate = fig.num > 1 && options$fig.show == 'animate' && !tikz
    if (animate) {
      if (fig.cur < fig.num) {
        return('')
      } else {
        # if it's the gifski hook then call it directly (it will call
        # this function back with the composed animated gif)
        hook <- knitr:::hook_animation(options)
        if (identical(hook, knitr:::hook_gifski)) {
          return(hook(x, options))
        }
      }
    }

    # classes
    classes <- paste0("cell-output-display")
    if (isTRUE(options[["plot.hidden"]])) {
      classes <- c(classes, "hidden")
    }

    # label
    placeholder <- output_label_placeholder(options)
    label <- ifelse(
      is_figure_label(placeholder),
      labelId(placeholder),
      ""
    )
    attr <- label

    # knitr::fix_options will convert out.width and out.height to their
    # latex equivalents, reverse this transformation so our figure layout
    # code can deal directly with percentages
    options <- latex_sizes_to_percent(options)

    # check for optional figure attributes
    keyvalue <- c()
    fig.align <- options[['fig.align']]
    if (!identical(fig.align, "default")) {
      keyvalue <- c(keyvalue, sprintf("fig-align='%s'", fig.align))
    }
    fig.env <- options[['fig.env']]
    if (!identical(fig.env, "figure")) {
      keyvalue <- c(keyvalue, sprintf("fig-env='%s'", fig.env))
    }
    fig.pos <- options[['fig.pos']]
    if (nzchar(fig.pos)) {
      keyvalue <- c(keyvalue, sprintf("fig-pos='%s'", fig.pos))
      # if we are echoing code, there is no default fig-pos, and
      # we are not using a layout then automatically set fig-pos to 'H'
    } else if (
      latexOutput &&
        isTRUE(options[["echo"]]) &&
        length(names(options)[startsWith(names(options), "layout")]) == 0 &&
        is.null(defaultFigPos)
    ) {
      keyvalue <- c(keyvalue, "fig-pos='H'")
    }
    fig.alt <- options[["fig.alt"]]
    escapeAttr <- function(x) gsub("'", "\\'", x, fixed = TRUE)
    if (!is.null(fig.alt) && nzchar(fig.alt)) {
      keyvalue <- c(keyvalue, sprintf("fig-alt='%s'", escapeAttr(fig.alt)))
    }
    fig.scap <- options[['fig.scap']]
    if (!is.null(fig.scap)) {
      keyvalue <- c(keyvalue, sprintf("fig-scap='%s'", escapeAttr(fig.scap)))
    }
    resize.width <- options[['resize.width']]
    if (!is.null(resize.width)) {
      keyvalue <- c(keyvalue, sprintf("resize.width='%s'", resize.width))
    }
    resize.height <- options[['resize.height']]
    if (!is.null(resize.height)) {
      keyvalue <- c(keyvalue, sprintf("resize.height='%s'", resize.height))
    }

    # add keyvalue
    keyvalue <- paste(
      c(
        keyvalue,
        sprintf('width=%s', options[['out.width']]),
        sprintf('height=%s', options[['out.height']]),
        options[['out.extra']]
      ),
      collapse = ' '
    )
    if (nzchar(keyvalue)) {
      attr <- paste(attr, keyvalue)
    }

    # create attributes if we have them
    if (nzchar(attr)) {
      attr <- paste0("{", trimws(attr), "}")
    }

    # special handling for animations
    if (animate) {
      # get the caption (then remove it so the hook doesn't include it)
      caption <- figure_cap(options)
      options[["fig.cap"]] <- NULL
      options[["fig.subcap"]] <- NULL

      # check for latex
      if (is_pandoc_latex_output(format)) {
        # include dependency on animate package
        knitr::knit_meta_add(list(
          rmarkdown::latex_dependency("animate")
        ))

        latexOutput <- paste(
          "```{=latex}",
          latex_animation(x, options),
          "```",
          sep = "\n"
        )

        # add the caption if we have one
        if (nzchar(caption)) {
          latexOutput <- paste0(latexOutput, "\n\n", caption, "\n")
        }

        # enclose in output div
        output_div(latexOutput, label, classes)

        # otherwise assume html
      } else {
        # render the animation
        hook <- knitr:::hook_animation(options)
        htmlOutput <- hook(x, options)
        htmlOutput <- htmlPreserve(htmlOutput)

        # add the caption if we have one
        if (nzchar(caption)) {
          htmlOutput <- paste0(htmlOutput, "\n\n", caption, "\n")
        }

        # enclose in output div
        output_div(htmlOutput, label, classes)
      }
    } else {
      # generate markdown for image
      md <- sprintf("![%s](%s)%s", figure_cap(options), x, attr)

      # enclose in link if requested
      link <- options[["fig.link"]]
      if (!is.null(link)) {
        md <- sprintf("[%s](%s)", md, link)
      }

      # result = "asis" specific
      if (identical(options[["results"]], "asis")) {
        return(md)
      }

      # enclose in output div
      output_div(md, NULL, classes)
    }
  }
}

knitr_options_hook <- function(options) {
  if (!knitr_has_yaml_chunk_options()) {
    # partition yaml options
    results <- partition_yaml_options(options$engine, options$code)
    if (!is.null(results$yaml)) {
      # convert any option with fig- into fig. and out- to out.
      # we need to do this to the yaml options prior to merging
      # so that the correctly interact with standard fig. and
      # out. options provided within knitr
      results$yaml <- normalize_options(results$yaml)
      # alias 'warning' explicitly set here to 'message'
      if (!is.null(results$yaml[["warning"]])) {
        options[["message"]] = results$yaml[["warning"]]
      }
      # merge with other options
      options <- merge_list(options, results$yaml)
      # set code
      options$code <- results$code
    }
    options[["yaml.code"]] <- results$yamlSource
  } else {
    # from knitr 1.44 onwards the normalization is done at parsing time by knitr
    # for all known options c(names(opts_chunk_attr), names(opts_chunk$get()))
    # so normalization here should not be necessary anymore at some point
    # TODO: remove normalization here in a few years
    #       when 1.44 is widely used version
    options <- normalize_options(options)
  }

  # some aliases not normalized
  # from knitr 1.44, `fig.format` and `fig.dpi` are now aliased
  # to `dev` and `dpi`
  # TODO: remove below in a few years when 1.44 is widely used version
  if (!is.null(options[["fig-format"]])) {
    options[["dev"]] <- options[["fig-format"]]
  }
  if (!is.null(options[["fig-dpi"]])) {
    options[["dpi"]] <- options[["fig-dpi"]]
  }

  # if there are line annotations in the code then we need to
  # force disable messages/warnings
  comment_chars <- engine_comment_chars(options$engine)
  pattern <- paste0(".*\\Q", comment_chars[[1]], "\\E\\s*", "<[0-9]+>\\s*")
  if (length(comment_chars) > 1) {
    pattern <- paste0(pattern, ".*\\Q", comment_chars[[2]], "\\E\\s*")
  }
  pattern <- paste0(pattern, "$")
  if (any(grepl(pattern, options$code))) {
    options$warning <- FALSE
    options$results <- "hold"
  }

  # fig.subcap: TRUE means fig.subcap: "" (more natural way
  # to specify that empty subcaps are okay)
  if (isTRUE(options[["fig.subcap"]])) {
    options[["fig.subcap"]] <- ""
  }

  # return options
  options
}

# convert any option with e.g. fig- into fig.
# we do this so that all downstream code can consume a single
# variation of these functions. We support both syntaxes because
# quarto/pandoc generally uses - as a delimeter everywhere,
# however we want to support all existing knitr code as well
# as support all documented knitr chunk options without the user
# needing to replace . with -
# from knitr 1.44 onwards the normalization is done at parsing time by knitr
# for all known options c(names(opts_chunk_attr), names(opts_chunk$get()))
# so normalization here should not be necessary anymore at some point
# TODO: remove normalization here in a few years
#       when 1.44 is widely used version
normalize_options <- function(options) {
  # TODO: knitr 1.44 store all known options as it does the normalization
  #       they are in `c(names(opts_chunk_attr), names(opts_chunk$get()))`
  knitr_options_dashed <- c(
    # Text output
    "strip-white",
    "class-output",
    "class-message",
    "class-warning",
    "class-error",
    "attr-output",
    "attr-message",
    "attr-warning",
    "attr-error",
    # Paged tables
    "max-print",
    "sql-max-print",
    "paged-print",
    "rows-print",
    "cols-print",
    "cols-min-print",
    "pages-print",
    "paged-print",
    "rownames-print",
    # Code decoration
    "tidy-opts",
    "class-source",
    "attr-source",
    # Cache
    "cache-path",
    "cache-vars",
    "cache-globals",
    "cache-lazy",
    "cache-comments",
    "cache-rebuild",
    # Plots
    "fig-path",
    "fig-keep",
    "fig-show",
    "dev-args",
    "fig-ext",
    "fig-width",
    "fig-height",
    "fig-asp",
    "fig-dim",
    "out-width",
    "out-height",
    "out-extra",
    "fig-retina",
    "resize-width",
    "resize-height",
    "fig-align",
    "fig-link",
    "fig-env",
    "fig-cap",
    "fig-alt",
    "fig-scap",
    "fig-lp",
    "fig-pos",
    "fig-subcap",
    "fig-ncol",
    "fig-sep",
    "fig-process",
    "fig-showtext",
    # Animation
    "animation-hook",
    "ffmpeg-bitrate",
    "ffmpeg-format",
    # Code chunk
    "ref-label",
    # Language engines
    "engine-path",
    "engine-opts",
    "opts-label",
    # Other chunk options
    "R-options"
  )
  # Un-normalize knitr options, and replace any existing options (e.g default one)
  for (name in knitr_options_dashed) {
    if (name %in% names(options)) {
      options[[gsub("-", ".", name)]] <- options[[name]]
      options[[name]] <- NULL
    }
  }
  options
}


partition_yaml_options <- function(engine, code) {
  # mask out empty blocks
  if (length(code) == 0) {
    return(list(
      yaml = NULL,
      yamlSource = NULL,
      code = code
    ))
  }
  comment_chars <- engine_comment_chars(engine)
  comment_start <- paste0(comment_chars[[1]], "| ")
  comment_end <- ifelse(length(comment_chars) > 1, comment_chars[[2]], "")

  # check for option comments
  match_start <- startsWith(code, comment_start)
  match_end <- endsWith(trimws(code, "right"), comment_end)
  matched_lines <- match_start & match_end

  # has to have at least one matched line at the beginning
  if (isTRUE(matched_lines[[1]])) {
    # divide into yaml and code
    if (all(matched_lines)) {
      yamlSource <- code
      code <- c()
    } else {
      last_match <- which.min(matched_lines) - 1
      yamlSource <- code[1:last_match]
      code <- code[(last_match + 1):length(code)]
    }

    # trim right
    if (any(match_end)) {
      yamlSource <- trimws(yamlSource, "right")
    }

    # extract yaml from comments, then parse it
    yaml <- substr(
      yamlSource,
      nchar(comment_start) + 1,
      nchar(yamlSource) - nchar(comment_end)
    )
    yaml_options <- yaml::yaml.load(yaml, eval.expr = TRUE)
    if (!is.list(yaml_options) || length(names(yaml_options)) == 0) {
      warning(
        "Invalid YAML option format in chunk: \n",
        paste(yaml, collapse = "\n"),
        "\n"
      )
      yaml_options <- list()
    }

    # extract code
    if (length(code) > 0 && knitr:::is_blank(code[[1]])) {
      code <- code[-1]
      yamlSource <- c(yamlSource, "")
    }

    list(
      yaml = yaml_options,
      yamlSource = yamlSource,
      code = code
    )
  } else {
    list(
      yaml = NULL,
      yamlSource = NULL,
      code = code
    )
  }
}

engine_comment_chars <- function(engine) {
  comment_chars <- list(
    r = "#",
    python = "#",
    julia = "#",
    scala = "//",
    matlab = "%",
    csharp = "//",
    fsharp = "//",
    c = c("/*", "*/"),
    css = c("/*", "*/"),
    sas = c("*", ";"),
    powershell = "#",
    bash = "#",
    sql = "--",
    mysql = "--",
    psql = "--",
    lua = "--",
    Rcpp = "//",
    cc = "//",
    stan = "#",
    octave = "#",
    fortran = "!",
    fortran95 = "!",
    awk = "#",
    gawk = "#",
    stata = "*",
    java = "//",
    groovy = "//",
    kotlin = "//",
    sed = "#",
    perl = "#",
    ruby = "#",
    tikz = "%",
    js = "//",
    d3 = "//",
    node = "//",
    sass = "//",
    coffee = "#",
    go = "//",
    asy = "//",
    haskell = "--",
    dot = "//",
    apl = "\u235D",
    ocaml = c("(*", "*)"),
    q = "/",
    rust = "//"
  )
  comment_chars[[engine]] %||% "#"
}


# helper to create an output div
output_div <- function(x, label, classes, attr = NULL) {
  div <- "::: {"
  if (!is.null(label) && nzchar(label)) {
    div <- paste0(div, labelId(label), " ")
  }
  paste0(
    div,
    paste(paste0(".", classes), collapse = " "),
    ifelse(!is.null(attr), paste0(" ", attr), ""),
    "}\n",
    x,
    "\n:::\n\n"
  )
}

labelId <- function(label) {
  if (!is.null(label) && !startsWith(label, "#")) paste0("#", label) else label
}

figure_cap <- function(options) {
  output_label <- output_label(options)
  if (is.null(output_label) || is_figure_label(output_label)) {
    fig.cap <- options[["fig.cap"]]
    fig.subcap <- options[["fig.subcap"]]
    if (length(fig.subcap) != 0) {
      fig.subcap
    } else if (length(fig.cap) != 0) {
      fig.cap
    } else {
      ""
    }
  } else {
    ""
  }
}


output_label <- function(options) {
  label <- options[["label"]]
  if (!is.null(label) && grepl("^#?(fig)-", label)) {
    label
  } else {
    NULL
  }
}

output_label_placeholder <- function(options) {
  kPlaceholder <- "D08295A6-16DC-499D-85A8-8BA656E013A2"
  label <- output_label(options)
  if (is_figure_label(label)) paste0(label, kPlaceholder) else NULL
}

is_figure_label <- function(label) {
  is_label_type("fig", label)
}

is_table_label <- function(label) {
  is_label_type("tbl", label)
}

is_label_type <- function(type, label) {
  !is.null(label) && grepl(paste0("^#?", type, "-"), label)
}


block_attr <- function(id = NULL, lang = NULL, class = NULL, attr = NULL) {
  id <- labelId(id)
  if (!is.null(lang) && nzchar(lang)) {
    lang <- paste0(".", lang)
  } else {
    lang <- NULL
  }
  if (!is.null(class)) {
    class <- paste(block_class(class))
  }
  attributes <- c(id, lang, class, attr)
  attributes <- paste(attributes[!is.null(attributes)], collapse = " ")
  if (nzchar(attributes)) paste0("{", attributes, "}") else ""
}

block_class <- function(x) {
  if (length(x) > 0) gsub('^[.]*', '.', unlist(strsplit(x, '\\s+')))
}

latex_sizes_to_percent <- function(options) {
  #  \linewidth
  width <- options[["out.width"]]
  if (!is.null(width)) {
    latex_width <- regmatches(
      width,
      regexec("^([0-9\\.]+)\\\\linewidth$", width)
    )
    if (length(latex_width[[1]]) > 1) {
      width <- paste0(as.numeric(latex_width[[1]][[2]]) * 100, "%")
      options[["out.width"]] <- width
    }
  }
  # \textheight
  height <- options[["out.height"]]
  if (!is.null(height)) {
    latex_height <- regmatches(
      height,
      regexec("^([0-9\\.]+)\\\\textheight$", height)
    )
    if (length(latex_height[[1]]) > 1) {
      height <- paste0(as.numeric(latex_height[[1]][[2]]) * 100, "%")
      options[["out.height"]] <- height
    }
  }
  options
}

# ported from:
# https://github.com/yihui/knitr/blob/f8f90baad99d873202b8dc8042eab7a88fac232f/R/hooks-latex.R#L151-L171
latex_animation <- function(x, options) {
  fig.num = options$fig.num %||% 1L

  ow = options$out.width
  # maxwidth does not work with animations
  if (identical(ow, '\\maxwidth')) {
    ow = NULL
  }
  if (is.numeric(ow)) {
    ow = paste0(ow, 'px')
  }
  size = paste(
    c(
      sprintf('width=%s', ow),
      sprintf('height=%s', options$out.height),
      options$out.extra
    ),
    collapse = ','
  )

  aniopts = options$aniopts
  aniopts = if (is.na(aniopts)) NULL else gsub(';', ',', aniopts)
  size = paste(c(size, sprintf('%s', aniopts)), collapse = ',')
  if (nzchar(size)) {
    size = sprintf('[%s]', size)
  }
  sprintf(
    '\\animategraphics%s{%s}{%s}{%s}{%s}',
    size,
    1 / options$interval,
    sub(sprintf('%d$', fig.num), '', xfun::sans_ext(x)),
    1L,
    fig.num
  )
}

is_ipynb_output <- function(to) {
  identical(to, "ipynb")
}
