[bug#50922] [PATCH 0/2] (guix import stackage) cleanups

[bug#50922] [PATCH 0/2] (guix import stackage) cleanups

[Ludovic Courtès]

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

[bug#50922] [PATCH 1/2] import: stackage: Use 'define-json-mapping'.

[Ludovic Courtès]

* 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@elephly.net>
 ;;; Copyright © 2020 Martin Becze <mjbecze@riseup.net>
 ;;; Copyright © 2021 Xinglu Chem <public@yoctocell.xyz>
+;;; Copyright © 2021 Ludovic Courtès <ludo@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)))
 
 \f
@@ -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

[bug#50922] [PATCH 2/2] import: stackage: Use the standard diagnostic procedures.

[Ludovic Courtès]

* 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

bug#50922: [PATCH 0/2] (guix import stackage) cleanups

[Ludovic Courtès]

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

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

Pushed as b7d8dc5841f9d71c6eac4c2c8faaf7f0b5e7748e!

Ludo’.