import: stackage: Use 'define-json-mapping'.
* 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.
master
Ludovic Courtès
parent
21aeb62437
commit
46d15af4cb
|
|
@ -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)))
|
||||
|
||||
|
||||
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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"
|
||||
|
|
|
|||
Reference in New Issue