utils-translate.R

#' Establish and Manage Translation Strings
#'
#' This is documentation for internal functions for translation. If you want a
#' guide to providing translations, please read `vignette("translations",
#' package = "sandpaper")`
#'
#' @details A page generated from `{sandpaper}` is made up of user-provided
#'   content wrapped into templated HTML provided by `{varnish}`. Since users can
#'   provide content in any human language that can be processed by computer,
#'   `{sandpaper}` must have a method to match the template content to the
#'   language of the content. These translations are added to the source of
#'   `{sandpaper}` by volunteers using the `{potools}` package.
#'
#'   Template content strings are stored in the `$translations` element of the
#'   `these` global environment variable, which is generated by the
#'   `establish_translation_vars()` function, which is run every time
#'   `{sandpaper}` is loaded. The `$translations` element consists of three
#'   lists:
#'
#'    - `varnish`: a list of translated strings that are passed directly
#'      to `{varnish}`
#'    - `computed`: a list of translated strings that are incorporated into
#'      the HTML content before it is passed to `{varnish}`.
#'    - `src`: a source list of the above two lists that serves as the source
#'      of the translations.
#'
#'   Whenever a lesson is built, the function `set_language()` will read the
#'   `lang` item from the `config.yaml` and apply translations to
#'   `these$translations$varnish` and `these$translations$computed` before the
#'   lesson is generated or updated.
#'
#' ## List of Translation Variables
#'
#' ```{r, child="man/children/translation-vars.Rmd"}
#' ```
#'
#' @aliases translations
#' @rdname translations
#' @seealso [known_languages()] for a list of known language codes.
#' @keywords internal
#' @examples
#' # When sandpaper is loaded, these functions return English
#' snd <- asNamespace("sandpaper")
#' head(snd$tr_varnish())
#' head(snd$tr_computed())
#'
#' # Setting language to Spanish will translate the computed and varnish
#' snd$set_language("es")
#' head(snd$tr_varnish())
#' head(snd$tr_computed())
#'
#' # The source will remain the same
#' head(snd$tr_src("varnish"))
#' head(snd$tr_src("computed"))
#'
#' # Running set_language with no arguments defaults to English
#' snd$set_language()
#' head(snd$tr_varnish())
#' head(snd$tr_computed())
these <- new.env(parent = emptyenv())

