#
# SessionThemes.R
#
# Copyright (C) 2022 by Posit Software, PBC
#
# Unless you have received this program directly from Posit Software pursuant
# to the terms of a commercial license agreement with Posit Software, then
# this program is licensed to you under the terms of version 3 of the
# GNU Affero General Public License. This program is distributed WITHOUT
# ANY EXPRESS OR IMPLIED WARRANTY, INCLUDING THOSE OF NON-INFRINGEMENT,
# MERCHANTABILITY OR FITNESS FOR A PARTICULAR PURPOSE. Please refer to the
# AGPL (http://www.gnu.org/licenses/agpl-3.0.txt) for more details.
#

# ACE/tools/tmThemes.js Functions ==================================================================

# Determines the luma of a color. This refers to the perceived luminance of the color. More 
# information can be found at https://en.wikipedia.org/wiki/Relative_luminance.
# 
# @param color    The color for which to determine the luma.
#
# Returns the luma of the specified color.
.rs.addFunction("getLuma", function(color) {
   rgb <- .rs.getRgbColor(color)
   (0.21 * rgb[[1]] + 0.72 * rgb[[2]] + 0.07 * rgb[[3]]) / 255
})

# Parses a color.
# 
# @param color    The color to parse.
#
# Returns the parsed color.
.rs.addFunction("parseColor", function(color) {
   colorLen <- nchar(color)
   if (colorLen < 1)
   {
      return(NULL)
   }
   
   if (colorLen == 4)
   {
      color <- gsub("([a-fA-F0-9])", "\\1\\1", color)
   }
   if (!grepl("^#[a-fA-F0-9]{6}$", color))
   {
      if (!grepl("^#[a-fA-F0-9]{8}$", color))
      {
         stop(
            "Unable to parse color: ",
            color, 
            "it must have format \"#RGB\", \"#RRGGBB\" or \"#RRGGBBAA\" where `R`, `G`, `B`, and `A` are in [0x00, 0xFF].",
            call. = FALSE)
      }
      
      aVal <- format(
         round(strtoi(substr(color, 8, 9), base = 16L) / 255, digits = 2),
         nsmall = 2)
      color <- paste0(
         "rgba(",
         paste(
            c(.rs.getRgbColor(substr(color, 1, 7)), aVal),
            collapse = ", "),
         ")")
   }
   
   color
})

# Parses a font style and converts it to CSS.
#
# @param styles      The style(s) to convert.
#
# Returns the converted font style.
.rs.addFunction("parseStyles", function(styles) {
   css <- list()
   fontStyle <- if (is.null(styles$fontStyle)) "" else styles$fontStyle
   
   if (grepl("underline", fontStyle))
   {
      # Not the most efficient, but this shouldn't be an overly common operation.
      css[["text-decoration"]] = "underline"
   }
   if (grepl("italic", fontStyle))
   {
      css[["font-style"]] <- "italic"
   }
   if (grepl("bold", fontStyle))
   {
      css[["font-weight"]] <- "bold"
   }
   
   if (!is.null(styles$foreground))
   {
      css[["color"]] <- .rs.parseColor(styles$foreground)
   }
   if (!is.null(styles$background))
   {
      css[["background-color"]] <- .rs.parseColor(styles$background)
   }
   
   css
})

