RspParser.R at c4b1d02 ⋅ HenrikBengtsson/R.rsp

###########################################################################/**
# @RdocClass RspParser
#
# @title "The RspParser class"
#
# \description{
#  @classhierarchy
#
#  An RspParser is parser for the RSP language.
# }
#
# @synopsis
#
# \arguments{
#   \item{...}{Not used.}
# }
#
# \section{Fields and Methods}{
#  @allmethods
# }
#
# @author
#
# @keyword internal
#*/###########################################################################
setConstructorS3("RspParser", function(...) {
  extend(NA, "RspParser")
})


#########################################################################/**
# @RdocMethod parseRaw
#
# @title "Parses the string into blocks of text and RSP"
#
# \description{
#  @get "title".
# }
#
# @synopsis
#
# \arguments{
#   \item{object}{An @see RspString to be parsed.}
#   \item{what}{A @character string specifying what type of RSP construct
#     to parse for.}
#   \item{commentLength}{Specify the number of hyphens in RSP comments
#     to parse for.}
#   \item{...}{Not used.}
#   \item{verbose}{See @see "R.utils::Verbose".}
# }
#
# \value{
#  Returns a named @list with elements named "text" and "rsp".
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/#########################################################################
setMethodS3("parseRaw", "RspParser", function(parser, object, what=c("comment", "directive", "expression"), commentLength=-1L, ..., verbose=FALSE) {
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Local functions
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Escape '<%%' and '%%>'
  escapeP <- function(s) {
    s <- gsub(.rspBracketOpenEscape,  "---<<<---%%%---%%%---", s, fixed=TRUE)
    s <- gsub(.rspBracketCloseEscape, "---%%%---%%%--->>>---", s, fixed=TRUE)
    s
  } # escapeP()

  # Unescape '<%%' and '%%>'
  unescapeP <- function(s) {
    s <- gsub("---<<<---%%%---%%%---", .rspBracketOpenEscape,  s, fixed=TRUE)
    s <- gsub("---%%%---%%%--->>>---", .rspBracketCloseEscape, s, fixed=TRUE)
    s
  } # unescapeP()


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'what':
  what <- match.arg(what)

  # Argument 'commentLength':
  commentLength <- as.integer(commentLength)
  stop_if_not(is.finite(commentLength))
  stop_if_not(commentLength == -1L || commentLength >= 2L)

  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }


  verbose && enter(verbose, "Raw parsing of RSP string")

  # Work with one large character string
  bfr <- paste(object, collapse="\n", sep="")
  verbose && cat(verbose, "Length of RSP string: ", nchar(bfr))


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Setup
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Pattern for suffix specification
  patternS <- paste("([+]|[-]+(\\[[^]]*\\])?)", .rspBracketClose, sep="")

  # Setup the regular expressions for start and stop RSP constructs
  hasPatternLTail <- FALSE
  if (what == "comment") {
    if (commentLength == -1L) {
      # <%-%>, <%--%>, <%---%>, <%----%>, ...
      # <%-[suffix]%>, <%--[suffix]%>, <%---[suffix]%>, ...
      patternL <- sprintf("(%s([-]+(\\[[^]]*\\])?%s))", .rspBracketOpen, .rspBracketClose)
      patternR <- NULL
    } else {
      # <%-- --%>, <%--\n--%>, <%-- text --%>, ...
      # <%--- ---%>, <%--- text ---%>, ...
      patternL <- sprintf("(%s-{%d})([^-])", .rspBracketOpen, commentLength)
      hasPatternLTail <- TRUE
      patternR <- sprintf("(|[^-])(-{%d}(\\[[^]]*\\])?)%s", commentLength, .rspBracketClose)
    }
    bodyClass <- RspComment
  } else if (what == "directive") {
    patternL <- sprintf("(%s@)()", .rspBracketOpen)
    patternR <- sprintf("()(|[+]|-(\\[[^]]*\\])?)%s", .rspBracketClose)
    bodyClass <- RspUnparsedDirective
  } else if (what == "expression") {
    patternL <- sprintf("(%s)()", .rspBracketOpen)
    patternR <- sprintf("()(|[+]|-(\\[[^]]*\\])?)%s", .rspBracketClose)
    bodyClass <- RspUnparsedExpression
  }

  if (verbose) {
    cat(verbose, "Regular expression patterns to use:")
    str(verbose, list(patternL=patternL, patternR=patternR, patternS=patternS))
    cat(verbose, "Class to coerce to: ", class(bodyClass())[1L])
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Parse
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  verbose && cat(verbose, "What to parse for: ", what)

  # Hide '<%%' and '%%>' from parser
  n <- nchar(bfr)
  bfr <- escapeP(bfr)
  escapedP <- (nchar(bfr) != n)

  # Constants
  START <- 0L
  STOP <- 1L

  parts <- list()
  state <- START
  while(TRUE) {
    if (state == START) {
      # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      # (a) Scan for RSP start tag, i.e. <%, <%@, or <%--
      # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      # The start tag may exists *anywhere* in static code
      posL <- regexpr(patternL, bfr)
      if (posL == -1L)
        break
      nL <- attr(posL, "match.length")
      stop_if_not(is.integer(nL))

      # (i) Extract RSP construct, '<%...%>[extra]'
      tag <- substring(bfr, first=posL, last=posL+nL-1L)

      # Was it an escaped RSP start tag, i.e. '<%%'?
      if (what == "expression") {
        tagX <- substring(bfr, first=posL, last=posL+nL)
        if (tagX == .rspBracketOpenEscape)
          break
      }

      # If parsed too far, i.e. into the tailing text
      # (so that '[extra]' is non-empty), then adjust
      bfrExtra <- gsub(patternL, "\\4", tag)
      nExtra <- nchar(bfrExtra)
      nL <- nL - nExtra

      # (ii) Extract the preceeding text
      text <- substring(bfr, first=1L, last=posL-1L)

      # Record as RSP text, unless empty.
      if (nchar(text) > 0L) {
        # Update flag whether the RSP construct being parsed is
        # on the same output line as RSP text or not.  It is not
        # if the text ends with a line break.
        if (escapedP) text <- unescapeP(text)
        part <- list(text=RspText(text))
      } else {
        part <- NULL
      }


      # (iii) Special case: Locate RSP end tag immediately.
      if (is.null(patternR)) {
        body <- ""

        # Extract the '<%...%>' part
        if (nExtra > 0L) {
          tail <- substring(tag, first=1L, last=nL-1L)
        } else {
          tail <- tag
        }

        # Extract the '...%>' part
        # Currently only used for "empty" comments, e.g. <%---%>
        tail <- gsub(patternL, "\\2", tail)

        # Get optional suffix specifications, i.e. '+%>' or '-[{specs}]%>'
        if (regexpr(patternS, tail) != -1L) {
          suffixSpecs <- gsub(patternS, "\\1", tail)
          suffixSpecs <- gsub("--*", "-", suffixSpecs)
          verbose && printf(verbose, "Identified suffix specification: '%s'\n", suffixSpecs)
          attr(body, "suffixSpecs") <- suffixSpecs
        } else {
          verbose && cat(verbose, "Identified suffix specification: <none>")
        }

        if (what == "comment") {
          attr(body, "commentLength") <- commentLength
        }

        if (!is.null(bodyClass)) {
          body <- bodyClass(body)
        }

        part2 <- list(rsp=body)
        if (what != "expression") {
          names(part2)[1L] <- what
        }
        part <- c(part, part2)
        state <- START
      } else {
        # Push-back something to buffer?
        if (hasPatternLTail && nchar(gsub(patternL, "\\2", tag)) > 0L) {
          nL <- nL - 1L
        }
        state <- STOP
      } # if (is.null(patternR))

      # (iv) Finally, consume the read buffer
      bfr <- substring(bfr, first=posL+nL)
    } else if (state == STOP) {
      # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      # (b) Scan for RSP end tag, i.e. %>, %>, or --%>
      # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
      # Not found?
      posR <- indexOfNonQuoted(bfr, patternR)
      if (posR == -1L)
        break

      # (i) Extract RSP body with RSP end tag, '[extra][pattern]%>'
      nR <- attr(posR, "match.length")
      tail <- substring(bfr, first=posR, last=posR+nR-1L)

      # Was it an escaped RSP end tag, i.e. '%%>'?
      if (what == "expression") {
        nT <- nchar(tail)
        if (nT >= nchar(.rspBracketCloseEscape) && substring(tail, first=nT-nchar(.rspBracketCloseEscape)+1L, last=nT) == .rspBracketCloseEscape)
          break
      }

      # If parsed too far, i.e. into the preceeding body
      # (so that '[extra]' is non-empty), then adjust
      bodyExtra <- gsub(patternR, "\\1", tail)
      nExtra <- nchar(bodyExtra)
      posR <- posR + nExtra
      nR <- nR - nExtra

      # Extract body of RSP construct (without RSP end tag)
      body <- substring(bfr, first=1L, last=posR-1L)
      if (escapedP) body <- unescapeP(body)

      # Get optional suffix specifications, i.e. '+%>' or '-[{specs}]%>'
      if (regexpr(patternS, tail) == 1L) {
        suffixSpecs <- gsub(patternS, "\\1", tail)
        verbose && printf(verbose, "Identified suffix specification: '%s'\n", suffixSpecs)
        attr(body, "suffixSpecs") <- suffixSpecs
      } else {
        verbose && cat(verbose, "Identified suffix specification: <none>")
      }

      if (what == "comment") {
        attr(body, "commentLength") <- commentLength
      }

      if (!is.null(bodyClass)) {
        body <- bodyClass(body)
      }

      part <- list(rsp=body)
      if (what != "expression") {
        names(part)[1L] <- what
      }

      # (iv) Finally, consume the read buffer
      bfr <- substring(bfr, first=posR+nR)

      state <- START
    } # if (state == ...)

    parts <- c(parts, part)

    if (verbose) {
      cat(verbose, "RSP construct(s) parsed:")
      print(verbose, part)
      cat(verbose, "Number of RSP constructs parsed this far: ", length(parts))
    }
  } # while(TRUE)


  # Add the rest of the buffer as text, unless empty.
  if (nchar(bfr) > 0L) {
    text <- bfr
    if (escapedP) text <- unescapeP(text)
    text <- RspText(text)
    parts <- c(parts, list(text=text))
  }
  verbose && cat(verbose, "Total number of RSP constructs parsed: ", length(parts))

  # Setup results
  doc <- RspDocument(parts, attrs=getAttributes(object))
  attr(doc, "what") <- what

  verbose && exit(verbose)

  doc
}, protected=TRUE) # parseRaw()



