import: stackage: Support recursive importing.

* guix/import/hackage.scm (hackage-name->package-name): Export procedure.
* guix/import/stackage.scm (lts-info-packages-lts-info): Fix match expression.
(stackage-recursive-import): New procedure.
(stackage->guix-package): Memoize results.
* guix/scripts/import/stackage.scm (show-help, %options,
guix-import-stackage): Support recursive importing.
* doc/guix.texi (Invoking guix import): Document option.
This commit is contained in:
Ricardo Wurmus 2018-08-20 17:38:56 +02:00 committed by Ricardo Wurmus
parent b5d1286f2d
commit a3ece51a29
No known key found for this signature in database
GPG Key ID: 197A5888235FACAC
4 changed files with 70 additions and 29 deletions

View File

@ -6699,9 +6699,14 @@ Specific command-line options are:
@itemx -t @itemx -t
Do not include dependencies required only by the test suites. Do not include dependencies required only by the test suites.
@item --lts-version=@var{version} @item --lts-version=@var{version}
@itemx -r @var{version} @itemx -l @var{version}
@var{version} is the desired LTS release version. If omitted the latest @var{version} is the desired LTS release version. If omitted the latest
release is used. release is used.
@item --recursive
@itemx -r
Traverse the dependency graph of the given upstream package recursively
and generate package expressions for all those packages that are not yet
in Guix.
@end table @end table
The command below imports metadata for the @code{HTTP} Haskell package The command below imports metadata for the @code{HTTP} Haskell package

View File

@ -44,6 +44,7 @@
%hackage-updater %hackage-updater
guix-package->hackage-name guix-package->hackage-name
hackage-name->package-name
hackage-fetch hackage-fetch
hackage-source-url hackage-source-url
hackage-cabal-url hackage-cabal-url