# Extracts the style information from a parsed tmTheme object.
#
# @param theme             The parsed tmTheme object.
# @param supportScopes     tmTheme scopes that are supported by ace and a mapping to their ace
#                          value.
# 
# Returns a list which contains the styles and unsupportedScopes in named elements.
.rs.addFunction("extractStyles", function(theme, supportedScopes) {
   # Fallback Scopes
   fallbackScopes <- list(
      "keyword" = "meta",
      "keyword.operator" = "keyword",
      "support.type" = "storage.type",
      "variable" = "entity.name.function")
   
   # Default Global Values
   defaultGlobals <- list(
      "printMargin" = "#e8e8e8",
      "background" = "#ffffff",
      "foreground" = "#000000",
      "gutter" = "#f0f0f0",
      "selection" = "rgb(181, 213, 255)",
      "step" = "rgb(198, 219, 174)",
      "bracket" = "rgb(192, 192, 192)",
      "active_line" = "rgba(0, 0, 0, 0.07)",
      "cursor" = "#000000",
      "invisible" = "rgb(191, 191, 191)",
      "fold" = "#6b72e6")
   
   globalSettings <- theme$settings[[1]]$settings
   
   # Get the global colors
   invisColor <- .rs.parseColor(globalSettings$invisibles)
   if (is.null(invisColor)) invisColor <- defaultGlobals$invisibles
   
   styles <- list(
      "printMargin" = defaultGlobals$printMargin,
      "background" = .rs.parseColor(globalSettings$background),
      "foreground" = .rs.parseColor(globalSettings$foreground),
      "gutter" = defaultGlobals$gutter,
      "selection" = .rs.parseColor(globalSettings$selection),
      "step" = defaultGlobals$step,
      "bracket" =  invisColor,
      "active_line" = .rs.parseColor(globalSettings$lineHighlight),
      "cursor" = .rs.parseColor(globalSettings$caret),
      "invisible" = invisColor)
   
   if (!("background" %in% names(styles))) styles$background <- defaultGlobals$background
   if (!("foreground" %in% names(styles))) styles$foreground <- defaultGlobals$foreground
   if (!("selection" %in% names(styles))) styles$selection <- defaultGlobals$selection
   if (!("active_line" %in% names(styles))) styles$active_line <- defaultGlobals$active_line
   if (!("cursor" %in% names(styles))) styles$cursor <- defaultGlobals$cursor
   
   # Get the specified scopes
   unsupportedScopes <- list()
   supportedScopeNames <- names(supportedScopes)
   for (element in theme$settings)
   {
      if (!is.null(element$scope) && !is.null(element$settings))
      {
         # Split on commas and strip whitespace.
         scopes <- strsplit(gsub("^\\s*|\\s*$", "", element$scope), "\\s*(,|\\|\\s)\\s*")[[1]]
         for (scope in scopes)
         {
            style <- .rs.parseStyles(element$settings)
            haveStyle <- !is.null(style) && any(!is.na(style)) && (length(style) > 0)
            if ((scope %in% supportedScopeNames) && haveStyle)
            {
               styles[[ supportedScopes[[scope]] ]] <- style
            }
            else if (haveStyle)
            {
               if (!(scope %in% names(unsupportedScopes)))
               {
                  unsupportedScopes[[scope]] <- 0
               }
               else 
               {
                  unsupportedScopes[[scope]] <- unsupportedScopes[[scope]] + 1
               }
            }
         }
      }
   }
   
   if (!("fold" %in% names(styles)))
   {
      if (("entity.name.function" %in% names(styles)) 
          && ("color" %in% names(styles[["entity.name.function"]]))
          && (styles[["entity.name.function"]][["color"]] != ""))
      {
         styles[["fold"]] <- styles[["entity.name.function"]][["color"]]
      }
      else if (("keyword" %in% names(styles))
               && ("color" %in% names(styles[["keyword"]]))
               && (styles[["keyword"]][["color"]] != ""))
      {
         styles[["fold"]] <- styles[["keyword"]][["color"]]
      }
      else
      {
         styles[["fold"]] <- defaultGlobals$fold
      }
   }
   
   styles[["gutterBg"]] <- styles$background
   styles[["gutterFg"]] <- .rs.mixColors(styles$foreground, styles$background, 0.5)
   styles[["selected_word_highlight"]] <- paste0("border: 1px solid ", styles$selection)
   
   styles$isDark = tolower(as.character(.rs.getLuma(styles$background) <  0.5))
   
   fScopeNames <- names(fallbackScopes)
   for (i in 1:length(fallbackScopes))
   {
      name <- fScopeNames[i]
      scope <- fallbackScopes[[i]]
      if (!(name %in% names(styles)) || !("color" %in% names(styles[[name]])))
      {
         if (!(scope %in% names(styles)) || !("color" %in% names(styles[[scope]])))
         {
            # All fallback elements are foreground for now.
            if (!(name %in% names(styles))) styles[[name]] <- list()
            styles[[name]][["color"]] <- styles$foreground
         }
         else if (name %in% names(styles))
         {
            styles[[name]][["color"]] <- styles[[scope]][["color"]]
         }
         else
         {
            styles[[name]] <- styles[[scope]]
         }
      }
   }
   
   list("styles" = styles, "unsupportedScopes" = unsupportedScopes)
})

