GNU bug report logs - #50922
[PATCH 0/2] (guix import stackage) cleanups

Previous Next

To add a comment to this bug, you must first unarchive it, by sending
a message to control AT debbugs.gnu.org, with unarchive 50922 in the body.
You can then email your comments to 50922 AT debbugs.gnu.org in the normal way.

Toggle the display of automated, internal messages from the tracker.

Message #5 received at submit <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: guix-patches <at> gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 0/2] (guix import stackage) cleanups
Date: Thu, 30 Sep 2021 22:54:54 +0200

Hi!

The following changes were prompted by the vision of a ‘list-ref’ call
and that of the whole alist family sitting at the JSON table.

Feedback welcome!

Ludo’.

Ludovic Courtès (2):
  import: stackage: Use 'define-json-mapping'.
  import: stackage: Use the standard diagnostic procedures.

 guix/import/stackage.scm | 96 ++++++++++++++++++++++------------------
 tests/lint.scm           |  6 ++-
 2 files changed, 58 insertions(+), 44 deletions(-)

-- 
2.33.0

Message #8 received at 50922 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 50922 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 2/2] import: stackage: Use the standard diagnostic procedures.
Date: Thu, 30 Sep 2021 23:01:44 +0200

* guix/import/stackage.scm (leave-with-message): Remove.
(stackage-lts-info-fetch): Use 'raise' and 'formatted-message'.
(stackage->guix-package): Likewise.
(latest-lts-release): Use 'warning' instead of 'format'.
---
 guix/import/stackage.scm | 19 ++++++++++---------
 1 file changed, 10 insertions(+), 9 deletions(-)

diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index 4eff09ad01..b4b20ebcf0 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -32,6 +32,8 @@
   #:use-module (guix memoization)
   #:use-module (guix packages)
   #:use-module (guix upstream)
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
   #:export (%stackage-url
             stackage->guix-package
             stackage-recursive-import
@@ -71,9 +73,6 @@
   (version     stackage-package-version)
   (synopsis    stackage-package-synopsis))
 
