Experiment implementing po_extract()

DESCRIPTION

@@ -16,3 +16,4 @@ Encoding: UTF-8
 Config/testthat/edition: 3
 VignetteBuilder: knitr
 RoxygenNote: 7.1.2
+Roxygen: list(markdown = TRUE)

NAMESPACE

@@ -11,6 +11,7 @@ export(translate_package)
 export(get_message_data)
 export(write_po_file, po_metadata)
 
+export(po_extract)
 export(po_compile)
 
 export(check_cracked_messages, check_untranslated_cat, check_untranslated_src)

R/get_message_data.R

@@ -1,19 +1,98 @@
+#' Extract user-visible messages from a package
+#'
+#' This function looks in the R and src directories of a package for
+#' user-visible messages and compiles them as a [data.table::data.table()]
+#' to facilitate analyzing this corpus as such.
+#'
+#' @param dir Character, default the present directory; a directory in which
+#'   an R package is stored.
+#' @param custom_translation_functions A `list` with either/both of two
+#'   components, `R` and `src`, together governing how to extract any
+#'   non-standard strings from the package.
+#'
+#'   See Details in [translate_package()].
+#' @param style Translation style, either `"base"` or `"explict"`.
+#'   The default, `NULL`, reads from the `DESCRIPTION` field
+#'   `Config/potools/style` so you can specify the style once for your
+#'   package.
+#'
+#'   Both styles extract strings explicitly flagged for translation with
+#'   `gettext()` or `ngettext()`. The base style additionally extracts
+#'   strings in calls to `stop()`, `warning()`, and `message()`,
+#'   and to `stopf()`, `warningf()`, and `messagef()` if you have
+#'   added those helpers to your package. The explicit style also accepts
+#'   `tr_()` as a short hand for `gettext()`. See
+#'   `vignette("developer")` for more details.
+#' @param verbose Logical, default `TRUE` (except during testing). Should
+#'   extra information about progress, etc. be reported?
+#' @return A `data.table` with the following schema:
+#'
+#' * `message_source`, `character`, either `"R"`
+#'   or `"src"`, saying whether the string was found in the R or the src
+#'   folder of the package
+#' * `type`, `character`, either `"singular"` or `"plural"`;
+#'   `"plural"` means the string came from [ngettext()] and can be pluralized
+#' * `file`, `character`, the file where the string was found
+#' * `msgid`, `character`, the string (character literal or `char` array as
+#'   found in the source); missing for all `type == "plural"` strings
+#' * `msgid_plural`, `list(character, character)`, the strings
+#'   (character literals or `char` arrays as found in the source); the first
+#'   applies in English for `n=1` (see `ngettext`), while the second
+#'   applies for `n!=1`; missing for all `type == "singular"` strings
+#' * `call`, `character`, the full call containing the string
+#'   that was found
+#' * `line_number`, `integer`, the line in `file` where the string was found
+#' * `is_repeat`, `logical`, whether the `msgid` is a duplicate within this
+#'   `message_source`
+#' *  `is_marked_for_translation`, `logical`, whether the string is marked for
+#'    translation (e.g., in R, all character literals supplied to a `...`
+#'    argument in [stop()] are so marked)
+#' *  `is_templated`, `logical`,whether the string is templatable (e.g., uses
+#'    `%s` or other formatting markers)
+#' @author Michael Chirico
+#' @seealso [translate_package()], [write_po_file()]
+#' @examples
+#' pkg <- system.file('pkg', package = 'potools')
+#' get_message_data(pkg)
+#'
+#' # includes strings provided to the custom R wrapper function catf()
+#' get_message_data(pkg, custom_translation_functions = list(R = "catf:fmt|1"))
+#'
+#' # includes untranslated strings provided to the custom
+#' #   C/C++ wrapper function ReverseTemplateMessage()
+#' get_message_data(
+#'   pkg,
+#'   custom_translation_functions = list(src = "ReverseTemplateMessage:2")
+#' )
+#'
+#' # cleanup
+#' rm(pkg)
 get_message_data = function(
   dir = ".",
   custom_translation_functions = list(R = NULL, src = NULL),
+  style = NULL,
   verbose = !is_testing()
 ) {
   package = get_desc_data(dir, 'Package')
   is_base = package == 'base'
 
-  if (verbose) message('Getting R-level messages...')
+  # If style not specified, read from DESCRIPTION
+  if (is.null(style)) {
+    style <- get_desc_data(dir, "Config/potools/style")
+    if (is.na(style)) {
+      style <- "base"
+    }
+  }
+
+  if (verbose && dir.exists(file.path(dir, "R"))) message('Getting R-level messages...')
   r_message_data = get_r_messages(
     dir,
     custom_translation_functions = custom_translation_functions$R,
-    is_base
+    style = style,
+    is_base = is_base
   )
 
-  if (verbose) message('Getting src-level messages...')
+  if (verbose && dir.exists(file.path(dir, "src"))) message('Getting src-level messages...')
   src_message_data = get_src_messages(
     dir,
     custom_translation_functions = custom_translation_functions$src,

R/get_r_messages.R

@@ -1,6 +1,8 @@
 # Spiritual cousin version of tools::{x,xn}gettext. Instead of iterating the AST
 #   as R objects, do so from the parse data given by utils::getParseData().
-get_r_messages <- function (dir, custom_translation_functions = NULL, is_base = FALSE) {
+get_r_messages <- function (dir, custom_translation_functions = NULL, is_base = FALSE, style = c("base", "explicit")) {
+  style <- match.arg(style)
+
   expr_data <- rbindlist(lapply(parse_r_files(dir, is_base), getParseData), idcol = 'file')
   # R-free package (e.g. a data package) fails, #56
   if (!nrow(expr_data)) return(r_message_schema())
@@ -37,16 +39,27 @@ get_r_messages <- function (dir, custom_translation_functions = NULL, is_base =
   #   <!-- mix and match those two types indefinitely -->
   #   <OP-RIGHT-PAREN>)</OP-RIGHT-PAREN>
   # </expr>
+  dots_funs <- domain_dots_funs(use_conditions = style == "base")
+  fmt_funs <- domain_fmt_funs(use_conditions = style == "base")
+
   singular_strings = rbind(
-    get_dots_strings(expr_data, DOMAIN_DOTS_FUNS, NON_DOTS_ARGS),
+    get_dots_strings(expr_data, dots_funs, NON_DOTS_ARGS),
     # treat gettextf separately since it takes a named argument, and we ignore ...
-    get_named_arg_strings(expr_data, 'gettextf', c(fmt = 1L), recursive = TRUE),
+    get_named_arg_strings(expr_data, fmt_funs, c(fmt = 1L), recursive = TRUE),
     # TODO: drop recursive=FALSE option now that exclude= is available? main purpose of recursive=
     #   was to block cat(gettextf(...)) usage right?
     get_dots_strings(expr_data, 'cat', c("file", "sep", "fill", "labels", "append"), recursive = FALSE)
   )
-
   plural_strings = get_named_arg_strings(expr_data, 'ngettext', c(msg1 = 2L, msg2 = 3L), plural = TRUE)
+
+  if (style == "explicit") {
+    tr_ <- get_dots_strings(expr_data, 'tr_', character(), recursive = TRUE)
+    tr_n <- get_named_arg_strings(expr_data, 'tr_n', c(singular = 2L, plural = 3L), plural = TRUE)
+
+    singular_strings <- rbind(singular_strings, tr_)
+    plural_strings <- rbind(plural_strings, tr_n)
+  }
+
   # for plural strings, the ordering within lines doesn't really matter since there's only one .pot entry,
   #   so just use the parent's location to get the line number
   plural_strings[ , id := parent]
@@ -146,11 +159,14 @@ get_r_messages <- function (dir, custom_translation_functions = NULL, is_base =
   #   You are trying to join data.tables where %s has 0 columns.
   msg[type == 'singular', 'is_repeat' := duplicated(msgid)]
 
-  known_translators = c(DOMAIN_DOTS_FUNS, 'ngettext', 'gettextf', get_fnames(custom_params))
+  known_translators = c(dots_funs, 'ngettext', fmt_funs, get_fnames(custom_params))
+  if (style == "explicit") {
+    known_translators <- c(known_translators, "tr", "tr_")
+  }
   msg[ , 'is_marked_for_translation' := fname %chin% known_translators]
 
   # TODO: assume custom translators are translated? or maybe just check the regex?
-  msg[ , "is_templated" := fname == "gettextf"]
+  msg[ , "is_templated" := fname %chin% fmt_funs]
   msg[ , "fname" := NULL]
 
   msg[]
@@ -274,10 +290,21 @@ exclude_untranslated = function(expr_data, comments) {
 #     if (is.null(f_args <- args(f))) next
 #     if (any(names(formals(f_args)) == 'domain')) cat(obj, '\n')
 # }
-DOMAIN_DOTS_FUNS = c("warning", "stop", "message", "packageStartupMessage", "gettext")
+domain_dots_funs <- function(use_conditions = TRUE) {
+  c(
+    "gettext",
+    if (use_conditions) c("stop", "warning", "message", "packageStartupMessage")
+  )
+}
+
+domain_fmt_funs <- function(use_conditions = TRUE) {
+  paste0(domain_dots_funs(use_conditions), "f")
+}
+
+#
 NON_DOTS_ARGS = c("domain", "call.", "appendLF", "immediate.", "noBreaks.")
 
-# for functions (e.g. DOMAIN_DOTS_FUNS) where we extract strings from ... arguments
+# for functions (e.g. domain_dots_funs) where we extract strings from ... arguments
 get_dots_strings = function(expr_data, funs, arg_names, exclude = c('gettext', 'gettextf', 'ngettext'), recursive = TRUE) {
   call_neighbors = get_call_args(expr_data, funs)
   call_neighbors = drop_suppressed_and_named(call_neighbors, expr_data, arg_names)

R/po_extract.R

@@ -0,0 +1,45 @@
+#' Extract messages for translation into a `.pot` file
+#'
+#' `po_extract()` scans your package for strings to be translated and
+#' saves them into a `.pot` template file (in the package's `po` directory).
+#' You should never modify this file by hand; instead modify the underlying
+#' source code and re-run `po_extract()`.
+#'
+#' @returns The extracted messages as computed by [get_message_data()],
+#'   invisibly.
+#' @inheritParams get_message_data
+po_extract <- function(
+    dir = ".",
+    custom_translation_functions = list(),
+    verbose = !is_testing(),
+    style = NULL) {
+
+  message_data <- get_message_data(dir,
+    custom_translation_functions = custom_translation_functions,
+    verbose = verbose,
+    style = style
+  )
+
+  n <- nrow(message_data)
+  if (!n) {
+    if (verbose) message('No messages to translate')
+    return(invisible())
+  }
+  # TODO: messagef() is double-translating the ngettext() result...
+  #   it needs an escape valve
+  if (verbose) messagef(ngettext(n, "Found %i message", "Found %i messages"), n)
+
+  po_dir <- file.path(dir, 'po')
+  dir.create(po_dir, showWarnings = FALSE)
+
+  desc <- get_desc_data(dir)
+  po_params = list(
+    package = desc[['Package']],
+    version = desc[['Version']],
+    copyright = NULL,
+    bugs = NULL
+  )
+
+  write_po_files(message_data, po_dir, po_params, template = TRUE, verbose = verbose)
+  invisible(message_data)
+}

R/translate_package.R

@@ -78,7 +78,6 @@ translate_package = function(
     if (length(responded_yes) && responded_yes) return(invisible())
   }
 
-  if (verbose) message('Generating .pot files...')
   po_params = list(package = package, version = version, copyright = copyright, bugs = bugs)
   write_po_files(message_data, po_dir, po_params, template = TRUE, use_base_rules = use_base_rules)
 

R/utils.R

@@ -19,7 +19,7 @@ get_desc_data = function(dir, fields = c('Package', 'Version')) {
     stopf('%s is not a package (missing DESCRIPTION)', normalizePath(dir))
   }
   desc_data <- read.dcf(desc_file, fields)
-  if (nrow(desc_data) != 1L || anyNA(desc_data)) {
+  if (missing(fields) && (nrow(desc_data) != 1L || anyNA(desc_data))) {
     stopf('%s is not a package (missing Package and/or Version field in DESCRIPTION)', normalizePath(dir))
   }
   return(drop(desc_data))

R/write_po_file.R

@@ -5,7 +5,7 @@
 #   default by xgettext, etc (unless --no-location is set, or if --add-location=never).
 # note also that the gettext manual says we shouldn't write these ourselves... for now i'm
 #   going to go ahead and try to anyway until it breaks something :)
-write_po_files <- function(message_data, po_dir, params, template = FALSE, use_base_rules = FALSE) {
+write_po_files <- function(message_data, po_dir, params, template = FALSE, use_base_rules = FALSE, verbose = TRUE) {
   if (template) {
     r_file <- sprintf("R-%s.pot", params$package)
     src_file <- sprintf("%s.pot", if (params$package == 'base') 'R' else params$package)
@@ -32,6 +32,9 @@ write_po_files <- function(message_data, po_dir, params, template = FALSE, use_b
       `X-Generator` = sprintf("potools %s", packageVersion("potools"))
     ))
   }
+
+  if (verbose) messagef('Writing %s', r_file)
+
   write_po_file(
     message_data[message_source == "R"],
     file.path(po_dir, r_file),