View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -25,10 +26,12 @@
#:use-module (srfi srfi-35) #:use-module (srfi srfi-35)
#:use-module (guix import json) #:use-module (guix import json)
#:use-module (guix import hackage) #:use-module (guix import hackage)
#:use-module (guix import utils)
#:use-module (guix memoization) #:use-module (guix memoization)
#:use-module (guix packages) #:use-module (guix packages)
#:use-module (guix upstream) #:use-module (guix upstream)
#:export (stackage->guix-package #:export (stackage->guix-package
stackage-recursive-import
%stackage-updater)) %stackage-updater))
@ -45,9 +48,9 @@
(_ #f))) (_ #f)))
(define (lts-info-packages lts-info) (define (lts-info-packages lts-info)
"Retruns the alist of packages contained in LTS-INFO." "Returns the alist of packages contained in LTS-INFO."
(match lts-info (match lts-info
((_ ("packages" pkg ...)) pkg) ((("packages" pkg ...) . _) pkg)
(_ '()))) (_ '())))
(define (leave-with-message fmt . args) (define (leave-with-message fmt . args)
@ -85,7 +88,9 @@
(define (hackage-name-version name version) (define (hackage-name-version name version)
(and version (string-append name "@" version))) (and version (string-append name "@" version)))
(define* (stackage->guix-package package-name ; upstream name (define stackage->guix-package
(memoize
(lambda* (package-name ; upstream name
#:key #:key
(include-test-dependencies? #t) (include-test-dependencies? #t)
(lts-version "") (lts-version "")
@ -103,7 +108,13 @@ included in the Stackage LTS release."
(hackage->guix-package name-version (hackage->guix-package name-version
#:include-test-dependencies? #:include-test-dependencies?
include-test-dependencies?) include-test-dependencies?)
(leave-with-message "~a: Stackage package not found" package-name)))) (leave-with-message "~a: Stackage package not found" package-name))))))
(define (stackage-recursive-import package-name . args)
(recursive-import package-name #f
#:repo->guix-package (lambda (name repo)
(apply stackage->guix-package (cons name args)))
#:guix-name hackage-name->package-name))
;;; ;;;

View File

@ -1,5 +1,6 @@
;;; GNU Guix --- Functional package management for GNU ;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch> ;;; Copyright © 2017 Federico Beffa <beffa@fbengineering.ch>
;;; Copyright © 2018 Ricardo Wurmus <rekado@elephly.net>
;;; ;;;
;;; This file is part of GNU Guix. ;;; This file is part of GNU Guix.
;;; ;;;
@ -26,6 +27,7 @@
#:use-module (srfi srfi-1) #:use-module (srfi srfi-1)
#:use-module (srfi srfi-11) #:use-module (srfi srfi-11)
#:use-module (srfi srfi-37) #:use-module (srfi srfi-37)
#:use-module (srfi srfi-41)
#:use-module (ice-9 match) #:use-module (ice-9 match)
#:use-module (ice-9 format) #:use-module (ice-9 format)
#:export (guix-import-stackage)) #:export (guix-import-stackage))
@ -43,11 +45,13 @@
(display (G_ "Usage: guix import stackage PACKAGE-NAME (display (G_ "Usage: guix import stackage PACKAGE-NAME
Import and convert the LTS Stackage package for PACKAGE-NAME.\n")) Import and convert the LTS Stackage package for PACKAGE-NAME.\n"))
(display (G_ " (display (G_ "
-r VERSION, --lts-version=VERSION -l VERSION, --lts-version=VERSION
specify the LTS version to use")) specify the LTS version to use"))
(display (G_ " (display (G_ "
-h, --help display this help and exit")) -h, --help display this help and exit"))
(display (G_ " (display (G_ "
-r, --recursive import packages recursively"))
(display (G_ "
-t, --no-test-dependencies don't include test-only dependencies")) -t, --no-test-dependencies don't include test-only dependencies"))
(display (G_ " (display (G_ "
-V, --version display version information and exit")) -V, --version display version information and exit"))
@ -68,11 +72,14 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n"))
(alist-cons 'include-test-dependencies? #f (alist-cons 'include-test-dependencies? #f
(alist-delete 'include-test-dependencies? (alist-delete 'include-test-dependencies?
result)))) result))))
(option '(#\r "lts-version") #t #f (option '(#\l "lts-version") #t #f
(lambda (opt name arg result) (lambda (opt name arg result)
(alist-cons 'lts-version arg (alist-cons 'lts-version arg
(alist-delete 'lts-version (alist-delete 'lts-version
result)))) result))))
(option '(#\r "recursive") #f #f
(lambda (opt name arg result)
(alist-cons 'recursive #t result)))
%standard-import-options)) %standard-import-options))
@ -90,6 +97,27 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n"))
(alist-cons 'argument arg result)) (alist-cons 'argument arg result))
%default-options)) %default-options))
(define (run-importer package-name opts error-fn)
(let* ((arguments (list
package-name
#:include-test-dependencies?
(assoc-ref opts 'include-test-dependencies?)
#:lts-version (assoc-ref opts 'lts-version)))
(sexp (if (assoc-ref opts 'recursive)
;; Recursive import
(map (match-lambda
((and ('package ('name name) . rest) pkg)
`(define-public ,(string->symbol name)
,pkg))
(_ #f))
(reverse
(stream->list
(apply stackage-recursive-import arguments))))
;; Single import
(apply stackage->guix-package arguments))))
(unless sexp (error-fn))
sexp))
(let* ((opts (parse-options)) (let* ((opts (parse-options))
(args (filter-map (match-lambda (args (filter-map (match-lambda
(('argument . value) (('argument . value)
@ -99,15 +127,11 @@ Import and convert the LTS Stackage package for PACKAGE-NAME.\n"))
(match args (match args
((package-name) ((package-name)
(with-error-handling (with-error-handling
(let ((sexp (stackage->guix-package (run-importer package-name opts
package-name (lambda ()
#:include-test-dependencies? (leave (G_ "failed to download cabal file \
(assoc-ref opts 'include-test-dependencies?) for package '~a'~%")
#:lts-version (assoc-ref opts 'lts-version)))) package-name)))))
(unless sexp
(leave (G_ "failed to download cabal file for package '~a'~%")
package-name))
sexp)))
(() (()
(leave (G_ "too few arguments~%"))) (leave (G_ "too few arguments~%")))
((many ...) ((many ...)