# Converts a theme from a tmTheme to an Ace css theme.
#
# @param tmTheme     The parsed tmTheme object.
# 
# Returns Ace css theme as a string.
.rs.addFunction("convertTmTheme", function(tmTheme) {
   # Helper functions 
   
   # Fills a template value with the given replacements.
   #
   # @param template          The template to fill.
   # @param replacements      The replacements to fill the template with.
   #
   # Returns a string of the filled template.
   fillTemplate <- function(template, replacements) {
      repeat
      {
         matches <- regmatches(template, regexec("%(.+?)%", template))[[1]]
         if (length(matches) != 2)
         {
            break
         }
         
         replacement <- replacements[[matches[2]]]
         if (is.null(replacement)) replacement <- ""
         template <- sub(matches[1], replacement, template)
      }
      
      template
   }
   
   # Hyphenates a title or camel case string, separating words and replacing "_" with "-".
   # 
   # @param string      The string to convert to lower case with hyphens.
   #
   # Returns the converted string.
   hyphenate <- function(string) {
      tolower(
         gsub("-+", "-", # Get rid of duplicate hyphens
              sub(
                 "^-", "", # Get rid of leading hyphen
                 gsub(
                    "_",
                    "-", # Replace _ with hyphen
                    gsub(
                       "([^0-9A-Z])([A-Z])", # Insert hyphen before capital letters which are not immediately preceded by a digit or another capital letter
                       "\\1-\\2",
                       gsub("(?:'|\"|\\(([^\\)]*)\\))", "\\1", # Remove special characters and anything encased in parentheses
                            gsub("&","-and-", # Replace & with And
                                 gsub("\\s", "-", string)))))))) # Replace whitespace with hyphen
   }
   
   # Quotes a string and adds extra escapes to escape characters.
   #
   # @param string      The string to quoted.
   #
   # Returns the processed string
   quoteStr <- function(string) {
      paste0(
         "\"",
         gsub("\n", "\\n", gsub("\"", "\\\"", gsub("\\", "\\\\", string))),
         "\"")
   }
   
   # Syntax highlighting scopes
   supportedScopes <- list()
   
   # Keywords
   supportedScopes[["keyword"]] <- "keyword"
   supportedScopes[["keyword.operator"]] <- "keyword.operator"
   supportedScopes[["keyword.other.unit"]] <- "keyword.other.unit"
   
   # Constants
   supportedScopes[["constant"]] <- "constant"
   supportedScopes[["constant.language"]] <- "constant.language"
   supportedScopes[["constant.library"]] <- "constant.library"
   supportedScopes[["constant.numeric"]] <- "constant.numeric"
   supportedScopes[["constant.character"]] <- "constant.character"
   supportedScopes[["constant.character.escape"]] <- "constant.character.escape"
   supportedScopes[["constant.character.entity"]] <- "constant.character.entity"
   supportedScopes[["constant.other"]] <- "constant.other"
   
   # Supports
   supportedScopes[["support"]] <- "support"
   supportedScopes[["support.function"]] <- "support.function"
   supportedScopes[["support.function.dom"]] <- "support.function.dom"
   supportedScopes[["support.function.firebug"]] <- "support.firebug"
   supportedScopes[["support.function.constant"]] <- "support.function.constant"
   supportedScopes[["support.constant"]] <- "support.constant"
   supportedScopes[["support.constant.property-value"]] <- "support.constant.property-value"
   supportedScopes[["support.class"]] <- "support.class"
   supportedScopes[["support.type"]] <- "support.type"
   supportedScopes[["support.other"]] <- "support.other"
   
   # Functions
   supportedScopes[["function"]] <- "function"
   supportedScopes[["function.buildin"]] <- "function.buildin"
   
   # Storages
   supportedScopes[["storage"]] <- "storage"
   supportedScopes[["storage.type"]] <- "storage.type"
   
   # Invalids
   supportedScopes[["invalid"]] <- "invalid"
   supportedScopes[["invalid.illegal"]] <- "invalid.illegal"
   supportedScopes[["invalid.deprecated"]] <- "invalid.deprecated"
   
   # Strings
   supportedScopes[["string"]] <- "string"
   supportedScopes[["string.regexp"]] <- "string.regexp"
   
   # Comments
   supportedScopes[["comment"]] <- "comment"
   supportedScopes[["comment.documentation"]] <- "comment.doc"
   supportedScopes[["comment.documentation.tag"]] <- "comment.doc.tag"
   
   # Variables
   supportedScopes[["variable"]] <- "variable"
   supportedScopes[["variable.language"]] <- "variable.language"
   supportedScopes[["variable.parameter"]] <- "variable.parameter"
   
   # Meta
   supportedScopes[["meta"]] <- "meta"
   supportedScopes[["meta.tag.sgml.doctype"]] <- "xml-pe"
   supportedScopes[["meta.tag"]] <- "meta.tag"
   supportedScopes[["meta.selector"]] <- "meta.selector"
   
   # Entities
   supportedScopes[["entity.other.attribute-name"]] <- "entity.other.attribute-name"
   supportedScopes[["entity.name.function"]] <- "entity.name.function"
   supportedScopes[["entity.name"]] <- "entity.name"
   supportedScopes[["entity.name.tag"]] <- "entity.name.tag"
   
   # Markup
   supportedScopes[["markup.heading"]] <- "markup.heading"
   supportedScopes[["markup.heading.1"]] <- "markup.heading.1"
   supportedScopes[["markup.heading.2"]] <- "markup.heading.2"
   supportedScopes[["markup.heading.3"]] <- "markup.heading.3"
   supportedScopes[["markup.heading.4"]] <- "markup.heading.4"
   supportedScopes[["markup.heading.5"]] <- "markup.heading.5"
   supportedScopes[["markup.heading.6"]] <- "markup.heading.6"
   supportedScopes[["markup.list"]] <- "markup.list"
   
   # Collaborators
   supportedScopes[["collab.user1"]] <- "collab.user1"
   
   # RStudio Supported Scopes
   supportedScopes[["marker-layer.active_debug_line"]] <- "marker-layer .active_debug_line"
   # Read the template files
   conn <- file(
      description = file.path(.Call("rs_rResourcesPath", PACKAGE = "(embedding)"), "templates", "ace_theme_template.css"),
      open = "rt")
   on.exit(close(conn), add = TRUE)
   cssTemplate <- paste0(readLines(conn, encoding = "UTF-8"), collapse ="\n")
   
   # Extract styles
   name <- tmTheme$name
   if (is.null(name)) name <- ""
   styleRes <- .rs.extractStyles(tmTheme, supportedScopes)
   styles <- styleRes$styles
   unsupportedScopes <- styleRes$unsupportedScopes
   
   # Fill template
   styles$cssClass = paste0("ace-", hyphenate(name))
   styles$uuid <- tmTheme$uuid
   css <- fillTemplate(cssTemplate, styles)
   
   for (scope in supportedScopes)
   {
      if (scope %in% names(styles))
      {
         if (grepl("active_debug_line", scope, fixed = TRUE))
         {
            css = paste0(
               css,
               "\n\n.",
               styles$cssClass,
               " ",
               gsub("^|\\.", ".ace_", scope),
               " {\n")
            for (rule in names(styles[[scope]]))
            {
               if (!grepl("^\\s*$", styles[[scope]][[rule]], perl = TRUE))
               {
                  css = paste0(css, "  ", rule, ": ", styles[[scope]][[rule]], ";\n")
               }
            }
            
            css = paste0(
               css,
               "\n  position: absolute;",
               "\n  z-index: -1;",
               "\n}")
         }
         else if (length(styles[[scope]]) > 0)
         {
            css = paste0(
               css,
               "\n\n.",
               styles$cssClass,
               " ",
               gsub("^|\\.", ".ace_", scope),
               " {\n")
            for (rule in names(styles[[scope]]))
            {
               if (!grepl("^\\s*$", styles[[scope]][[rule]], perl = TRUE))
               {
                  css = paste0(css, "  ", rule, ": ", styles[[scope]][[rule]], ";\n")
               }
            }
            
            css = paste0(css, "\n}")
         }
      }
   }
   
   list(
      "theme" = strsplit(gsub("[^\\{\\}]+\\{\\s*\\}", "", css, perl = TRUE), "\n")[[1]],
      "isDark" = as.logical(styles$isDark))
})

