highr.r

stopifnot(getRversion() >= '3.0.0')

.keywords = c('FUNCTION', 'IF', 'ELSE', 'WHILE', 'FOR', 'IN', 'BREAK', 'REPEAT', 'NEXT')

.cmd.list = c(
  NUM_CONST            = 'number',
  SYMBOL_FUNCTION_CALL = 'functioncall',
  STR_CONST            = 'string',
  setNames(rep('keyword', length(.keywords)), .keywords),
  SYMBOL_FORMALS       = 'argument',
  COMMENT              = 'comment',
  SYMBOL_SUB           = 'formalargs',
  EQ_SUB               = 'eqformalargs',
  LEFT_ASSIGN          = 'assignment',
  EQ_ASSIGN            = 'assignment',
  RIGHT_ASSIGN         = 'assignment',
  SLOT                 = 'slot',
  SYMBOL               = 'symbol'
)

cmd_latex = data.frame(
  cmd1 = paste('\\hl', .cmd.list, '{', sep = ''),
  cmd2 = '}',
  stringsAsFactors = FALSE,
  row.names = names(.cmd.list)
)

cmd_html = data.frame(
  cmd1 = paste('<span class="', .cmd.list, '">', sep = ''),
  cmd2 = '</span>',
  stringsAsFactors = FALSE,
  row.names = names(.cmd.list)
)

## an important missing part: must put white spaces back!
## a minor missing part: escape special characters (see knitr:::escape_latex)
hilight = function(x, format = c('latex', 'html')) {
  format = match.arg(format)
  p = parse(text = x)
  if (length(p) == 0L) return(x)
  z = getParseData(p)
  if (NROW(z) == 0L || !any(z$terminal)) return(x)
  z = z[z$terminal, ]
  res = (if (format == 'latex') cmd_latex else cmd_html)[z$token, ]
  zcols = z[, c('line1', 'col1', 'col2', 'text')]
  # The key point is that, the numbers that are not covered by
  # col1:col2 represent the positions of spaces.
  # For example, assume we have
  #
  # col1    col2
  #    1       1
  #    2       4
  #    6       6
  #   10      12
  #
  # then it means the positions 1:1, 2:4, 6:6, 10:12 are symbols,
  # so position 5, 7, 8, 9 are spaces.
  res = cbind(zcols, res)
  res = within(res, {cmd1[is.na(cmd1)] = ''; cmd2[is.na(cmd2)] = ''})
  
  nonspace_pos = with(res, mapply(':', col1, col2))
  nonspace_pos_byline = tapply(nonspace_pos, res$line1, unlist)
  space_pos_byline = lapply(nonspace_pos_byline,
                            function(x) setdiff(1:max(x), x)
                           )
  space_pos = mapply(function(linenum, pos) {
    if (!length(pos)) return(NULL);
    data.frame(line1 = linenum, col1 = pos, col2 = pos, text = ' ',
               cmd1 = '', cmd2 = '')
  },
       as.integer(names(space_pos_byline)),
       space_pos_byline, SIMPLIFY = FALSE)
  space_pos = do.call(rbind, space_pos)
  
  res = rbind(res, space_pos)
  res = res[order(res$line1, res$col1), ]
  
  with(res, tapply(paste(cmd1, text, cmd2, sep = ''), line1, paste, collapse = ''))  
}

hi_latex = function(x) hilight(x, 'latex')
hi_html = function(x) hilight(x, 'html')

# examples
txt = c('a<-1 # something', 'c(z="hello")', 'b=function(x=2){while(FALSE) NA}',
        'for(i in 1:10) {if (i < 5) print(i) else break}', 'z@child # S4 slot')
hi_latex(txt)
hi_html(txt)