* [bug#50922] [PATCH 1/2] import: stackage: Use 'define-json-mapping'.
2021-09-30 20:54 [bug#50922] [PATCH 0/2] (guix import stackage) cleanups Ludovic Courtès
@ 2021-09-30 21:01 ` Ludovic Courtès
2021-09-30 21:01 ` [bug#50922] [PATCH 2/2] import: stackage: Use the standard diagnostic procedures Ludovic Courtès
2021-10-02 15:29 ` bug#50922: [PATCH 0/2] (guix import stackage) cleanups Ludovic Courtès
1 sibling, 1 reply; 4+ messages in thread
From: Ludovic Courtès @ 2021-09-30 21:01 UTC (permalink / raw)
To: 50922; +Cc: 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
^ permalink raw reply related [flat|nested] 4+ messages in thread