02/04: packages: Add 'package-upstream-name*'.

[guix-commits]

civodul pushed a commit to branch master
in repository guix.

commit 052faadde70c44043d0db73bd254f664e1905ceb
Author: Lars-Dominik Braun <lars@6xq.net>
AuthorDate: Fri Dec 9 11:46:37 2022 +0100

    packages: Add 'package-upstream-name*'.
    
    * guix/packages.scm (package-upstream-name*): New procedure.
    * tests/packages.scm ("package-upstream-name*"): New test.
    
    Signed-off-by: Ludovic Courtès <ludo@gnu.org>
---
 guix/packages.scm  | 33 +++++++++++++++++++++++++++++++++
 tests/packages.scm |  4 ++++
 2 files changed, 37 insertions(+)

diff --git a/guix/packages.scm b/guix/packages.scm
index 8f119d9fa7..6e61e16aa4 100644
--- a/guix/packages.scm
+++ b/guix/packages.scm
@@ -89,6 +89,7 @@
             this-package
             package-name
             package-upstream-name
+            package-upstream-name*
             package-version
             package-full-name
             package-source
@@ -691,6 +692,38 @@ it has in Guix."
   (or (assq-ref (package-properties package) 'upstream-name)
       (package-name package)))
 
+(define (package-upstream-name* package)
+  "Return the upstream name of PACKAGE, accounting for commonly-used
+package name prefixes in addition to the @code{upstream-name} property."
+  (let ((namespaces (list "cl-"
+                          "ecl-"
+                          "emacs-"
+                          "ghc-"
+                          "go-"
+                          "guile-"
+                          "java-"
+                          "julia-"
+                          "lua-"
+                          "minetest-"
+                          "node-"
+                          "ocaml-"
+                          "perl-"
+                          "python-"
+                          "r-"
+                          "ruby-"
+                          "rust-"
+                          "sbcl-"
+                          "texlive-"))
+        (name (package-name package)))
+    (or (assq-ref (package-properties package) 'upstream-name)
+        (let loop ((prefixes namespaces))
+          (match prefixes
+            (() name)
+            ((prefix rest ...)
+              (if (string-prefix? prefix name)
+                (substring name (string-length prefix))
+                (loop rest))))))))
+
 (define (hidden-package p)
   "Return a \"hidden\" version of P--i.e., one that 'fold-packages' and thus,
 user interfaces, ignores."
diff --git a/tests/packages.scm b/tests/packages.scm
index a5819d8de3..f58c47817b 100644
--- a/tests/packages.scm
+++ b/tests/packages.scm
@@ -626,6 +626,10 @@
     (build-derivations %store (list drv))
     (call-with-input-file output get-string-all)))
 
+(test-equal "package-upstream-name*"
+  (package-upstream-name* (specification->package "guile-gcrypt"))
+  "gcrypt")
+
 
 ;;;
 ;;; Source derivation with snippets.