# TmTheme XML Parsing functions ====================================================================

# Parses a "key" element from a tmtheme document and raises appropriate error.
#
# @param element     The element to parse.
#
# Returns the text value of the element.
.rs.addFunction("parseKeyElement", function(element) {
   key <- xml2::xml_text(element)
   if (key == "")
   {
      stop("The value of a \"key\" element may not be empty.", call. = FALSE)
   }
   
   key
})

# Parses a "string" element from a tmtheme document and raises appropriate errors.
#
# @param element     The element to parse.
# @param keyName     The name of the key for this value.
#
# Returns the text value of the element.
.rs.addFunction("parseStringElement", function(element, keyName) {
   value <- xml2::xml_text(element)
   
   # The key can only be null if there was no <key> element immediately preceding the <string>
   # element in the provided xml. If any <key> element was found (even a <key/>), the key name
   # will at least be "".
   if (is.null(keyName))
   {
      stop(
         "Unable to find a key for the \"string\" element with value \"",
         value,
         "\".",
         call. = FALSE)
   }
   
   value
})

# Recursively parses a dictionary element from a tmtheme document and raises the correct errors.
#
# @param dictElement    The element to parse.
# @param keyName        The name of the dictionary.
#
# Returns a list with named values.
.rs.addFunction("parseDictElement", function(dictElement, keyName) {
   if (is.null(keyName))
   {
      stop("Unable to find a key for the current \"dict\" element.", call. = FALSE)
   }
   
   values <- list()
   if (xml2::xml_length(dictElement) >= 1)
   {
      key <- NULL
      for (element in xml2::xml_children(dictElement))
      {
         elName <- xml2::xml_name(element)
         if (elName != "comment")
         {
            if (elName == "key")
            {
               if (!is.null(key))
               {
                  stop(
                     "Unable to find a value for the key \"",
                     key,
                     "\".",
                     call. = FALSE)
               }
               key <- .rs.parseKeyElement(element)
            }
            else if (elName == "string")
            {
               # Add the key-value pair to the theme object and reset the key to NULL to avoid erroneously
               # using the same key twice.
               values[[key]] <- .rs.parseStringElement(element, key)
               key <- NULL
            }
            else if (elName == "dict")
            {
               values[[key]] <- .rs.parseDictElement(element, key)
               key <- NULL
            }
            else if (elName == "array")
            {
               values[[key]] <- .rs.parseArrayElement(element, key)
               key <- NULL
            }
            else
            {
               stop(
                  "Encountered unexpected element as a child of the current \"dict\" element: \"",
                  elName,
                  "\". Expected \"key\", \"string\", \"array\", or \"dict\".",
                  call. = FALSE)
            }
         }
      }
      
      if (!is.null(key))
      {
         stop(
            "Unable to find a value for the key \"",
            key,
            "\".",
            call. = FALSE)
      }
   }
   
   values
})