#' @rdname translations
#' @keywords internal
establish_translation_vars <- function() {
  # Create central list of elements to translate. This function is called in
  # the zzz.R file and establishes a central list of translation variables that
  # are used to generate the website.
  withr::with_language("en", {
    varnish <- list(
      # Keys and values that are known by `{varnish}`. They are passed directly
      # via pkgdown::render_page() and represented in `{varnish}` by
      # the key translate.VarName
      # header.html -----------------------------------------------------------
      SkipToMain = tr_('Skip to main content'),# alt text
      iPreAlpha = tr_('Pre-Alpha'),
      PreAlphaNote = tr_('This lesson is in the pre-alpha phase, which means that it is in early development, but has not yet been taught.'),
      AlphaNote = tr_('This lesson is in the alpha phase, which means that it has been taught once and lesson authors are iterating on feedback.'),
      iAlpha = tr_('Alpha'),
      BetaNote = tr_('This lesson is in the beta phase, which means that it is ready for teaching by instructors outside of the original author team.'),
      iBeta = tr_('Beta'),
      PeerReview = tr_('This lesson has passed peer review.'),
      InstructorView = tr_('Instructor View'),   # navbar.html
      LearnerView = tr_('Learner View'),         # navbar.html
      MainNavigation = tr_('Main Navigation'), # alt text
      ToggleNavigation = tr_('Toggle Navigation'), # alt-text
      ToggleDarkMode = tr_('Toggle theme (auto)'), # alt-text
      Menu = tr_('Menu'), # footer.html
      SearchButton = tr_('Search the All In One page'), # alt text
      Setup = tr_('Setup'),                      # navbar.html
      KeyPoints = tr_("Key Points"),             # navbar.html
      InstructorNotes = tr_('Instructor Notes'), # navbar.html
      Glossary = tr_('Glossary'),                # navbar.html
      LearnerProfiles = tr_('Learner Profiles'), # navbar.html
      More = tr_('More'),
      # Search = tr_('Search'),
      LessonProgress = tr_('Lesson Progress'), # alt text
      # navbar.html -----------------------------------------------------------
      CloseMenu = tr_("close menu"), # alt text
      EPISODES = tr_('EPISODES'),
      Home = tr_('Home'), # content-chapter.html
      HomePageNav = tr_('Home Page Navigation'), # alt text
      RESOURCES = tr_('RESOURCES'),
      ExtractAllImages = tr_('Extract All Images'),
      AIO = tr_("See all in one page"),
      DownloadHandout = tr_('Download Lesson Handout'),
      ExportSlides = tr_('Export Chapter Slides'), # content-chapter.html
      # content-[thing].html --------------------------------------------------
      PreviousAndNext = tr_('Previous and Next Chapter'), # alt text
      Previous = tr_('Previous'),
      EstimatedTime = tr_('Estimated time: {icons$clock} {minutes} minutes'),
      Next = tr_('Next'),
      NextChapter = tr_('Next Chapter'), # alt-text
      LastUpdate = tr_('Last updated on {updated}'),
      EditThisPage = tr_('Edit this page'),
      ExpandAllSolutions = tr_('Expand All Solutions'),
      # content-syllabus.html -------------------------------------------------
      SetupInstructions = tr_('Setup Instructions'),
      DownloadFiles = tr_('Download files required for the lesson'),
      ActualScheduleNote = tr_('The actual schedule may vary slightly depending on the topics and exercises chosen by the instructor.'),
      # footer.html -----------------------------------------------------------
      BackToTop = tr_('Back To Top'),
      SpanToTop = tr_('<(Back)> To Top'),
      ThisLessonCoC = tr_('This lesson is subject to the <(Code of Conduct)>'),
      CoC = tr_('Code of Conduct'),
      EditOnGH = tr_('Edit on GitHub'),
      Contributing = tr_('Contributing'),
      Source = tr_('Source'),
      Cite = tr_('Cite'),
      Contact = tr_('Contact'),
      About = tr_('About'),
      MaterialsLicensedUnder = tr_('Materials licensed under <({license})> by the authors'),
      TemplateLicense = tr_('Template licensed under <(CC-BY 4.0)> by {template_authors}'),
      Carpentries = tr_('The Carpentries'),
      BuiltWith = tr_('Built with {sandpaper_link}, {pegboard_link}, and {varnish_link}'),
      # javascript -----------------------------------------------------------
      ExpandAllSolutions = tr_('Expand All Solutions'),
      CollapseAllSolutions = tr_('Collapse All Solutions'),
      Collapse = tr_('Collapse'),
      Episodes = tr_('Episodes'),
      # beta content not used anymore.
      GiveFeedback = tr_('Give Feedback'),
      LearnMore = tr_('Learn More')
    )
    computed <- list(
      # These keys and values are used in `{sandpaper}`
      # before they are passed to `{varnish}`
      # Code blocks ----------------------------------------------------------
      OUTPUT = tr_("OUTPUT"),
      WARNING = tr_("WARNING"),
      ERROR = tr_("ERROR"),
      # Callouts -------------------------------------------------------------
      Overview    = tr_("Overview"),
      Questions   = tr_("Questions"),
      Objectives  = tr_("Objectives"),
      Callout     = tr_("Callout"),
      Challenge   = tr_("Challenge"),
      Prereq      = tr_("Prerequisite"),
      Checklist   = tr_("Checklist"),
      Discussion  = tr_("Discussion"),
      Testimonial = tr_("Testimonial"),
      Caution = tr_("Caution"),
      Keypoints   = varnish$KeyPoints,
      # Accordions -----------------------------------------------------------
      "Show me the solution" = tr_("Show me the solution"),
      "Give me a hint"       = tr_("Give me a hint"),
      "Show details"         = tr_("Show details"),
      "Instructor Note"      = tr_("Instructor Note"),
      # Headings -------------------------------------------------------------
      SummaryAndSetup = tr_("Summary and Setup"),
      SummaryAndSchedule = tr_("Summary and Schedule"),
      AllInOneView = tr_("All in One View"),
      PageNotFound = tr_("Page not found"),
      AllImages = tr_("All Images"),
      # Misc -----------------------------------------------------------------
      Anchor = tr_("anchor"), # alt text
      Figure = tr_("Figure {element}"),
      ImageOf = tr_("Image {i} of {n}: {sQuote(txt)}"),
      Finish = tr_("Finish") # end of schedule
    )
  })
  these$translations <- list(
    src = list(varnish = varnish, computed = computed),
    varnish = varnish,
    computed = computed
    # NOTE: If you want to include translations for messages to the user in
    # their own language, they could be added to this list and then the
    # message functions (e.g. those in R/utils-cli.R) could use
    # a key from these$translations$msg
    # msg = list(
    #   RemovedFile = tr_("Removed {what}"),
    # )
  )
}

