02/08: gnu-maintenance: Factorize URL prefix predicates.

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 7632f7bc214b798ff3e154c2fac9a856aa9494e3
Author: Ludovic Courtès <address@hidden>
Date:   Wed Nov 30 15:56:55 2016 +0100

    gnu-maintenance: Factorize URL prefix predicates.
    
    * guix/gnu-maintenance.scm (url-prefix-predicate): New procedure.
    (gnome-package?): Rewrite in terms of 'url-prefix-predicate'.
    (kde-package?, xorg-package?): Remove.
    (%kde-updater, %xorg-updater): Use 'url-prefix-predicate'.
---
 guix/gnu-maintenance.scm |   70 +++++++++++++++-------------------------------
 1 file changed, 22 insertions(+), 48 deletions(-)

diff --git a/guix/gnu-maintenance.scm b/guix/gnu-maintenance.scm
index 6c6c072..90ca7a4 100644
--- a/guix/gnu-maintenance.scm
+++ b/guix/gnu-maintenance.scm
@@ -448,21 +448,26 @@ elpa.gnu.org, and all the GNOME packages."
        (not (gnome-package? package))
        (gnu-package? package)))
 
-(define (gnome-package? package)
-  "Return true if PACKAGE is a GNOME package, hosted on gnome.org."
-  (define gnome-uri?
-    (match-lambda
-      ((? string? uri)
-       (string-prefix? "mirror://gnome/" uri))
-      (_
-       #f)))
-
-  (match (package-source package)
-    ((? origin? origin)
-     (match (origin-uri origin)
-       ((? gnome-uri?) #t)
-       (_              #f)))
-    (_ #f)))
+(define (url-prefix-predicate prefix)
+  "Return a predicate that returns true when passed a package where one of its
+source URLs starts with PREFIX."
+  (lambda (package)
+    (define matching-uri?
+      (match-lambda
+        ((? string? uri)
+         (string-prefix? prefix uri))
+        (_
+         #f)))
+
+    (match (package-source package)
+      ((? origin? origin)
+       (match (origin-uri origin)
+         ((? matching-uri?) #t)
+         (_                 #f)))
+      (_ #f))))
+
+(define gnome-package?
+  (url-prefix-predicate "mirror://gnome/"))
 
 (define (latest-gnome-release package)
   "Return the latest release of PACKAGE, the name of a GNOME package."
@@ -504,21 +509,6 @@ elpa.gnu.org, and all the GNOME packages."
                        ;; checksums.
                        #:file->signature (const #f))))
 
-(define (kde-package? package)
-  "Return true if PACKAGE is a KDE package, developed by KDE.org."
-  (define kde-uri?
-    (match-lambda
-      ((? string? uri)
-       (string-prefix? "mirror://kde/" uri))
-      (_
-       #f)))
-
-  (match (package-source package)
-    ((? origin? origin)
-     (match (origin-uri origin)
-      ((? kde-uri?) #t)
-      (_             #f)))
-    (_ #f)))
 
 (define (latest-kde-release package)
   "Return the latest release of PACKAGE, the name of an KDE.org package."
@@ -532,22 +522,6 @@ elpa.gnu.org, and all the GNOME packages."
       (string-append "/kde" (dirname (dirname (uri-path uri))))
       #:file->signature (const #f)))))
 
-(define (xorg-package? package)
-  "Return true if PACKAGE is an X.org package, developed by X.org."
-  (define xorg-uri?
-    (match-lambda
-      ((? string? uri)
-       (string-prefix? "mirror://xorg/" uri))
-      (_
-       #f)))
-
-  (match (package-source package)
-    ((? origin? origin)
-     (match (origin-uri origin)
-       ((? xorg-uri?) #t)
-       (_              #f)))
-    (_ #f)))
-
 (define (latest-xorg-release package)
   "Return the latest release of PACKAGE, the name of an X.org package."
   (let ((uri (string->uri (origin-uri (package-source package)))))
@@ -576,14 +550,14 @@ elpa.gnu.org, and all the GNOME packages."
   (upstream-updater
     (name 'kde)
     (description "Updater for KDE packages")
-    (pred kde-package?)
+    (pred (url-prefix-predicate "mirror://kde/"))
     (latest latest-kde-release)))
 
 (define %xorg-updater
   (upstream-updater
    (name 'xorg)
    (description "Updater for X.org packages")
-   (pred xorg-package?)
+   (pred (url-prefix-predicate "mirror://xorg/"))
    (latest latest-xorg-release)))
 
 ;;; gnu-maintenance.scm ends here