-(define (leave-with-message fmt . args)
-  (raise (condition (&message (message (apply format #f fmt args))))))
-
 (define stackage-lts-info-fetch
   ;; "Retrieve the information about the LTS Stackage release VERSION."
   (memoize
@@ -84,7 +83,8 @@
                                             version)))
             (lts-info (and=> (json-fetch url) json->stackage-lts)))
        (or lts-info
-           (leave-with-message "LTS release version not found: ~a" version))))))
+           (raise (formatted-message (G_ "LTS release version not found: ~a")
+                                     version)))))))
 
 (define (lts-package-version packages name)
   "Return the version of the package with upstream NAME included in PACKAGES."
@@ -120,7 +120,8 @@ included in the Stackage LTS release."
            (hackage->guix-package name-version
                                   #:include-test-dependencies?
                                   include-test-dependencies?)
-           (leave-with-message "~a: Stackage package not found" package-name))))))
+           (raise (formatted-message (G_ "~a: Stackage package not found")
+                                     package-name)))))))
 
 (define (stackage-recursive-import package-name . args)
   (recursive-import package-name
@@ -145,10 +146,10 @@ PACKAGE or #f if the package is not included in the Stackage LTS release."
              (version (lts-package-version (packages) hackage-name))
              (name-version (hackage-name-version hackage-name version)))
         (match (and=> name-version hackage-fetch)
-          (#f (format (current-error-port)
-                      "warning: failed to parse ~a~%"
-                      (hackage-cabal-url hackage-name))
-              #f)
+          (#f
+           (warning (G_ "failed to parse ~a~%")
+                    (hackage-cabal-url hackage-name))
+           #f)
           (_ (let ((url (hackage-source-url hackage-name version)))
                (upstream-source
                 (package (package-name package))
-- 
2.33.0

Message #11 received at 50922 <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 50922 <at> debbugs.gnu.org
Cc: Ludovic Courtès <ludo <at> gnu.org>
Subject: [PATCH 1/2] import: stackage: Use 'define-json-mapping'.
Date: Thu, 30 Sep 2021 23:01:43 +0200

* guix/import/stackage.scm (<stackage-lts>, <snapshot>)
(<stackage-package>): New record types and JSON mappings.
(lts-info-packages, stackage-package-name)
(stackage-package-version): Remove.
(lts-package-version): Rename 'pkgs-info' to 'packages'; assume
'packages' is a list of <stackage-package>.
(stackage->guix-package): Use 'stackage-lts-packages' instead of
'lts-info-packages'.  Rename 'packages-info' to 'packages'.
(latest-lts-release): Likewise.
(stackage-package?): Rename to...
(stackage-lts-package?): ... this.  Adjust to new API.
(%stackage-updater)[pred]: Update accordingly.
* tests/lint.scm ("haskell-stackage"): Add "snapshot" entry in JSON
snippet.
---
 guix/import/stackage.scm | 79 ++++++++++++++++++++++------------------
 tests/lint.scm           |  6 ++-
 2 files changed, 49 insertions(+), 36 deletions(-)

diff --git a/guix/import/stackage.scm b/guix/import/stackage.scm
index 731e69651e..4eff09ad01 100644
--- a/guix/import/stackage.scm
+++ b/guix/import/stackage.scm
@@ -3,6 +3,7 @@
 ;;; Copyright © 2018 Ricardo Wurmus <rekado <at> elephly.net>
 ;;; Copyright © 2020 Martin Becze <mjbecze <at> riseup.net>
 ;;; Copyright © 2021 Xinglu Chem <public <at> yoctocell.xyz>
+;;; Copyright © 2021 Ludovic Courtès <ludo <at> gnu.org>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -21,13 +22,10 @@
 
 (define-module (guix import stackage)
   #:use-module (ice-9 match)
-  #:use-module (ice-9 regex)
-  #:use-module (ice-9 control)
+  #:use-module (json)
   #:use-module (srfi srfi-1)
-  #:use-module (srfi srfi-26)
   #:use-module (srfi srfi-34)
   #:use-module (srfi srfi-35)
-  #:use-module (srfi srfi-43)
   #:use-module (guix import json)
   #:use-module (guix import hackage)
   #:use-module (guix import utils)
@@ -50,9 +48,28 @@
 ;; Latest LTS version compatible with GHC 8.6.5.
 (define %default-lts-version "14.27")
 
-(define (lts-info-packages lts-info)
-  "Returns the alist of packages contained in LTS-INFO."
-  (or (assoc-ref lts-info "packages") '()))
+(define-json-mapping <stackage-lts> make-stackage-lts
+  stackage-lts?
+  json->stackage-lts
+  (snapshot    stackage-lts-snapshot "snapshot" json->snapshot)
+  (packages    stackage-lts-packages "packages"
+               (lambda (vector)
+                 (map json->stackage-package (vector->list vector)))))
+
+(define-json-mapping <snapshot> make-snapshot
+  stackage-snapshot?
+  json->snapshot
+  (name        snapshot-name)
+  (ghc-version snapshot-ghc-version)
+  (compiler    snapshot-compiler))
+
+(define-json-mapping <stackage-package> make-stackage-package
+  stackage-package?
+  json->stackage-package
+  (origin      stackage-package-origin)
+  (name        stackage-package-name)
+  (version     stackage-package-version)
+  (synopsis    stackage-package-synopsis))
 
 (define (leave-with-message fmt . args)
   (raise (condition (&message (message (apply format #f fmt args))))))
@@ -65,21 +82,14 @@
                                 "/lts-" (if (string-null? version)
                                             %default-lts-version
                                             version)))
-            (lts-info (json-fetch url)))
-       (if lts-info
-           (reverse lts-info)
+            (lts-info (and=> (json-fetch url) json->stackage-lts)))
+       (or lts-info
            (leave-with-message "LTS release version not found: ~a" version))))))
 
-(define (stackage-package-name pkg-info)
-  (assoc-ref pkg-info "name"))
-
-(define (stackage-package-version pkg-info)
-  (assoc-ref pkg-info "version"))
-
-(define (lts-package-version pkgs-info name)
-  "Return the version of the package with upstream NAME included in PKGS-INFO."
+(define (lts-package-version packages name)
+  "Return the version of the package with upstream NAME included in PACKAGES."
   (let ((pkg (find (lambda (pkg) (string=? (stackage-package-name pkg) name))
-                   (vector->list pkgs-info))))
+                   packages)))
     (stackage-package-version pkg)))
 
 
@@ -96,15 +106,15 @@
              #:key
              (include-test-dependencies? #t)
              (lts-version %default-lts-version)
-             (packages-info
-              (lts-info-packages
+             (packages
+              (stackage-lts-packages
                (stackage-lts-info-fetch lts-version))))
      "Fetch Cabal file for PACKAGE-NAME from hackage.haskell.org.  The retrieved
 version corresponds to the version of PACKAGE-NAME specified in the LTS-VERSION
 release at stackage.org.  Return the `package' S-expression corresponding to
 that package, or #f on failure.  PACKAGES-INFO is the alist with the packages
 included in the Stackage LTS release."
-     (let* ((version (lts-package-version packages-info package-name))
+     (let* ((version (lts-package-version packages package-name))
             (name-version (hackage-name-version package-name version)))
        (if name-version
            (hackage->guix-package name-version
@@ -124,14 +134,15 @@ included in the Stackage LTS release."
 ;;;
 
 (define latest-lts-release
-  (let ((pkgs-info
-        (mlambda () (lts-info-packages
-                     (stackage-lts-info-fetch %default-lts-version)))))
+  (let ((packages
+         (mlambda ()
+           (stackage-lts-packages
+            (stackage-lts-info-fetch %default-lts-version)))))
     (lambda* (package)
       "Return an <upstream-source> for the latest Stackage LTS release of
 PACKAGE or #f if the package is not included in the Stackage LTS release."
       (let* ((hackage-name (guix-package->hackage-name package))
-             (version (lts-package-version (pkgs-info) hackage-name))
+             (version (lts-package-version (packages) hackage-name))
              (name-version (hackage-name-version hackage-name version)))
         (match (and=> name-version hackage-fetch)
           (#f (format (current-error-port)
@@ -144,23 +155,21 @@ PACKAGE or #f if the package is not included in the Stackage LTS release."
                 (version version)
                 (urls (list url))))))))))
 
-(define (stackage-package? package)
-  "Whether PACKAGE is available on the default Stackage LTS release."
+(define (stackage-lts-package? package)
+  "Return whether PACKAGE is available on the default Stackage LTS release."
   (and (hackage-package? package)
-       (let ((packages (lts-info-packages
+       (let ((packages (stackage-lts-packages
                         (stackage-lts-info-fetch %default-lts-version)))
              (hackage-name (guix-package->hackage-name package)))
-         (vector-any identity
-                     (vector-map
-                      (lambda (_ metadata)
-                        (string=? (cdr (list-ref metadata 2)) hackage-name))
-                      packages)))))
+         (find (lambda (package)
+                 (string=? (stackage-package-name package) hackage-name))
+               packages))))
 
 (define %stackage-updater
   (upstream-updater
    (name 'stackage)
    (description "Updater for Stackage LTS packages")
-   (pred stackage-package?)
+   (pred stackage-lts-package?)
    (latest latest-lts-release)))
 
 ;;; stackage.scm ends here
diff --git a/tests/lint.scm b/tests/lint.scm
index e96265a55a..699a750eb9 100644
--- a/tests/lint.scm
+++ b/tests/lint.scm
@@ -1319,7 +1319,11 @@
   (let* ((stackage (string-append "{ \"packages\": [{"
                                   "    \"name\":\"pandoc\","
                                   "    \"synopsis\":\"synopsis\","
-                                  "    \"version\":\"1.0\" }]}"))
+                                  "    \"version\":\"1.0\" }],"
+                                  "  \"snapshot\": {"
+                                  "    \"ghc\": \"8.6.5\","
+                                  "    \"name\": \"lts-14.27\""
+                                  "  }}"))
          (packages (map (lambda (version)
                           (dummy-package
                            "ghc-pandoc"
-- 
2.33.0

Message #16 received at 50922-done <at> debbugs.gnu.org (full text, mbox):

From: Ludovic Courtès <ludo <at> gnu.org>
To: 50922-done <at> debbugs.gnu.org
Subject: Re: bug#50922: [PATCH 0/2] (guix import stackage) cleanups
Date: Sat, 02 Oct 2021 17:29:10 +0200

Ludovic Courtès <ludo <at> gnu.org> skribis:

>   import: stackage: Use 'define-json-mapping'.
>   import: stackage: Use the standard diagnostic procedures.

Pushed as b7d8dc5841f9d71c6eac4c2c8faaf7f0b5e7748e!

Ludo’.

Previous Next

GNU bug tracking system
Copyright (C) 1999 Darren O. Benham, 1997,2003 nCipher Corporation Ltd, 1994-97 Ian Jackson.