#' Rd Converter for \special{MoinMoin} Markup
#'
#' This function takes (or obtains) output of the \code{\link[tools:parse_Rd]{parse_Rd}} function and produces a help page in \special{MoinMoin} markup. It uses internal functions from \code{\link[tools:tools]{tools}}, so these are subject to change. See \code{\link[tools:Rd2txt]{Rd2txt}} for futher details. 
#' @param Rd an parsed Rd object to use as input, or a file path for an Rd file.
#' @param out a filename or connection object to which to write the output. names to be applied to \code{x}, if unnamed, or to replace existing names.
#' @param append a logical value indicating whether the output file should be openned in append or write mode.
#' @param package the package to list in the output.
#' @param defines string(s) to use in #ifdef tests.
#' @param stages at which stage ("build", "install", or "render") should \\Sexpr macros be executed? See \code{\link[tools:Rd2txt]{Rd2txt}} for futher details.
#' @param outputEncoding see \code{\link[tools:Rd2txt]{Rd2txt}} for futher details.
#' @param fragment a logical value indicating if fragments of Rd files be accepted.See \code{\link[tools:Rd2txt]{Rd2txt}} for futher details.
#' @param depth an integer indicating the heading level at which to start.
#' @param prepared a local value indicating if the Rd object supplied has aleardy been prepared for processing by \code{tools:::prepare_Rd()}.
#' @param ... additional parameters to pass to \code{tools:::prepare_Rd()} for use in parsing an Rd source. See \code{\link[tools:parse_Rd]{parse_Rd}}.
#' @author Ian Riley \email{ian@@riley.asia}
#' @return This function is executed to write a help page converted to \special{MoinMoin} markup. The value is the name of the output file (invisibly).
# @examples
# To come!
#' @export
Rd2moin <- function(Rd, out = "", append = FALSE, package = "", defines = .Platform$OS.type,
	stages = "render", outputEncoding = "UTF-8", fragment = FALSE, depth = 1,
	prepared = FALSE, ...) #!moin
		