#########################################################################/**
# @RdocMethod parseDocument
#
# @title "Parse an RSP string into and RSP document"
#
# \description{
#  @get "title" with RSP comments dropped.
# }
#
# @synopsis
#
# \arguments{
#   \item{object}{An @see RspString to be parsed.}
#   \item{envir}{The @environment where the RSP document is preprocessed.}
#   \item{...}{Passed to the processor in each step.}
#   \item{until}{Specifies how far the parse should proceed, which is useful
#      for troubleshooting and debugging.}
#   \item{as}{Specifies in what format the parsed RSP document
#      should be returned.}
#   \item{verbose}{See @see "R.utils::Verbose".}
# }
#
# \value{
#  Returns a @see "RspDocument" (when \code{as = "RspDocument"}; default)
#  or @see "RspString" (when \code{as = "RspString"}).
# }
#
# @author
#
# \seealso{
#   @seeclass
# }
#*/#########################################################################
setMethodS3("parseDocument", "RspParser", function(parser, object, envir=parent.frame(), ..., until=c("*", "end", "expressions", "directives", "comments"), as=c("RspDocument", "RspString"), verbose=FALSE) {
  ## WORKAROUND: For unknown reasons, the R.oo package needs to be
  ## attached in order for 'R CMD build' to build the R.rsp package.
  ## If not, the generated RSP-to-R script becomes corrupt and contains
  ## invalid symbols, at least for '<%= ... %>' RSP constructs.
  ## Below use("R.oo", quietly=TRUE) is used to attach 'R.oo',
  ## but we do it as late as possible, in order narrow down the cause.
  ## It appears to be related to garbage collection and finalizers of
  ## Object, which will try to attach 'R.oo' temporarily before running
  ## finalize() on the object.  If so, it's a bug in R.oo.
  ## /HB 2013-09-17
  use("R.oo", quietly=TRUE)


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Local functions
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  metadata <- getMetadata(object, local=TRUE)

  returnAs <- function(doc, as=c("RspDocument", "RspString")) {
    as <- match.arg(as)

    # Make sure to always output something
    if (length(doc) == 0L) {
      expr <- RspText("")
      doc[[1]] <- expr
    }

    if (length(metadata) > 0L) doc <- setMetadata(doc, metadata)

    if (as == "RspDocument") {
      return(doc)
    } else if (as == "RspString") {
      object <- asRspString(doc)
      return(object)
    }
  } # returnAs()


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Validate arguments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # Argument 'until':
  until <- match.arg(until)

  # Argument 'as':
  as <- match.arg(as)

  # Argument 'verbose':
  verbose <- Arguments$getVerbose(verbose)
  if (verbose) {
    pushState(verbose)
    on.exit(popState(verbose))
  }


  verbose && enter(verbose, "Parsing RSP string")
  verbose && cat(verbose, "Compile until: ", sQuote(until))
  verbose && cat(verbose, "Return as: ", sQuote(as))

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # (1a) Parse and drop "empty" RSP comments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  verbose && enter(verbose, "Dropping 'empty' RSP comments")
  verbose && cat(verbose, "Length of RSP string before: ", nchar(object))

  # This is only for comments such as <%-%>, <%--%>, <%---%>, ...
  doc <- parseRaw(parser, object, what="comment", commentLength=-1L, verbose=less(verbose, 50))

  # Nothing todo?
  if (length(doc) == 0L) {
    return(returnAs(doc, as=as))
  }

  idxs <- which(sapply(doc, FUN=inherits, "RspComment"))
  count <- length(idxs)

  # Empty comments found?
  if (count > 0L) {
    verbose && print(verbose, doc)

    # Preprocess, drop RspComments and adjust for empty lines
    doc <- preprocess(doc, verbose=less(verbose, 10))
    verbose && print(verbose, doc)

    verbose && cat(verbose, "Number of 'empty' RSP comments dropped: ", count)

    # Coerce to RspString
    object <- asRspString(doc)
    verbose && cat(verbose, "Length of RSP string after: ", nchar(object))
  } else {
    verbose && cat(verbose, "No 'empty' RSP comments found.")
  }

  verbose && exit(verbose)

  if (until == "comments") {
    verbose && exit(verbose)
    return(returnAs(doc, as=as))
  }


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # (1b) Parse and drop RSP comments
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  verbose && enter(verbose, "Dropping 'paired' RSP comments")
  verbose && cat(verbose, "Length of RSP string before: ", nchar(object))

  # Nothing todo?
  if (length(doc) == 0L) {
    return(returnAs(doc, as=as))
  }

  count <- 0L
  posL <- -1L
  while ((pos <- regexpr(sprintf("%s[-]+", .rspBracketOpen), object)) != -1L) {
    # Nothing changed? (e.g. if there is an unclosed comment)
    if (identical(pos, posL)) {
      break
    }

    # Identify the comment length of the first comment found
    n <- attr(pos, "match.length") - 2L
    if (n < 2L) {
       tag <- substring(object, first=pos)
       start <- substring(tag, first=1L, n+2L)
       throw(RspParseException(sprintf("Detected an RSP comment start tag (%s) but no matching end tag: %s", sQuote(start), sQuote(tag))))
    }

    verbose && printf(verbose, "Number of hypens of first comment found: %d\n", n)

    # Find all comments of this same length
    doc <- parseRaw(parser, object, what="comment", commentLength=n, verbose=less(verbose, 50))

    idxs <- which(sapply(doc, FUN=inherits, "RspComment"))
    count <- count + length(idxs)

    # Trim non-text RSP constructs
    doc <- trimNonText(doc, verbose=less(verbose, 10))

    # Preprocess (=drop RspComments and adjust for empty lines)
    doc <- preprocess(doc, verbose=less(verbose, 10))

    # Coerce to RspString
    object <- asRspString(doc)

    posL <- pos
  }

  if (count > 0L) {
    verbose && cat(verbose, "Number of 'paired' RSP comments dropped: ", count)
    verbose && cat(verbose, "Length of RSP string after: ", nchar(object))
  } else {
    verbose && cat(verbose, "No 'paired' RSP comments found.")
  }

  verbose && exit(verbose)


  if (until == "directives") {
    verbose && exit(verbose)
    docP <- parseRaw(parser, object, what="directive", verbose=less(verbose, 50))
    return(returnAs(docP, as=as))
  }

  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # (2a) Parse RSP preprocessing directive
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  verbose && enter(verbose, "Processing RSP preprocessing directives")
  verbose && cat(verbose, "Length of RSP string before: ", nchar(object))

  doc <- parseRaw(parser, object, what="directive", verbose=less(verbose, 50))

  # Nothing todo?
  if (length(doc) == 0L) {
    return(returnAs(doc, as=as))
  }

  idxs <- which(sapply(doc, FUN=inherits, "RspUnparsedDirective"))
  if (length(idxs) > 0L) {
    verbose && cat(verbose, "Number of (unparsed) RSP preprocessing directives found: ", length(idxs))

    # Parse each of them
    for (idx in idxs) {
      doc[[idx]] <- parseDirective(doc[[idx]])
    }

    # Trim non-text RSP constructs
    doc <- trimNonText(doc, verbose=less(verbose, 10))

    # Process all RSP preprocessing directives, i.e. <%@...%>
    doc <- preprocess(doc, envir=envir, ..., verbose=less(verbose, 10))

    # Coerce to RspString
    object <- asRspString(doc)
    verbose && cat(verbose, "Length of RSP string after: ", nchar(object))
  } else {
    verbose && cat(verbose, "No RSP preprocessing directives found.")
  }
  idxs <- NULL; # Not needed anymore

  verbose && exit(verbose)

  if (until == "expressions") {
    verbose && exit(verbose)
    return(returnAs(doc, as=as))
  }


  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  # (3) Parse RSP expressions
  # - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  verbose && enter(verbose, "Processing RSP expressions")
  verbose && cat(verbose, "Length of RSP string before: ", nchar(object))

  doc <- parseRaw(parser, object, what="expression", verbose=less(verbose, 50))

  # Nothing todo?
  if (length(doc) == 0L) {
    return(returnAs(doc, as=as))
  }

  idxs <- which(sapply(doc, FUN=inherits, "RspUnparsedExpression"))

  if (length(idxs) > 0L) {
    verbose && cat(verbose, "Number of (unparsed) RSP expressions found: ", length(idxs))

    # Parse them
    for (idx in idxs) {
      doc[[idx]] <- parseExpression(doc[[idx]])
    }

    # Trim non-text RSP constructs
    doc <- trimNonText(doc, verbose=less(verbose, 10))

    # Preprocess (=trim all empty lines)
    doc <- preprocess(doc, envir=envir, ..., verbose=less(verbose, 10))

    if (verbose && isVisible(verbose)) {
      object <- asRspString(doc)
      verbose && cat(verbose, "Length of RSP string after: ", nchar(object))
    }
  } else {
    verbose && cat(verbose, "No RSP expressions found.")
  }

  verbose && exit(verbose)

  if (until == "end") {
    verbose && exit(verbose)
    return(returnAs(doc, as=as))
  }

  verbose && exit(verbose)

  returnAs(doc, as=as)
}, protected=TRUE)

