---
title: "DBI specification"
author: "Kirill Müller"
date: "`r Sys.Date()`"
output:
  rmarkdown::html_document:
    smart: FALSE
    toc: TRUE
    toc_float: TRUE
abstract: >
  The DBI package defines the generic DataBase Interface for R.
  The connection to individual DBMS is provided by other packages that import DBI
  (so-called *DBI backends*).
  This document formalizes the behavior expected by the methods declared in
  DBI and implemented by the individual backends.
  
  To ensure maximum portability and exchangeability, and to reduce the effort
  for implementing a new DBI backend, the DBItest package defines
  a comprehensive set of test cases that test conformance to the DBI
  specification.
  This document is derived from comments in the test definitions of
  the DBItest package.
  Any extensions or updates to the tests will be reflected in
  this document.
vignette: >
  %\VignetteIndexEntry{DBI specification}
  %\VignetteEngine{knitr::rmarkdown}
  %\VignetteEncoding{UTF-8}
---

```{r echo = FALSE}
library(magrittr)
library(xml2)
knitr::opts_chunk$set(echo = FALSE)
r <- rprojroot::is_r_package$make_fix_file()
```

```{r error=TRUE}
rd_db <- tools::Rd_db(dir = r())

Links <- tools::findHTMLlinks()

html_topic <- function(name) {
  rd <- rd_db[[paste0(name, ".Rd")]]

  conn <- textConnection(NULL, "w")
  on.exit(close(conn))

  #tools::Rd2HTML(rd, conn, Links = Links)
  tools::Rd2HTML(rd, conn)

  textConnectionValue(conn)
}

xml_topic <- function(name, patcher) {
  html <- html_topic(name)
  x <- read_html(paste(html, collapse = "\n"))

  # No idea why this is necessary when embedding HTML in Markdown
  codes <- x %>% xml_find_all("//code[contains(., '$')]")
  xml_text(codes) <- gsub("[$]", "\\\\$", xml_text(codes))

  xx <- x %>% xml_find_first("/html/body")
  xx %>% xml_find_first("//table") %>% xml_remove()
  patcher(xx)
}

asis_topic <- function(name, patcher = identity) {
  xml <- lapply(name, xml_topic, patcher = patcher)
  asis <- sapply(xml, as.character) %>% paste(collapse = "\n")
  knitr::asis_output(asis)
}

patch_package_doc <- function(x) {
  x %>% xml_find_first("//h3") %>% xml_remove

  remove_see_also_section(x)
  remove_authors_section(x)

  x
}

move_contents_of_usage_section <- function(x) {
  # http://stackoverflow.com/a/3839299/946850
  usage_contents <-
    x %>%
    xml_find_all(
      "//h3[.='Usage']/following-sibling::node() [not(self::h3)] [count(preceding-sibling::h3)=2]")

  usage_text <-
    usage_contents %>%
    xml_find_first("//pre") %>% 
    xml_text

  h3 <- x %>% xml_find_first("//h3")

  intro_text <-
    read_xml(
      paste0(
        "<p>This section describes the behavior of the following method",
        if (length(grep("[(]", strsplit(usage_text, "\n")[[1]])) > 1) "s" else "",
        ":</p>")
    )

  xml_add_sibling(
    h3,
    intro_text,
    .where = "before")
  lapply(usage_contents, xml_add_sibling, .x = h3, .copy = FALSE, .where = "before")

  x %>% xml_find_first("//h3[.='Usage']") %>% xml_remove
  x
}

move_additional_arguments_section <- function(x) {
  # http://stackoverflow.com/a/3839299/946850 and some trial and error
  additional_arguments <- x %>%
    xml_find_all(
      "//h3[.='Additional arguments'] | //h3[.='Additional arguments']/following-sibling::node()[following-sibling::h3]")

  after_arg <- x %>% xml_find_first("//h3[text()='Arguments']/following-sibling::h3")

  lapply(additional_arguments, xml_add_sibling, .x = after_arg, .copy = FALSE, .where = "before")

  x
}

remove_see_also_section <- function(x) {
  # http://stackoverflow.com/a/3839299/946850 and some trial and error
  x %>%
    xml_find_all(
      "//h3[.='See Also'] | //h3[.='See Also']/following-sibling::node()[following-sibling::h3]") %>%
    xml_remove()
  x
}

remove_authors_section <- function(x) {
  # http://stackoverflow.com/a/3839299/946850 and some trial and error
  x %>%
    xml_find_all(
      "//h3[.='Author(s)'] | //h3[.='Author(s)']/following-sibling::node()[following-sibling::h3]") %>%
    xml_remove()
  x
}

patch_method_doc <- function(x) {
  move_contents_of_usage_section(x)
  remove_see_also_section(x)
  move_additional_arguments_section(x)
  x
}

asis_topic("DBI-package", patch_package_doc)
topics <- c(
  "dbDataType",
  "dbConnect",
  "dbDisconnect",
  "dbSendQuery",
  "dbFetch",
  "dbClearResult",
  "dbBind",
  "dbGetQuery",
  "dbSendStatement",
  "dbExecute",
  "dbQuoteString",
  "dbQuoteIdentifier",
  "dbReadTable",
  "dbWriteTable",
  "dbListTables",
  "dbExistsTable",
  "dbRemoveTable",
  "dbIsValid",
  "dbHasCompleted",
  "dbGetStatement",
  "dbGetRowCount",
  "dbGetRowsAffected",
  "transactions",
  "dbWithTransaction"
)

asis_topic(topics, patch_method_doc)
```