# Recursively parses the list of settings from a tmtheme document.
#
# @param arrayElement      The <array> element to parse.
# @param keyName           The name of the key for this array element.
#
# Returns a list() of named settings.
.rs.addFunction("parseArrayElement", function(arrayElement, keyName) {
   if (xml2::xml_length(arrayElement) < 1)
   {
      stop("\"array\" element cannot be empty.", call. = FALSE)
   }
   
   if (is.null(keyName))
   {
      stop("Unable to find a key for array value.", call. = FALSE)
   }
   if (keyName != "settings")
   {
      stop(
         "Incorrect key for array element. Expected: \"settings\"; Actual: \"",
         keyName,
         "\".",
         call. = FALSE)
   }
   
   values <- list()
   index <- 1
   for (element in xml2::xml_children(arrayElement))
   {
      elName <- xml2::xml_name(element)
      if (elName != "comment")
      {
         if (elName != "dict")
         {
            stop(
               "Expecting \"dict\" element; found \"",
               elName,
               "\".",
               call. = FALSE)
         }
         
         # Intentionally empty key here
         values[[index]] <- .rs.parseDictElement(element, "")
         index <- index + 1
      }
   }
   
   values
})

# Parses a tmtheme document and stores the relevant values in a list with named values.
#
# @param filePath     The path of the file to parse.
# 
# Returns a list with named values.
.rs.addFunction("parseTmTheme", function(filePath) {
   if (!file.exists(filePath))
   {
      stop(
         "The specified file, \"",
         filePath,
         "\", does not exist.",
         call. = FALSE)
   }
   xmlStr <- paste(readLines(filePath, encoding = "UTF-8", warn = FALSE), collapse = "\n")
   
   tmThemeDoc <- xml2::xml_root(xml2::read_xml(
      xmlStr, 
      error = function(msg, code, domain, line, col, level, filename) {
         stop(
            "An error occurred while parsing ",
            filename,
            " at line ",
            line,
            ": ",
            msg,
            call. = FALSE)
      },
      encoding = "UTF-8"))
   
   # Check for the right number of children
   childrenCount <- xml2::xml_length(tmThemeDoc)
   if (childrenCount != 1)
   {
      stop("Expected 1 non-text child of the root, found: ",
           childrenCount,
           call. = FALSE)
   }
   
   # Check the structure at the root is correct before continuing.
   if (xml2::xml_name(xml2::xml_child(tmThemeDoc, 1)) != "dict")
   {
      stop("Expecting \"dict\" element; found \"",
           xml2::xml_name(xml2::xml_child(tmThemeDoc, 1)),
           "\".",
           call. = FALSE)
   }
   if (xml2::xml_length(xml2::xml_child(tmThemeDoc, 1)) < 1)
   {
      stop(
         "\"dict\" element cannot be empty.",
         call. = FALSE)
   }
   
   # Skip the plist (root), first child is a <dict>.
   # Intentionally empty key here
   .rs.parseDictElement(xml2::xml_child(tmThemeDoc, 1), "")
})

# compile-themes Functions =========================================================================

# Converts an ace theme to an RStudio theme.
# 
# @param aceCss      The ace CSS to convert.
# @param name        The name 
.rs.addFunction("convertAceTheme", function(name, aceCss, isDark) {
   rsTheme <- .rs.compile_theme(aceCss, isDark, name = name)
   if (length(rsTheme) == 0)
   {
      stop("Please see above for warnings.",
           .call = FALSE)
   }
   
   c(
      paste0("/* rs-theme-name: ", name, " */"),
      paste0("/* rs-theme-is-dark: ", isDark, " */"),
      rsTheme,
      "\n")
})