#' @param lang a two-letter language code (optionally with a country code).
#'   Defaults to `NULL`, which falls back to English (the language of the
#'   source code).
#' @rdname translations
set_language <- function(lang = NULL) {
  lang <- lang %||% "en"
  known <- is_known_language(lang, warn = TRUE)
  if (known) {
    withr::with_language(lang, {
      add_varnish_translations()
    })
  }
  no_translations_exist <- length(these$translations$varnish) == 0L
  if (no_translations_exist) {
    withr::with_language("en", {
      add_varnish_translations()
    })
  }
}

# These are all the translations that occur in `{varnish}`
# NOTE: this assumes a specific language context
add_varnish_translations <- function() {
  to_translate <- these$translations$src
  these$translations$varnish <- lapply(to_translate$varnish, tr_)
  these$translations$computed <- lapply(to_translate$computed, tr_)
}

#' Show a list of languages known by `{sandpaper}`
#'
#' @return a character vector of language codes known by `{sandpaper}`
#'
#' @details The known languages are translations of menu and navigational
#' elements that exist in `{sandpaper}`. If these elements have not been
#' translated for a given language and you would like to add translations for
#' them, please consult `vignette("translations", package = "sandpaper")` for
#' details of how to do so in the source code for `{sandpaper}`.
#'
#' ## List of Known Languages:
#'
#' ```{r, echo = FALSE}
#' langs <- known_languages()
#' writeLines(paste("-", langs))
#' ```
#'
#' @seealso `vignette("translations", package = "sandpaper")` for an overview
#'   of providing translations.
#' @export
#' @examples
#' known_languages()
known_languages <- function() {
  lang_files <- system.file("po", package = "sandpaper")
  as.character(c("en", fs::path_file(fs::dir_ls(lang_files, type = "dir"))))
}

is_known_language <- function(lang = NULL, warn = FALSE) {
  lang <- lang %||% "en"
  not_known <- strsplit(lang, "_")[[1]][1] %nin% known_languages()
  if (not_known && warn) {
    warn_no_language(lang)
  }
  return(!not_known)
}

#' @param from a single character specifying the translation list to fetch.
#'   This defaults to "varnish" but can be one of the following:
#'   ```{r echo = FALSE, results = "asis"}
#'   writeLines(paste("-", names(these$translations)))
#'   ```
#' @param key a single character specifying a specific key to fetch from the
#'   translation list. This defaults to `NULL`, returning the whole list.
#' @return if `key = NULL`, a list if `key` is a single character, the result
#'   will be an unnamed character vector of length 1 representing the value from
#'   that list.
#' @rdname translations
tr_src <- function(from = "varnish", key = NULL) {
  res <- these$translations$src[[from]]
  if (length(key) == 1L) {
    res <- res[[key]]
  }
  return(res)
}

#' @rdname translations
tr_get <- function(from = "varnish", key = NULL) {
  res <- these$translations[[from]]
  if (length(key) == 1L) {
    res <- res[[key]]
  }
  return(res)
}

#' @rdname translations
tr_varnish <- function(key = NULL) {
  tr_get(from = "varnish", key = key)
}

#' @rdname translations
tr_computed <- function(key = NULL) {
  tr_get(from = "computed", key = key)
}


starts_with_whitespace <- function(x) {
  grepl("^\\s", x)
}

# Function to check if a string ends with a whitespace
ends_with_whitespace <- function(x) {
  grepl("\\s$", x)
}

# Apply translations to text assuming that the names of the translations
# matches the text
apply_translations <- function(txt, translations) {
  ntxt <- length(txt)
  ntranslations <- length(translations)
  # empty text or empty translations returns the text
  if (ntxt == 0L || ntranslations == 0L) {
    return(txt)
  }

  # https://github.com/carpentries/sandpaper/issues/562
  # check if there is leading or trailing whitespace
  sw <- starts_with_whitespace(txt)
  ew <- ends_with_whitespace(txt)

  # replace newlines with spaces and trim whitespace
  trimmed_txt <- sub("\n", " ", txt)
  trimmed_txt <- sub("^[[:space:]]+", "", trimmed_txt)
  trimmed_txt <- sub("[[:space:]]+$", "", trimmed_txt)

  # when there are translations, apply them only to the matching elements of
  # the vector
  to_translate <- trimmed_txt %in% names(translations)
  if (any(to_translate)) {
    ids <- trimmed_txt[to_translate]
    trimmed_txt[to_translate] <- translations[ids]

    # reintroduce whitespace where there was previously
    if (any(sw)) {
      trimmed_txt <- paste0(" ", trimmed_txt)
    }

    if (any(ew)) {
      trimmed_txt <- paste0(trimmed_txt, " ")
    }

    return(trimmed_txt)
  } else {
    # return original text if no translations are found
    return(txt)
  }
}