{
	#!moin TODO escape camelcase with !	
		
	code_quote = TRUE
	fcodes <- c("l", "c", "r")
	
	buffer <- character()	# Lines to be written to con
	# Newlines are treated as a separate input lines
	
	# For tacking
	linestart <- TRUE		# At start of line?
	dropBlank <- FALSE		# Drop initial blank lines?
	haveBlanks <- 0L			# How many blank lines have just been written?
	enumItem <- 0L			# Last enumeration item number
	inEqn <- FALSE			# Should we do edits needed in an eqn?
	sectionLevel <- depth 	#!moin Start from 1 form MoinMoin headings
   
	startCapture <- function() {
		save <- list(buffer=buffer, linestart=linestart, dropBlank=dropBlank,
		haveBlanks=haveBlanks, enumItem=enumItem, inEqn=inEqn)
		buffer <<- character()
		linestart <<- TRUE
		dropBlank <<- FALSE
		haveBlanks <<- 0L
		enumItem <<- 0L
		inEqn <<- FALSE
		save
	}
 
	endCapture <- function(saved) {
		result <- buffer
		buffer <<- saved$buffer
		linestart <<- saved$linestart
		dropBlank <<- saved$dropBlank
		haveBlanks <<- saved$haveBlanks
		enumItem <<- saved$enumItem
		inEqn <<- saved$inEqn
		result
	}
 
	## for efficiency
	WriteLines <- 
	if (outputEncoding == "UTF-8" ||
		(outputEncoding == "" && l10n_info()[["UTF-8"]])) {
		function(x, con, outputEncoding, ...) {
			writeLines(x, con, useBytes = TRUE, ...)
		}
	} else {
		function(x, con, outputEncoding, ...) {
			x <- iconv(x, "UTF-8", outputEncoding, sub="byte", mark=FALSE)
			writeLines(x, con, useBytes = TRUE, ...)
		}
	}
 
	put <- function(...) {
		txt <- paste0(..., collapse="")
		trail <- grepl("\n$", txt)
		# Convert newlines
		txt <- strsplit(txt, "\n", fixed = TRUE)[[1L]]
		if (dropBlank) {
			while(length(txt) && grepl("^[[:space:]]*$", txt[1L]))
			txt <- txt[-1L]
			if (length(txt)) dropBlank <<- FALSE
		}
		if (!length(txt)) return()
		haveBlanks <<- 0
 
		if (linestart) buffer <<- c(buffer, txt)
		else if (length(buffer)) {
			buffer[length(buffer)] <<-
				paste0(buffer[length(buffer)], txt[1L])
			buffer <<- c(buffer, txt[-1L])
		} else buffer <<- txt
		linestart <<- trail
	}
 
	flushBuffer <- function() {
		if (!length(buffer)) return() 
		if (length(buffer)) WriteLines(buffer, con, outputEncoding)
		buffer <<- character()
		linestart <<- TRUE
	}
  
	trim <- function(x) {
		x <- psub1("^\\s*", "", x)
		psub1("\\s*$", "", x)
	}
 
	unescape <- function(x) {
		psub("(---|--)", "-", x)
	}
 
	tabExpand <- function (x) {
 	   srcref <- attr(x, "srcref")
    	if (is.null(srcref)) 
        	start <- 0L
    	else start <- srcref[5L] - 1L
		#.Call(C_doTabExpand, x, start) #!moin 
		# cannot call this outside `Tools`
		# so the following replacement is used
		fsub("\t", strrep(" ", start), x) #!moin
	}
	
	writeCode <- function(x) {
		txt <- as.character(x)
		if(inEqn) txt <- txt_eqn(txt)
		txt <- fsub('"\\{"', '"{"', txt)
		## \dots gets left in noquote.Rd
		txt <- fsub("\\dots",  "...", txt) #!moin
		put(txt)
	}
 
	# This function strips pending blank lines, then adds n new ones.
	blankLine <- function(n = 1L) {
		while (length(buffer) && grepl("^[[:blank:]]*$", buffer[length(buffer)]))
			buffer <<- buffer[-length(buffer)]
		flushBuffer()
		if (n > haveBlanks) {
			buffer <<- rep_len("", n - haveBlanks)
			flushBuffer()
			haveBlanks <<- n
		}
		dropBlank <<- TRUE
	}
 
	txt_eqn <- function(x) { #!moin this has not been tested from moin markup
		x <- psub("\\\\(Alpha|Beta|Gamma|Delta|Epsilon|Zeta|Eta|Theta|Iota|Kappa|Lambda|Mu|Nu|Xi|Omicron|Pi|Rho|Sigma|Tau|Upsilon|Phi|Chi|Psi|Omega|alpha|beta|gamma|delta|epsilon|zeta|eta|theta|iota|kappa|lambda|mu|nu|xi|omicron|pi|rho|sigma|tau|upsilon|phi|chi|psi|omega|sum|prod|sqrt)", "\\1", x)
		x <- psub("\\\\(dots|ldots)", "...", x)
		x <- fsub("\\le", "<=", x)
		x <- fsub("\\ge", ">=", x)
		x <- fsub("\\infty", "Inf", x)
		## FIXME: are these needed?
		x <- psub("\\\\(bold|strong|emph|var)\\{([^}]*)\\}", "\\2", x)
		x <- psub("\\\\(code|samp)\\{([^}]*)\\}", "'\\2'", x)
		x
	}
 
	writeDR <- function(block, tag) {
		if (length(block) > 1L) {
			put('## Not run:\n')
			writeCodeBlock(block, tag)
			blankLine(0L)
			put('## End(Not run)\n')
		} else {
			put('## Not run: ')
			writeCodeBlock(block, tag)
			blankLine(0L)
		}
	}
 
	writeQ <- function(block, tag, quote=tag)
	{
		if (quote == "\\sQuote") {
			put("'"); writeContent(block, tag); put("'")
		} else {
			put("\""); writeContent(block,tag); put("\"")
		}
	}
	
	tidy <- function(block) { #!moin
		x <- paste(as.character(block), collapse="")
		trimws(gsub("\n", "", x)) 
	}

	writeBlock <- function(block, tag, blocktag) {
		switch(tag,
			UNKNOWN =,
			VERB =,
			RCODE = writeCode(tabExpand(block)),
			TEXT = {
				if (blocktag == "\\command") put(block) #!moin
				else put(escWw(unescape(tabExpand(block)))) #!moin
				},
			USERMACRO =,
			"\\newcommand" =,
			"\\renewcommand" =,
			COMMENT = {},
			LIST = writeContent(block, tag),
			"\\describe" = {
				blankLine(0L)
				writeContent(block, tag)
				blankLine()
				},
			"\\itemize" =,
			"\\enumerate" = {
				blankLine(0L)
				enumItem0 <- enumItem
				enumItem <<- 0L
				dropBlank <<- TRUE
				writeContent(block, tag)
				blankLine()
				enumItem <<- enumItem0
				},
			"\\code" = { #!moin
				put(markup(type = ".monospace"))
				writeContent(block, tag)
				put(markup(type = ".monospace"))
				},
			"\\command" =,
			"\\env" =,
			"\\file" =,
			"\\kbd" =,
			"\\option" =,
			"\\pkg" =,
			"\\samp" = {
				if(code_quote)
					writeQ(block, tag, quote="\\sQuote")
				else writeContent(block, tag)
				},
			"\\email" = if (length(block)) { #!moin
				put(markup(tidy(block), "mailTo")) 
				},
			"\\url" = if (length(block)) { #!moin
				put(markup(tidy(block), "link"))  
				},
			"\\href" = if (length(block[[1L]])) { #!moin
				if (length(block[[2L]])) { 
					.url <- tidy(block)
					names(.url) <- writeContent(block[[2L]], tag)
					put(markup(.url, "linkNamed"))
				} else {
					put(markup(tidy(block), "link"))
				}
				},
			"\\Sexpr" = put(as.character.Rd(block, deparse=TRUE)), #throws errors
			"\\acronym" =,
			"\\cite" =,
			"\\dfn" =,
			"\\special" =,
			"\\var" = writeContent(block, tag),
 			"\\bold" =,
			"\\strong" = { #!moin
				put(markup(type = ".bold"))
				writeContent(block, tag)
				put(markup(type = ".bold"))
				},
			"\\emph" = { #!moin
				put(markup(type = ".italic"))
				writeContent(block, tag)
				put(markup(type = ".italic"))
				},
			"\\sQuote" =,
			"\\dQuote" = writeQ(block, tag),
			"\\preformatted" = { #!moin
				put(markup(type = ".verbBlockOpen"))
				writeCodeBlock(block, tag)
				put(markup(type = ".blockClose"))
				}, 
			"\\verb" = put(block),
			"\\linkS4class" =,
			"\\link" = put(block), #{ #!moin
				#put(markup(type = ".linkOpen"))
				#writeContent(block, tag)
				#put(markup(type = ".linkClose"))
				#},
			"\\cr" = put(markup(type = ".newline")), #!moin
			"\\dots" = put(markup("...", "monospace")), #!moin
			"\\ldots" = put("..."),
			"\\R" = put("R"),
			"\\enc" = { #!moin untested from moin markup
				## Test to see if we can convert the encoded version
				txt <- as.character(block[[1L]])
				test <- iconv(txt, "UTF-8", outputEncoding, mark = FALSE)
				txt <- if(!is.na(test)) txt else as.character(block[[2L]])
				put(txt)
				},
			"\\eqn" = { #!moin untested from moin markup
				block <- block[[length(block)]]
				## FIXME: treat 2 of 2 differently?
				inEqn0 <- inEqn
				inEqn <<- TRUE
				writeContent(block, tag)
				inEqn <<- inEqn0
				},
			"\\deqn" = { #!moin untested from moin markup
				blankLine()
				block <- block[[length(block)]]
				save <- startCapture()
				inEqn <<- TRUE
				writeContent(block, tag)
				eqn <- endCapture(save)
				put(paste(eqn, collapse = "\n"))
				blankLine()
				},
			"\\figure" = { #!moin untested from moin markup
				blankLine()
				save <- startCapture()
				writeContent(block[[length(block)]], tag)
				alt <- endCapture(save)
				if (length(alt)) {
					put(paste(alt, collapse = "\n"))
					blankLine()
				}
				},
			"\\tabular" = writeTabular(block),
			"\\subsection" = writeSection(block, tag),
			"\\if" =,
			"\\ifelse" =
				if (testRdConditional("text", block, Rdfile))
					writeContent(block[[2L]], tag)
				else if (tag == "\\ifelse")
					writeContent(block[[3L]], tag),
			"\\out" = for (i in seq_along(block))
						put(block[[i]]),
			stopRd(block, Rdfile, "Tag ", tag, " not recognized")
		)
	}
 
    writeTabular <- function(table) { #!moin
    		formats <- table[[1L]]
        if (length(formats) != 1L || RdTags(formats) != "TEXT") 
            stopRd(table, Rdfile, "\\tabular format must be simple text")
        ftext <- formats[[1L]]
        aligns <- strsplit(ftext, "", fixed = TRUE)[[1L]]
        if (!all(aligns %in% fcodes))
            stopRd(table, Rdfile, "Unrecognized \\tabular format: ", ftext)
            
        content <- table[[2L]]
        tags <- RdTags(content)
        cells <- cell <- 1L
        for (t in seq_along(tags)) {
        		cells[t] <- cell * (!tags[t] %in% c("\\tab", "\\cr"))
        		if (!cells[t]) cell <- t + 1L
        }
        if (tags[length(tags)] != "\\cr") cells[max(cells):length(tags)] <- 0
         
        for (cell in unique(cells[cells])) {
			save <- startCapture()
			writeContent(content[cells == cell], tags[cell])
			cells[cells == cell] <- 0
			cells[cell] <- cell
			content[cell] <- tidy(endCapture(save))        		
        }

        rows <- sum(as.integer(tags == "\\cr"))
		cols <- sum(as.integer(tags %in% c("\\tab", "\\cr"))) / rows
        if (cols != length(aligns))
            stopRd(table, Rdfile,
            	"\\tabular formats (", ftext,
            	") do not match columns found:", cols)
		content <- unlist(content[cells])
		cnt <<- content
		table <- matrix(c(aligns, content), rows + 1, cols, byrow = TRUE)
		tbl <<- table
		blankLine()
		put(markup(table, type = "table"))
    }
 
	writeCodeBlock <- function(blocks, blocktag) {
		tags <- RdTags(blocks)
		i <- 0
		while (i < length(tags)) {
			i <- i + 1
			block <- blocks[[i]]
			tag <- tags[i]
			switch(tag,
				"\\method" =,
				"\\S3method" =,
				"\\S4method" = {
					blocks <- transformMethod(i, blocks, Rdfile)
					tags <- RdTags(blocks)
					i <- i - 1
					},
				UNKNOWN =,
				VERB =,
				RCODE =,
				TEXT = writeCode(tabExpand(block)),
				"\\donttest" =,
				"\\special" =,
				"\\var" = writeCodeBlock(block, tag),
				"\\dots" =,
				"\\ldots" = put(markup("...", "monospace")),
				"\\dontrun" = writeDR(block, tag),
				USERMACRO =,
				"\\newcommand" =,
				"\\renewcommand" =,
				COMMENT =,
				"\\dontshow" =,
				"\\testonly" = {}, # do nothing
				## All the markup such as \emph
				stopRd(block, Rdfile, "Tag ", tag, " not expected in code block")
			)
		}
	}
 
	writeContent <- function(blocks, blocktag) {
		itemskip <- FALSE
		tags <- RdTags(blocks)
		for (i in seq_along(tags)) {
			tag <- tags[i]
			block <- blocks[[i]]
			switch(tag,
				"\\item" = {
					switch(blocktag,
						"\\describe" = {
							blankLine()
							save <- startCapture()
							dropBlank <<- TRUE
							writeContent(block[[1L]], tag)
							DLlab <- endCapture(save)
							put(" ", paste0(DLlab), " ") #!moin
							writeContent(block[[2L]], tag)
							blankLine(0L)
							},
						"\\value" =,
						"\\arguments" = {
							blankLine()
							save <- startCapture()
							dropBlank <<- TRUE
							writeContent(block[[1L]], tag)
							DLlab <- endCapture(save)
							itemLabel <- setNames("", DLlab) #!moin
							put(markup(itemLabel, "itemLabel")) #!moin
							writeContent(block[[2L]], tag)
							blankLine(0L)
							},
						"\\itemize" =,
						"\\enumerate" = {
							blankLine()
							if (blocktag == "\\itemize") {
								put(markup("", "itemBullet")) #!moin
							} else {
								enumItem <<- enumItem + 1L
								put(markup("", "itemNumber", enumItem)) #!moin
							}
							})
					itemskip <- TRUE
					},
					{ # default
					if (itemskip) {
						## The next item must be TEXT, and start with a space.
						itemskip <- FALSE
						if (tag == "TEXT") {
							txt <- psub("^ ", "", as.character(tabExpand(block)))
							put(txt) #!moin
						} else {
							writeBlock(block, tag, blocktag) # should not happen
						}
					} else { 
						writeBlock(block, tag, blocktag)
					}
					})
		}
	}
 
	writeSection <- function(section, tag) {
		if (tag %in% c("\\alias", "\\concept", "\\encoding", "\\keyword"))
			return()
		save <- c(sectionLevel, dropBlank)
		blankLine() #!moin
		sectionLevel <<- sectionLevel + 1L
		if (tag == "\\section" || tag == "\\subsection") {
			#!moin no markup allowed moin titles
			title <- .Rd_format_title(section[[1L]]) #!moin
			put(markup(title, "heading", sectionLevel)) #!moin
			blankLine()
			dropBlank <<- TRUE
			writeContent(section[[2L]], tag)
		} else if (tag %in% c("\\usage", "\\examples")) {#!moin
			put(markup(sectionTitles[tag], "heading", sectionLevel))
			blankLine()
			dropBlank <<- TRUE
			put(markup(type = ".codeBlockOpen"))
			writeCodeBlock(section, tag)
			put(markup(type = ".blockClose"))
		} else {
			put(markup(sectionTitles[tag], "heading", sectionLevel)) #!moin
			blankLine()
			dropBlank <<- TRUE
			writeContent(section, tag)
		}
		blankLine()
 
		sectionLevel <<- save[1L]
		dropBlank <<- save[2L]
	}
 
	if (is.character(out)) {
		if (out == "") {
			con <- stdout()
		} else {
			con <- file(out, ifelse(append, "at", "wt")) #!moin
			on.exit(close(con), add=TRUE)
		}
	} else {
		con <- out
		out <- summary(con)$description
	}
 
	if (!prepared) Rd <- prepare_Rd(Rd, defines=defines, stages=stages, fragment=fragment, ...)
	Rdfile <- attr(Rd, "Rdfile")
	sections <- RdTags(Rd)
	if (fragment) {
		if (sections[1L] %in% names(sectionOrder))
			for (i in seq_along(sections))
				writeSection(Rd[[i]], sections[i])
		else
			for (i in seq_along(sections))
				writeBlock(Rd[[i]], sections[i], "")
	} else {
		title <- .Rd_format_title(.Rd_get_title(Rd))
		name <- trim(Rd[[2L]][[1L]])
		if (nzchar(package)) {
			put(markup("", "hozline", 2)) #!moin
			put('||<tablestyle="width: 100%" style="width: 50%; border: none;">', name, " {", package, 
				'} ||<style="width: 50%; text-align: right; border: none;">R Documentation`   `||\n') #!moin
			put(markup("", "hozline", 2)) #!moin
		}
		put(markup(name, "heading", sectionLevel)) #!moin
		blankLine()
		put(title)
		blankLine()
		for (i in seq_along(sections)[-(1:2)])
			writeSection(Rd[[i]], sections[i])
	}
	blankLine(0L)
	invisible(out)
}