# Worker Functions =================================================================================
.rs.addFunction("isGlobalTheme", function(themeUrl)
{
   grepl("^theme/custom/global/.*?\\.rstheme$", themeUrl, ignore.case = TRUE)
})

.rs.addFunction("isLocalTheme", function(themeUrl)
{
   grepl("^theme/custom/local/.*\\.rstheme$", themeUrl, ignore.case = TRUE)
})

.rs.addFunction("isDefaultTheme", function(themeUrl)
{
   grepl("^theme/default/.*\\.rstheme$", themeUrl, ignore.case = TRUE)
})

.rs.addFunction("getThemeName", function(themeLines, fileName)
{
   tmThemeNameRegex <- "<key>name</key>\\s*<string>([^>]*)</string>"
   rsthemeNameRegex <- "rs-theme-name\\s*:\\s*([^\\*]+?)\\s*(?:\\*|$)"
   nameRegex <- tmThemeNameRegex
   nameLine <- themeLines[grep(tmThemeNameRegex, themeLines, perl = TRUE, ignore.case = TRUE)]
   if (length(nameLine) == 0)
   {
      nameRegex <- rsthemeNameRegex
      nameLine <- themeLines[grep(rsthemeNameRegex, themeLines, perl = TRUE, ignore.case = TRUE)]
   }
   if (length(nameLine) == 0)
   {
      regmatches(
         basename(fileName),
         regexec(
            "^([^\\.]*)(?:\\.[^\\.]*)?",
            basename(fileName),
            perl = TRUE))[[1]][2]
   }
   else
   {
      sub(
         "^\\s*(.+?)\\s*$",
         "\\1",
         regmatches(
            nameLine,
            regexec(
               nameRegex,
               nameLine,
               perl = TRUE))[[1]][2],
         perl = TRUE)
   }
})

# Gets the install location.
#
# @param global    Whether to get the global or local install dir.
#
# Returns the install location.
.rs.addFunction("getThemeInstallDir", function(global) 
{
   if (global)
      .Call("rs_getGlobalThemeDir", PACKAGE = "(embedding)")
   else
      .Call("rs_getLocalThemeDir", PACKAGE = "(embedding)")
})

.rs.addFunction("getThemeDirFromUrl", function(url) 
{
   decodedUrl <- URLdecode(url)
   if (.rs.isGlobalTheme(decodedUrl))
   {
      file.path(.rs.getThemeInstallDir(TRUE), basename(decodedUrl))
   }
   else if (.rs.isLocalTheme(decodedUrl))
   {
      .Call("rs_getLocalThemePath", basename(decodedUrl), PACKAGE="(embedding)")
   }
   else
   {
      NULL
   }
})

# Converts a tmtheme file into an rstheme file.
# 
# @param themePath         The tmtheme file to convert.
# @param add               Whether to add the converted custom theme to RStudio.
# @param outputLocation    Where to place a local copy of the converted theme.
# @param apply             Whether to immediately apply the new custom theme.
# @param force             Whether to force the operation when it may involve an overwrite.
# @param globally          Whether to add the theme for all users (true) or just this user (false).
#
# Returns the name of the theme on success.
.rs.addFunction("convertTheme", function(themePath, add, outputLocation, apply, force, globally) {
   tmTheme <- .rs.parseTmTheme(themePath)
   name <- tmTheme$name
   fileName <- paste0(tools::file_path_sans_ext(basename(themePath)), ".rstheme")
   
   
   aceTheme <- .rs.convertTmTheme(tmTheme)
   rsTheme <- .rs.convertAceTheme(name, aceTheme$theme, aceTheme$isDark)
   
   
   isTemp <- is.null(outputLocation)
   location <- if (is.null(outputLocation)) file.path(tempdir(), fileName)
   else file.path(outputLocation, fileName)
   
   if (!file.create(location))
   {
      stop(
         "Unable to create the theme file in the requested location: ",
         location,
         ". Please see above for relevant warnings.",
         call. = FALSE)
   }
   
   cat(paste(rsTheme, collapse="\n"), file = location)
   
   if (add)
   {
      .rs.addTheme(location, apply, force, globally)
   }
   else if (apply)
   {
      stop("Invalid input: unable to apply a theme which has not been added.", call. = FALSE)
   }
   
   name
})