Read our documentation on viewing source code .

Navigation	Overlay
`t` Navigate files	`h` Toggle hits
`y` Change url to tip of branch	`m` Toggle misses
`b / v` Jump to prev/next hit line	`p` Toggle partial
`z / x` Jump to prev/next missed or partial line	`1..9` Toggle flags
`shift + o` Open current page in GitHub	`a` Toggle all on
`/ or ?` Show keyboard shortcuts dialog	`c` Toggle context lines or commits

1		###########################################################################/**
2		# @RdocClass RspParser
3		#
4		# @title "The RspParser class"
5		#
6		# \description{
7		# @classhierarchy
8		#
9		# An RspParser is parser for the RSP language.
10		# }
11		#
12		# @synopsis
13		#
14		# \arguments{
15		# \item{...}{Not used.}
16		# }
17		#
18		# \section{Fields and Methods}{
19		# @allmethods
20		# }
21		#
22		# @author
23		#
24		# @keyword internal
25		#*/###########################################################################
26		setConstructorS3("RspParser", function(...) {
27	1	extend(NA, "RspParser")
28		})
29
30
31		#########################################################################/**
32		# @RdocMethod parseRaw
33		#
34		# @title "Parses the string into blocks of text and RSP"
35		#
36		# \description{
37		# @get "title".
38		# }
39		#
40		# @synopsis
41		#
42		# \arguments{
43		# \item{object}{An @see RspString to be parsed.}
44		# \item{what}{A @character string specifying what type of RSP construct
45		# to parse for.}
46		# \item{commentLength}{Specify the number of hyphens in RSP comments
47		# to parse for.}
48		# \item{...}{Not used.}
49		# \item{verbose}{See @see "R.utils::Verbose".}
50		# }
51		#
52		# \value{
53		# Returns a named @list with elements named "text" and "rsp".
54		# }
55		#
56		# @author
57		#
58		# \seealso{
59		# @seeclass
60		# }
61		#*/#########################################################################
62		setMethodS3("parseRaw", "RspParser", function(parser, object, what=c("comment", "directive", "expression"), commentLength=-1L, ..., verbose=FALSE) {
63		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
64		# Local functions
65		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
66		# Escape '<%%' and '%%>'
67	1	escapeP <- function(s) {
68	1	s <- gsub(.rspBracketOpenEscape, "---<<<---%%%---%%%---", s, fixed=TRUE)
69	1	s <- gsub(.rspBracketCloseEscape, "---%%%---%%%--->>>---", s, fixed=TRUE)
70	1	s
71	1	} # escapeP()
72
73		# Unescape '<%%' and '%%>'
74	1	unescapeP <- function(s) {
75	1	s <- gsub("---<<<---%%%---%%%---", .rspBracketOpenEscape, s, fixed=TRUE)
76	1	s <- gsub("---%%%---%%%--->>>---", .rspBracketCloseEscape, s, fixed=TRUE)
77	1	s
78	1	} # unescapeP()
79
80
81		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
82		# Validate arguments
83		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
84		# Argument 'what':
85	1	what <- match.arg(what)
86
87		# Argument 'commentLength':
88	1	commentLength <- as.integer(commentLength)
89	1	stop_if_not(is.finite(commentLength))
90	1	stop_if_not(commentLength == -1L \|\| commentLength >= 2L)
91
92		# Argument 'verbose':
93	1	verbose <- Arguments$getVerbose(verbose)
94	1	if (verbose) {
95	1	pushState(verbose)
96	1	on.exit(popState(verbose))
97		}
98
99
100	1	verbose && enter(verbose, "Raw parsing of RSP string")
101
102		# Work with one large character string
103	1	bfr <- paste(object, collapse="\n", sep="")
104	1	verbose && cat(verbose, "Length of RSP string: ", nchar(bfr))
105
106
107		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
108		# Setup
109		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
110		# Pattern for suffix specification
111	1	patternS <- paste("([+]\|[-]+(\\[[^]]*\\])?)", .rspBracketClose, sep="")
112
113		# Setup the regular expressions for start and stop RSP constructs
114	1	hasPatternLTail <- FALSE
115	1	if (what == "comment") {
116	1	if (commentLength == -1L) {
117		# <%-%>, <%--%>, <%---%>, <%----%>, ...
118		# <%-[suffix]%>, <%--[suffix]%>, <%---[suffix]%>, ...
119	1	patternL <- sprintf("(%s([-]+(\\[[^]]*\\])?%s))", .rspBracketOpen, .rspBracketClose)
120	1	patternR <- NULL
121		} else {
122		# <%-- --%>, <%--\n--%>, <%-- text --%>, ...
123		# <%--- ---%>, <%--- text ---%>, ...
124	1	patternL <- sprintf("(%s-{%d})([^-])", .rspBracketOpen, commentLength)
125	1	hasPatternLTail <- TRUE
126	1	patternR <- sprintf("(\|[^-])(-{%d}(\\[[^]]*\\])?)%s", commentLength, .rspBracketClose)
127		}
128	1	bodyClass <- RspComment
129	1	} else if (what == "directive") {
130	1	patternL <- sprintf("(%s@)()", .rspBracketOpen)
131	1	patternR <- sprintf("()(\|[+]\|-(\\[[^]]*\\])?)%s", .rspBracketClose)
132	1	bodyClass <- RspUnparsedDirective
133	1	} else if (what == "expression") {
134	1	patternL <- sprintf("(%s)()", .rspBracketOpen)
135	1	patternR <- sprintf("()(\|[+]\|-(\\[[^]]*\\])?)%s", .rspBracketClose)
136	1	bodyClass <- RspUnparsedExpression
137		}
138
139	1	if (verbose) {
140	1	cat(verbose, "Regular expression patterns to use:")
141	1	str(verbose, list(patternL=patternL, patternR=patternR, patternS=patternS))
142	1	cat(verbose, "Class to coerce to: ", class(bodyClass())[1L])
143		}
144
145		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
146		# Parse
147		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
148	1	verbose && cat(verbose, "What to parse for: ", what)
149
150		# Hide '<%%' and '%%>' from parser
151	1	n <- nchar(bfr)
152	1	bfr <- escapeP(bfr)
153	1	escapedP <- (nchar(bfr) != n)
154
155		# Constants
156	1	START <- 0L
157	1	STOP <- 1L
158
159	1	parts <- list()
160	1	state <- START
161	1	while(TRUE) {
162	1	if (state == START) {
163		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
164		# (a) Scan for RSP start tag, i.e. <%, <%@, or <%--
165		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
166		# The start tag may exists anywhere in static code
167	1	posL <- regexpr(patternL, bfr)
168	1	if (posL == -1L)
169	1	break
170	1	nL <- attr(posL, "match.length")
171	1	stop_if_not(is.integer(nL))
172
173		# (i) Extract RSP construct, '<%...%>[extra]'
174	1	tag <- substring(bfr, first=posL, last=posL+nL-1L)
175
176		# Was it an escaped RSP start tag, i.e. '<%%'?
177	1	if (what == "expression") {
178	1	tagX <- substring(bfr, first=posL, last=posL+nL)
179	1	if (tagX == .rspBracketOpenEscape)
180	0	break
181		}
182
183		# If parsed too far, i.e. into the tailing text
184		# (so that '[extra]' is non-empty), then adjust
185	1	bfrExtra <- gsub(patternL, "\\4", tag)
186	1	nExtra <- nchar(bfrExtra)
187	1	nL <- nL - nExtra
188
189		# (ii) Extract the preceeding text
190	1	text <- substring(bfr, first=1L, last=posL-1L)
191
192		# Record as RSP text, unless empty.
193	1	if (nchar(text) > 0L) {
194		# Update flag whether the RSP construct being parsed is
195		# on the same output line as RSP text or not. It is not
196		# if the text ends with a line break.
197	1	if (escapedP) text <- unescapeP(text)
198	1	part <- list(text=RspText(text))
199		} else {
200	1	part <- NULL
201		}
202
203
204		# (iii) Special case: Locate RSP end tag immediately.
205	1	if (is.null(patternR)) {
206	1	body <- ""
207
208		# Extract the '<%...%>' part
209	1	if (nExtra > 0L) {
210	0	tail <- substring(tag, first=1L, last=nL-1L)
211		} else {
212	1	tail <- tag
213		}
214
215		# Extract the '...%>' part
216		# Currently only used for "empty" comments, e.g. <%---%>
217	1	tail <- gsub(patternL, "\\2", tail)
218
219		# Get optional suffix specifications, i.e. '+%>' or '-[{specs}]%>'
220	1	if (regexpr(patternS, tail) != -1L) {
221	1	suffixSpecs <- gsub(patternS, "\\1", tail)
222	1	suffixSpecs <- gsub("--*", "-", suffixSpecs)
223	1	verbose && printf(verbose, "Identified suffix specification: '%s'\n", suffixSpecs)
224	1	attr(body, "suffixSpecs") <- suffixSpecs
225		} else {
226	0	verbose && cat(verbose, "Identified suffix specification: <none>")
227		}
228
229	1	if (what == "comment") {
230	1	attr(body, "commentLength") <- commentLength
231		}
232
233	1	if (!is.null(bodyClass)) {
234	1	body <- bodyClass(body)
235		}
236
237	1	part2 <- list(rsp=body)
238	1	if (what != "expression") {
239	1	names(part2)[1L] <- what
240		}
241	1	part <- c(part, part2)
242	1	state <- START
243		} else {
244		# Push-back something to buffer?
245	1	if (hasPatternLTail && nchar(gsub(patternL, "\\2", tag)) > 0L) {
246	1	nL <- nL - 1L
247		}
248	1	state <- STOP
249	1	} # if (is.null(patternR))
250
251		# (iv) Finally, consume the read buffer
252	1	bfr <- substring(bfr, first=posL+nL)
253	1	} else if (state == STOP) {
254		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
255		# (b) Scan for RSP end tag, i.e. %>, %>, or --%>
256		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
257		# Not found?
258	1	posR <- indexOfNonQuoted(bfr, patternR)
259	1	if (posR == -1L)
260	0	break
261
262		# (i) Extract RSP body with RSP end tag, '[extra][pattern]%>'
263	1	nR <- attr(posR, "match.length")
264	1	tail <- substring(bfr, first=posR, last=posR+nR-1L)
265
266		# Was it an escaped RSP end tag, i.e. '%%>'?
267	1	if (what == "expression") {
268	1	nT <- nchar(tail)
269	1	if (nT >= nchar(.rspBracketCloseEscape) && substring(tail, first=nT-nchar(.rspBracketCloseEscape)+1L, last=nT) == .rspBracketCloseEscape)
270	0	break
271		}
272
273		# If parsed too far, i.e. into the preceeding body
274		# (so that '[extra]' is non-empty), then adjust
275	1	bodyExtra <- gsub(patternR, "\\1", tail)
276	1	nExtra <- nchar(bodyExtra)
277	1	posR <- posR + nExtra
278	1	nR <- nR - nExtra
279
280		# Extract body of RSP construct (without RSP end tag)
281	1	body <- substring(bfr, first=1L, last=posR-1L)
282	1	if (escapedP) body <- unescapeP(body)
283
284		# Get optional suffix specifications, i.e. '+%>' or '-[{specs}]%>'
285	1	if (regexpr(patternS, tail) == 1L) {
286	1	suffixSpecs <- gsub(patternS, "\\1", tail)
287	1	verbose && printf(verbose, "Identified suffix specification: '%s'\n", suffixSpecs)
288	1	attr(body, "suffixSpecs") <- suffixSpecs
289		} else {
290	1	verbose && cat(verbose, "Identified suffix specification: <none>")
291		}
292
293	1	if (what == "comment") {
294	1	attr(body, "commentLength") <- commentLength
295		}
296
297	1	if (!is.null(bodyClass)) {
298	1	body <- bodyClass(body)
299		}
300
301	1	part <- list(rsp=body)
302	1	if (what != "expression") {
303	1	names(part)[1L] <- what
304		}
305
306		# (iv) Finally, consume the read buffer
307	1	bfr <- substring(bfr, first=posR+nR)
308
309	1	state <- START
310	1	} # if (state == ...)
311
312	1	parts <- c(parts, part)
313
314	1	if (verbose) {
315	1	cat(verbose, "RSP construct(s) parsed:")
316	1	print(verbose, part)
317	1	cat(verbose, "Number of RSP constructs parsed this far: ", length(parts))
318		}
319	1	} # while(TRUE)
320
321
322		# Add the rest of the buffer as text, unless empty.
323	1	if (nchar(bfr) > 0L) {
324	1	text <- bfr
325	1	if (escapedP) text <- unescapeP(text)
326	1	text <- RspText(text)
327	1	parts <- c(parts, list(text=text))
328		}
329	1	verbose && cat(verbose, "Total number of RSP constructs parsed: ", length(parts))
330
331		# Setup results
332	1	doc <- RspDocument(parts, attrs=getAttributes(object))
333	1	attr(doc, "what") <- what
334
335	1	verbose && exit(verbose)
336
337	1	doc
338		}, protected=TRUE) # parseRaw()
339
340
341
342		#########################################################################/**
343		# @RdocMethod parseDocument
344		#
345		# @title "Parse an RSP string into and RSP document"
346		#
347		# \description{
348		# @get "title" with RSP comments dropped.
349		# }
350		#
351		# @synopsis
352		#
353		# \arguments{
354		# \item{object}{An @see RspString to be parsed.}
355		# \item{envir}{The @environment where the RSP document is preprocessed.}
356		# \item{...}{Passed to the processor in each step.}
357		# \item{until}{Specifies how far the parse should proceed, which is useful
358		# for troubleshooting and debugging.}
359		# \item{as}{Specifies in what format the parsed RSP document
360		# should be returned.}
361		# \item{verbose}{See @see "R.utils::Verbose".}
362		# }
363		#
364		# \value{
365		# Returns a @see "RspDocument" (when \code{as = "RspDocument"}; default)
366		# or @see "RspString" (when \code{as = "RspString"}).
367		# }
368		#
369		# @author
370		#
371		# \seealso{
372		# @seeclass
373		# }
374		#*/#########################################################################
375		setMethodS3("parseDocument", "RspParser", function(parser, object, envir=parent.frame(), ..., until=c("*", "end", "expressions", "directives", "comments"), as=c("RspDocument", "RspString"), verbose=FALSE) {
376		## WORKAROUND: For unknown reasons, the R.oo package needs to be
377		## attached in order for 'R CMD build' to build the R.rsp package.
378		## If not, the generated RSP-to-R script becomes corrupt and contains
379		## invalid symbols, at least for '<%= ... %>' RSP constructs.
380		## Below use("R.oo", quietly=TRUE) is used to attach 'R.oo',
381		## but we do it as late as possible, in order narrow down the cause.
382		## It appears to be related to garbage collection and finalizers of
383		## Object, which will try to attach 'R.oo' temporarily before running
384		## finalize() on the object. If so, it's a bug in R.oo.
385		## /HB 2013-09-17
386	1	use("R.oo", quietly=TRUE)
387
388
389		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
390		# Local functions
391		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
392	1	metadata <- getMetadata(object, local=TRUE)
393
394	1	returnAs <- function(doc, as=c("RspDocument", "RspString")) {
395	1	as <- match.arg(as)
396
397		# Make sure to always output something
398	1	if (length(doc) == 0L) {
399	1	expr <- RspText("")
400	1	doc[[1]] <- expr
401		}
402
403	1	if (length(metadata) > 0L) doc <- setMetadata(doc, metadata)
404
405	1	if (as == "RspDocument") {
406	1	return(doc)
407	1	} else if (as == "RspString") {
408	1	object <- asRspString(doc)
409	1	return(object)
410		}
411	1	} # returnAs()
412
413
414		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
415		# Validate arguments
416		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
417		# Argument 'until':
418	1	until <- match.arg(until)
419
420		# Argument 'as':
421	1	as <- match.arg(as)
422
423		# Argument 'verbose':
424	1	verbose <- Arguments$getVerbose(verbose)
425	1	if (verbose) {
426	1	pushState(verbose)
427	1	on.exit(popState(verbose))
428		}
429
430
431	1	verbose && enter(verbose, "Parsing RSP string")
432	1	verbose && cat(verbose, "Compile until: ", sQuote(until))
433	1	verbose && cat(verbose, "Return as: ", sQuote(as))
434
435		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
436		# (1a) Parse and drop "empty" RSP comments
437		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
438	1	verbose && enter(verbose, "Dropping 'empty' RSP comments")
439	1	verbose && cat(verbose, "Length of RSP string before: ", nchar(object))
440
441		# This is only for comments such as <%-%>, <%--%>, <%---%>, ...
442	1	doc <- parseRaw(parser, object, what="comment", commentLength=-1L, verbose=less(verbose, 50))
443
444		# Nothing todo?
445	1	if (length(doc) == 0L) {
446	0	return(returnAs(doc, as=as))
447		}
448
449	1	idxs <- which(sapply(doc, FUN=inherits, "RspComment"))
450	1	count <- length(idxs)
451
452		# Empty comments found?
453	1	if (count > 0L) {
454	1	verbose && print(verbose, doc)
455
456		# Preprocess, drop RspComments and adjust for empty lines
457	1	doc <- preprocess(doc, verbose=less(verbose, 10))
458	1	verbose && print(verbose, doc)
459
460	1	verbose && cat(verbose, "Number of 'empty' RSP comments dropped: ", count)
461
462		# Coerce to RspString
463	1	object <- asRspString(doc)
464	1	verbose && cat(verbose, "Length of RSP string after: ", nchar(object))
465		} else {
466	1	verbose && cat(verbose, "No 'empty' RSP comments found.")
467		}
468
469	1	verbose && exit(verbose)
470
471	1	if (until == "comments") {
472	1	verbose && exit(verbose)
473	1	return(returnAs(doc, as=as))
474		}
475
476
477		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
478		# (1b) Parse and drop RSP comments
479		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
480	1	verbose && enter(verbose, "Dropping 'paired' RSP comments")
481	1	verbose && cat(verbose, "Length of RSP string before: ", nchar(object))
482
483		# Nothing todo?
484	1	if (length(doc) == 0L) {
485	0	return(returnAs(doc, as=as))
486		}
487
488	1	count <- 0L
489	1	posL <- -1L
490	1	while ((pos <- regexpr(sprintf("%s[-]+", .rspBracketOpen), object)) != -1L) {
491		# Nothing changed? (e.g. if there is an unclosed comment)
492	1	if (identical(pos, posL)) {
493	0	break
494		}
495
496		# Identify the comment length of the first comment found
497	1	n <- attr(pos, "match.length") - 2L
498	1	if (n < 2L) {
499	0	tag <- substring(object, first=pos)
500	0	start <- substring(tag, first=1L, n+2L)
501	0	throw(RspParseException(sprintf("Detected an RSP comment start tag (%s) but no matching end tag: %s", sQuote(start), sQuote(tag))))
502		}
503
504	1	verbose && printf(verbose, "Number of hypens of first comment found: %d\n", n)
505
506		# Find all comments of this same length
507	1	doc <- parseRaw(parser, object, what="comment", commentLength=n, verbose=less(verbose, 50))
508
509	1	idxs <- which(sapply(doc, FUN=inherits, "RspComment"))
510	1	count <- count + length(idxs)
511
512		# Trim non-text RSP constructs
513	1	doc <- trimNonText(doc, verbose=less(verbose, 10))
514
515		# Preprocess (=drop RspComments and adjust for empty lines)
516	1	doc <- preprocess(doc, verbose=less(verbose, 10))
517
518		# Coerce to RspString
519	1	object <- asRspString(doc)
520
521	1	posL <- pos
522		}
523
524	1	if (count > 0L) {
525	1	verbose && cat(verbose, "Number of 'paired' RSP comments dropped: ", count)
526	1	verbose && cat(verbose, "Length of RSP string after: ", nchar(object))
527		} else {
528	1	verbose && cat(verbose, "No 'paired' RSP comments found.")
529		}
530
531	1	verbose && exit(verbose)
532
533
534	1	if (until == "directives") {
535	1	verbose && exit(verbose)
536	1	docP <- parseRaw(parser, object, what="directive", verbose=less(verbose, 50))
537	1	return(returnAs(docP, as=as))
538		}
539
540		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
541		# (2a) Parse RSP preprocessing directive
542		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
543	1	verbose && enter(verbose, "Processing RSP preprocessing directives")
544	1	verbose && cat(verbose, "Length of RSP string before: ", nchar(object))
545
546	1	doc <- parseRaw(parser, object, what="directive", verbose=less(verbose, 50))
547
548		# Nothing todo?
549	1	if (length(doc) == 0L) {
550	1	return(returnAs(doc, as=as))
551		}
552
553	1	idxs <- which(sapply(doc, FUN=inherits, "RspUnparsedDirective"))
554	1	if (length(idxs) > 0L) {
555	1	verbose && cat(verbose, "Number of (unparsed) RSP preprocessing directives found: ", length(idxs))
556
557		# Parse each of them
558	1	for (idx in idxs) {
559	1	doc[[idx]] <- parseDirective(doc[[idx]])
560		}
561
562		# Trim non-text RSP constructs
563	1	doc <- trimNonText(doc, verbose=less(verbose, 10))
564
565		# Process all RSP preprocessing directives, i.e. <%@...%>
566	1	doc <- preprocess(doc, envir=envir, ..., verbose=less(verbose, 10))
567
568		# Coerce to RspString
569	1	object <- asRspString(doc)
570	1	verbose && cat(verbose, "Length of RSP string after: ", nchar(object))
571		} else {
572	1	verbose && cat(verbose, "No RSP preprocessing directives found.")
573		}
574	1	idxs <- NULL; # Not needed anymore
575
576	1	verbose && exit(verbose)
577
578	1	if (until == "expressions") {
579	1	verbose && exit(verbose)
580	1	return(returnAs(doc, as=as))
581		}
582
583
584		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
585		# (3) Parse RSP expressions
586		# - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
587	1	verbose && enter(verbose, "Processing RSP expressions")
588	1	verbose && cat(verbose, "Length of RSP string before: ", nchar(object))
589
590	1	doc <- parseRaw(parser, object, what="expression", verbose=less(verbose, 50))
591
592		# Nothing todo?
593	1	if (length(doc) == 0L) {
594	0	return(returnAs(doc, as=as))
595		}
596
597	1	idxs <- which(sapply(doc, FUN=inherits, "RspUnparsedExpression"))
598
599	1	if (length(idxs) > 0L) {
600	1	verbose && cat(verbose, "Number of (unparsed) RSP expressions found: ", length(idxs))
601
602		# Parse them
603	1	for (idx in idxs) {
604	1	doc[[idx]] <- parseExpression(doc[[idx]])
605		}
606
607		# Trim non-text RSP constructs
608	1	doc <- trimNonText(doc, verbose=less(verbose, 10))
609
610		# Preprocess (=trim all empty lines)
611	1	doc <- preprocess(doc, envir=envir, ..., verbose=less(verbose, 10))
612
613	1	if (verbose && isVisible(verbose)) {
614	1	object <- asRspString(doc)
615	1	verbose && cat(verbose, "Length of RSP string after: ", nchar(object))
616		}
617		} else {
618	1	verbose && cat(verbose, "No RSP expressions found.")
619		}
620
621	1	verbose && exit(verbose)
622
623	1	if (until == "end") {
624	1	verbose && exit(verbose)
625	1	return(returnAs(doc, as=as))
626		}
627
628	1	verbose && exit(verbose)
629
630	1	returnAs(doc, as=as)
631		}, protected=TRUE)