# generator of translations for code blocks.
get_codeblock_translations <- function() {
  needed <- c("OUTPUT",
    "ERROR",
    "WARNING")
  unlist(tr_computed()[needed])
}

# generator for translations of callout blocks and accordions
get_callout_translations <- function() {
  needed <- c("Callout",
    "Challenge",
    "Prereq",
    "Checklist",
    "Discussion",
    "Testimonial",
    "Keypoints")
  unlist(tr_computed()[needed])
}

get_accordion_translations <- function() {
  needed <- c("Show me the solution",
    "Give me a hint",
    "Show details",
    "Instructor Note"
  )
  unlist(tr_computed()[needed])
}

# replace text string with a <(kirby template)> with link text
# replace_link("this string has a <(kirby template)>", "https://emojicombos.com/kirby")
replace_link <- function(txt, href) {
  replace_html(txt, open = paste0('<a href="', href, '">'), close = "</a>")
}

replace_html <- function(txt, open, close) {
  txt <- sub("<(", open, txt, fixed = TRUE)
  return(sub(")>", close, txt, fixed = TRUE))
}

#' Apply template items to translated strings
#'
#' @param the_data a list of global variables (either `learner_globals` or
#' `instructor_globals`) that also contains a "translate" element containing
#' a list of translated strings.
#'
#' @return the translated list with templated data filled out
#' @keywords internal
#' @details There are two kinds of templating we use:
#'
#'  1. variable templating indicated by `{key}` where `key` represents a
#'     variable that exists within the global data and is replaced.
#'  2. link templating indicated by `<(text to wrap)>` where we replace the
#'     `<()>` with a known URL or HTML markup. This allows the translators to
#'     translate text without having to worry about HTML markup.
#' @examples
#'
#' dat <- list(
#'   a = "a barn",
#'   b = "a bee",
#'   minutes = 5,
#'   translate = list(
#'      one = "a normal translated string (pretend it's translated from another language)",
#'      two = "a question: are you (A) {a}, (B) {b}",
#'      EstimatedTime = "Estimated time: {icons$clock} {minutes}",
#'      license = "Licensed under {license} by the authors",
#'      ThisLessonCoC = "This lesson operates under our <(Code of Conduct)>"
#'   )
#' )
#' asNamespace("sandpaper")$fill_translation_vars(dat)
fill_translation_vars <- function(the_data) {
  # define icons that we will need to pre-fab insert for the template.
  icns <- c("clock", "edit")
  template_icns <- glue::glue(
    '<i aria-hidden="true" data-feather="{icns}"></i>'
  )

  # add our templating variables to the data list
  named_icons <- as.list(template_icns)
  names(named_icons) <- icns
  dat <- c(the_data,
    list(
       icons = named_icons,
       template_authors = '<a href="https://carpentries.org/">The Carpentries</a>',
       license = the_data$license %||% "CC-BY 4.0",
       license_url = the_data$license_url %||% "LICENSE.html",
       minutes = the_data$minutes %||% NULL,
       updated = the_data$updated %||% NULL
    )
  )
  # variables that have known fixed URLs can simply have them added in.
  dat$license <- glue::glue('<a href="LICENSE.html">{dat$license}</a>')
  translated <- the_data[["translate"]]

  # all translated items need to have variables replaced and the URL templates
  # filled out.
  for (key in names(translated)) {
    the_string <- translated[[key]]
    is_templated <- grepl("[{][A-z_$.]+?[}]", the_string)
    if (is_templated) {
      # if the string has a template variable {key}, it should be replaced
      # via {glue}.
      the_string <- glue::glue_data(dat, the_string)
    }
    string_exists <- length(the_string) > 0L
    has_url_template <- string_exists && grepl("<(", the_string, fixed = TRUE)
    if (has_url_template) {
      # In this space, we need to replace links present in the URL template
      # with their URLs
      # (e.g. going from `<(hello)>` to `<a href="hello.html">hello</a>`)
      the_string <- switch(key,
        ThisLessonCoC = replace_link(the_string,
          href = "CODE_OF_CONDUCT.html"
        ),
        TemplateLicense = replace_link(the_string,
          href = "https://creativecommons.org/licenses/by-sa/4.0/"
        ),
        MaterialsLicensedUnder = replace_link(the_string,
          href = dat$license_url
        ),
        SpanToTop = replace_html(the_string,
          open = '<span class="d-none d-sm-none d-md-none d-lg-none d-xl-block">',
          close = '</span>'
        ),
        the_string
      )
    }
    translated[[key]] <- the_string
  }
  return(translated)
}