# Adds a custom rstheme to RStudio.
#
# @param themePath   The full or relative path of the rstheme file to add.
# @param apply       Whether to immediately apply the newly added theme.
# @param force       Whether to force the operation when it may involve an overwrite.
# @param globally    Whether to add the theme for all users (true) or for the current user (false).
#
# Returns the name of the theme on success.
.rs.addFunction("addTheme", function(themePath, apply, force, globally) {
   # Get the name of the file without extension.
   fileName <- basename(themePath)
   
   # Get the name of the theme either from the first occurrence of "rs-theme-name:" in the css or 
   # the name of the file.
   themeLines <- readLines(themePath, encoding = "UTF-8", warn = FALSE)
   name <- .rs.getThemeName(paste0(themeLines, collapse = "\n"), fileName)
   
   if (is.na(name) || (name == "") || is.null(name))
   {
      stop(
         "Unable to find a name for the new theme. Please check that the file \"",
         themePath,
         "\" is valid.",
         call. = FALSE)
   }
   
   if (length(themeLines) == 0)
   {
      stop("The theme file is empty.", call. = FALSE);
   }
      
   # Check if a theme with the same name already exists in the current location.
   dupTheme <- .rs.getThemes()[[tolower(name)]]
   if (!is.null(dupTheme) && 
       ((globally && .rs.isGlobalTheme(dupTheme$url)) ||
        (!globally && .rs.isLocalTheme(dupTheme$url))) &&
       !force)
   {
      stop(
         "The specified theme, \"",
         name,
         "\", already exists in the target location. Please delete the existing theme and try again.",
         call. = FALSE)
   }
   else if (!is.null(dupTheme))
   {
      willBeOverridden <- if (!globally || .rs.isDefaultTheme(dupTheme$url)) "The existing theme will be overridden by the new theme."
      else "The newly added theme will be overridden by the existing theme."
      warning("There is another theme with the same name, \"",
              name,
              "\". ",
              willBeOverridden,
              call. = FALSE)
   }
   
   outputDir <- .rs.getThemeInstallDir(globally)
   if (!dir.exists(outputDir))
   {
      if (globally)
      {
         stop(
            "The global installation directory does not exist: \"",
            outputDir,
            "\".",
            call. = FALSE)
      }
      if (!dir.create(outputDir, recursive = TRUE))
      {
         stop(
            "Please check file system permissions.",
            call. = FALSE)
      }
   }
   
   addedTheme <- file.path(outputDir, fileName)
   if (file.exists(addedTheme) && !force)
   {
      stop(
         "A file with the same name, \"",
         fileName,
         "\", already exists in the target location. To add the theme anyway, try again with `force = TRUE`.",
         call. = FALSE)
   }
   
   if (!file.copy(
      themePath,
      addedTheme,
      overwrite = force))
   {
      msg <- "Please check file system permissions"
      if (!force)
      {
         msg <- paste0(msg, " or try again with `force = TRUE`.")
      }
      
      stop(msg, ".", call. = FALSE)
   }
   
   if (apply)
   {
      .rs.applyTheme(name, .rs.getThemes())
   }
   
   name
})

# Applies a theme to RStudio.
#
# @param name     The name of the theme to apply.
.rs.addFunction("applyTheme", function(name, themeList) {
   theme <- themeList[[tolower(name)]]
   if (is.null(theme))
   {
      stop("The specified theme \"", name, "\" does not exist.", call. = FALSE)
   }
   
   themeValue <- list(
      "name"= .rs.scalar(theme$name),
      "isDark" = .rs.scalar(theme$isDark),
      "url" = .rs.scalar(theme$url))

   # Save theme details to user state
   .rs.writeUserState("theme", themeValue)

   # Save theme itself as a user pref
   .rs.writeUserPref("editor_theme", name)
})

# Removes a theme from RStudio. If the removed theme is the current theme, the current theme will be
# set to the default theme.
#
# @param The name of the theme to remove.
.rs.addFunction("removeTheme", function(name, themeList) {
   currentTheme <- .rs.api.getThemeInfo()$editor
   lowerCaseName <- tolower(name)
   
   if (is.null(themeList[[lowerCaseName]]))
   {
      stop("The specified theme \"", name, "\" does not exist.")
   }
   
   if (identical(lowerCaseName, tolower(currentTheme)))
   {
      nextTheme <- if (themeList[[lowerCaseName]]$isDark) "Tomorrow Night" else "TextMate (default)"
      warning("Removing the active theme - setting the current theme to ", nextTheme)
      .rs.applyTheme(nextTheme, themeList)
   }
   
   filePath <- .rs.getThemeDirFromUrl(themeList[[lowerCaseName]]$url)
   
   if (is.null(filePath))
   {
      stop("Please verify that the theme is installed as a custom theme.")
   }
   if (!file.remove(filePath))
   {
      if (file.exists(filePath))
      {
         justFileName <- basename(filePath)
         actualPath <- normalizePath(filePath, mustWork = FALSE, winslash = "/")
         globalPath <- normalizePath(.rs.getThemeInstallDir(TRUE), mustWork = FALSE, winslash = "/")
         if (identical(file.path(globalPath, justFileName), actualPath))
         {
            stop("The specified theme is installed for all users. Please contact your system administrator to remove the theme.")
         }
         else
         {
            stop("Please check your file system permissions.")
         }
      }
   }
})

