mdcontent: Manage content in markdown files

# Copyright (C) 2017  Metrum Research Group, LLC
#
# This file is part of mdcontent
#
# mdcontent is free software: you can redistribute it and/or modify it
# under the terms of the GNU General Public License as published by
# the Free Software Foundation, either version 2 of the License, or
# (at your option) any later version.
#
# mdcontent is distributed in the hope that it will be useful, but
# WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with mdcontent  If not, see <http://www.gnu.org/licenses/>.


drop_codeblock <- function(x,clip="```") {
  cl <- grepl(clip,x,fixed=TRUE)
  if(!any(cl)) return(x)
  wcl <- which(cl)
  from <- wcl[seq(1,length(wcl),2)]
  to <- wcl[seq(2,length(wcl),2)]
  keep <- !vector(mode="logical", length(x))
  for(i in seq_along(from)) {
    a <- from[i]
    b <- to[i]
    keep[seq(a,b,1)] <- FALSE
  }
  x[keep]
}


rm_hash <- function(x) gsub("^\\#+ ", " ",x)

make_hash <- function(x) {
  x <- gsub("[[:punct:]]", "", tolower(x))
  x <- gsub(" ", "-", x)
  paste0("#",x)
}

##' Generate link text for an anchor
##'
##' @param x section or subsection header
##' @param link_prefix used to connect source document to target
##'
##' @examples
##' make_link("# How to ski!")
##'
##' @export
make_link <- function(x,link_prefix="") {
  x <- rm_hash(x)
  x <- gsub("^ +| +$", "", x)
  x0 <- x
  x <- paste0(link_prefix,make_hash(x))
  paste0("[",x0,"](",x,")")
}

to_lvl1 <- function(x,link=TRUE,link_prefix="") {
  if(link) x <- make_link(x,link_prefix=link_prefix)
  paste0("- ",x)
}

to_lvl2 <- function(x,link=TRUE,link_prefix="") {
  if(link) x <- make_link(x,link_prefix=link_prefix)
  paste0("  - ",x)
}

to_lvl3 <- function(x,link=TRUE,link_prefix="") {
  if(link) x <- make_link(x,link_prefix=link_prefix)
  paste0("    - ",x)
}

ul2hash <- function(x) {
  h1 <- grepl("^===+", x)
  h2 <- grepl("^---+",x)
  h1sub <- which(h1)-1
  h2sub <- which(h2)-1
  x[h1sub] <- paste0("# ",  x[h1sub])
  x[h2sub] <- paste0("## ", x[h2sub])
  x <- x[!h1]
  x <- x[!h2]
  x
}

get_headers <- function(x) {
  x[grepl("^\\#{1,3}",x)]
}

find_lvl <- function(x,n) {
  substr(x,1,n+1)==paste0(paste(rep("#",n),collapse=""), " ")
}

##' Get a table of contents
##'
##' @param target directory to scan for files
##' @param ext file extension
##' @param link_prefix used to link between \code{toc} and file
##' @param skip character vector of file names to skip
##' @export
get_toc <- function(target='.',ext=".md",link_prefix=".",skip=NULL) {
  ext <- paste0("*\\",ext,"$")
  f <- list.files(target,pattern=ext,full.names=TRUE)
  if(is.character(skip)) {
    base <- basename(f)
    found <- is.element(base,skip)
    f <- f[!found]
  }
  labels <- basename(f)
  out <- lapply(f,get_toc_file,link_prefix=link_prefix)
  names(out) <- labels
  out
}
##' @param file the name of a file for building toc
##' @rdname get_toc
##' @export
get_toc_file <- function(file,link_prefix) {
  get_toc_text(readLines(file,warn=FALSE),file=file)
}
##' @param text to parse
##' @param split logical; if \code{TRUE}, \code{text} will be split on newline prior
##' to processing
##' @rdname get_toc
##'
##' @examples
##' text <- '
##' How to Ski!
##' ==============
##' This document will teach you how to ski.  First, find snow.
##'
##' ## Finding some snow
##' To find snow, it is best to go somewhere cold.
##'
##' ### Cold places in the United States
##' Try Minnesota. It is pretty code there.
##' '
##' get_toc_text(text)
##'
##' @export
get_toc_text <- function(text,file=character(0),link_prefix=".",split=FALSE) {
  if(split) text <- unlist(strsplit(text,split="\n"),use.names=FALSE)
  data <- drop_codeblock(text)
  data <- ul2hash(data)
  toc <- get_headers(data)
  l3 <- find_lvl(toc,3)
  l2 <- find_lvl(toc,2)
  l1 <- find_lvl(toc,1)
  link_prefix <- file.path(link_prefix,basename(file))
  toc[l1] <- to_lvl1(toc[l1],link_prefix=link_prefix)
  toc[l2] <- to_lvl2(toc[l2],link_prefix=link_prefix)
  toc[l3] <- to_lvl3(toc[l3],link_prefix=link_prefix)
  toc
}


##' Write a table of contents
##'
##' @param x toc contents; the result of \code{\link{get_toc}}
##' @param file output file name
##' @param title title for the toc page
##' @export
write_toc1 <- function(x,file="toc.md",title="Table of contents") {
  if(file.exists(file)) file.remove(file)
  cat(file=file,paste0("# ", title, "\n"))
  for(i in seq_along(x)) {
    name <- names(x)[i]
    cat(file=file,paste0("## ", name),"\n",append=TRUE)
    cat(file=file,paste(x[[i]],collapse="\n"),"\n",append=TRUE)
  }
  return(file)
}



found_toc <- function(x,y) {
  sum(x)==1 & sum(y)==1
}

find_toc <- function(x) {
  start_toc <- grepl(GLOBAL[["start_toc"]],x,fixed=TRUE)
  end_toc <- grepl(GLOBAL[["end_toc"]],x,fixed=TRUE)
  if(!found_toc(start_toc,end_toc)) {
    return(NULL)
  }
  c(which(start_toc)[1],which(end_toc)[1])
}

##' Insert table of contents into markdown file
##'
##' @param file file name
##' @export
insert_toc_file <- function(file) {
  x <- readLines(file)
  x <- insert_toc_text(x)
  x <- writeLines(con=file,x)
  return(invisible(file))
}

##' @param x text to modify
##' @rdname insert_toc_file
##' @export
insert_toc_text <- function(x) {
  where <- find_toc(x)
  spcr <- NULL
  if(is.null(where)) {
    where <- c(1,2)
    spcr <- c(" "," ")
    x <- c(start_toc_,end_toc_,x)
  }
  a <- x[1:where[1]]
  b <- x[where[2]:length(x)]
  return(c(a,get_toc_text(x),spcr,b))
}