.rs.addFunction("getThemes", function() {
   themeList <- .Call("rs_getThemes", PACKAGE = "(embedding)")
   for (i in seq_along(themeList))
   {
      Encoding(themeList[[i]]$name) <- "UTF-8"
      Encoding(themeList[[i]]$url) <- "UTF-8"
   }
   themeList
})

# C++ Wrappers =====================================================================================
.rs.addFunction("internal.convertTheme", function(themePath) {
   Encoding(themePath) <- "UTF-8"
   
   warnings <- c()
   tryCatch(
      withCallingHandlers(
         .rs.convertTheme(
            themePath,
            add = TRUE,
            outputLocation = NULL,
            apply = FALSE,
            force = TRUE,
            globally = FALSE),
         warning = function(w) 
         { 
            warnings <<- conditionMessage(w)
            invokeRestart("muffleWarning")
         }),
      error = function(e) 
      { 
         if (length(warnings) > 0)
            e$message <- paste(
               e$message,
               paste0(warnings, collapse = "\n    "),
               sep = "\nAlso, warnings:\n    ")
         e 
      })
})

.rs.addFunction("internal.addTheme", function(themePath) {
   Encoding(themePath) <- "UTF-8"
   
   warnings <- c()
   tryCatch(
      withCallingHandlers(
         .rs.addTheme(themePath, apply = FALSE, force = FALSE, globally = FALSE),
         warning = function(w) 
         { 
            warnings <<- conditionMessage(w)
            invokeRestart("muffleWarning")
         }),
      error = function(e) 
      {
         if (length(warnings) > 0)
            e$message <- paste(
               e$message,
               paste0(warnings, collapse = "\n    "),
               sep = "\nAlso, warnings:\n    ")
         e 
      })
})

.rs.addFunction("internal.removeTheme", function(name, themeList) {
   Encoding(name) <- "UTF-8"
   
   warnings <- c()
   tryCatch(
      withCallingHandlers(
         .rs.removeTheme(name, themeList),
         warning = function(w) 
         { 
            warnings <<- c(warnings, conditionMessage(w))
            invokeRestart("muffleWarning")
         }),
      error = function(e) 
      { 
         if (length(warnings) > 0)
            e$message <- paste(
               e$message,
               paste0(warnings, collapse = "\n    "),
               sep = "\nAlso, warnings:\n    ")
         e 
      })
})

# API Functions ====================================================================================

# Convert a tmtheme to rstheme and optionally add it to RStudio.
.rs.addApiFunction("convertTheme", function(themePath, add = TRUE, outputLocation = NULL, apply = FALSE, force = FALSE, globally = FALSE) {
   # Require XML package for parsing the tmtheme files.
   missingLibraryMsg <- "Taking this action requires the %pkg% library. Please run 'install.packages(\"%pkg%\")' before continuing."
   if (!suppressWarnings(require("xml2", quietly = TRUE)))
   {
      stop(gsub("%pkg%", "xml2", missingLibraryMsg, fixed = TRUE))
   }
   
   tryCatch(
      .rs.convertTheme(themePath, add, outputLocation, apply, force, globally),
      error = function(e) { stop("Unable to convert the tmTheme to an rstheme. ", e$message) })
})

# Add a theme to RStudio.
.rs.addApiFunction("addTheme", function(themePath, apply = FALSE, force = FALSE, globally = FALSE) {
   tryCatch(
      .rs.addTheme(themePath, apply, force, globally),
      error = function(e) 
      {
         stop("Unable to add the theme file \"", themePath, "\". ", e$message)
      })
})

# Apply a theme to RStudio.
.rs.addApiFunction("applyTheme", function(name) {
   tryCatch(
      .rs.applyTheme(name, .rs.getThemes()),
      error = function(e) { stop("Unable to apply the theme \"", name, "\". ", e$message) })
})

# Remove a theme from RStudio.
.rs.addApiFunction("removeTheme", function(name) {
   tryCatch(
      .rs.removeTheme(name, .rs.getThemes()),
      error = function(e) { stop("Unable to remove the theme \"", name, "\". ", e$message) })
})

# Get the list of installed themes.
.rs.addApiFunction("getThemes", function() {
   lapply(.rs.getThemes(), function(theme) {
      theme[names(theme) != "url"]
   })
})

# RPC Functions ====================================================================================
.rs.addJsonRpcHandler("get_theme_name", function(themeFile) {
   Encoding(themeFile) <- "UTF-8"
   lines <- readLines(themeFile, encoding = "UTF-8")
   .rs.scalar(.rs.getThemeName(paste0(lines, collapse = "\n"), themeFile))
})
