[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
bug#26645: [PATCH 6/9] gnu: Add find-package-binding.
From: |
Andy Wingo |
Subject: |
bug#26645: [PATCH 6/9] gnu: Add find-package-binding. |
Date: |
Mon, 24 Apr 2017 22:59:20 +0200 |
* gnu/packages.scm (find-package-binding): New export.
---
gnu/packages.scm | 62 +++++++++++++++++++++++++++++++++++++++++++++++++++++++-
1 file changed, 61 insertions(+), 1 deletion(-)
diff --git a/gnu/packages.scm b/gnu/packages.scm
index 92bab7228..5e85d3dd6 100644
--- a/gnu/packages.scm
+++ b/gnu/packages.scm
@@ -55,7 +55,9 @@
find-newest-available-packages
specification->package
- specification->package+output))
+ specification->package+output
+
+ find-package-binding))
;;; Commentary:
;;;
@@ -368,3 +370,61 @@ version; if SPEC does not specify an output, return
OUTPUT."
(leave (_ "package `~a' lacks output `~a'~%")
(package-full-name package)
sub-drv))))))
+
+(define (find-package-binding package)
+ "Find the module that exports PACKAGE. Return two values, an interface name
+and a symbol that can be used to import PACKAGE. Signal an error if no public
variable binds PACKAGE."
+ (define (strip-extension file exts)
+ (or (or-map (lambda (ext)
+ (and (string-suffix? ext file)
+ (substring file 0 (- (string-length file)
+ (string-length ext)))))
+ exts)
+ file))
+ (define (file-name->module-name file)
+ (and (not (absolute-file-name? file))
+ (map string->symbol
+ (string-split (strip-extension file %load-extensions)
+ #\/))))
+ ;; Instead of building a table and always doing a search, first just see if
+ ;; we can use the package's location to find its module and look in that
+ ;; module.
+ (define (global-search)
+ (let search ((modules (all-package-modules)))
+ (match modules
+ (()
+ (raise (condition
+ (&message (message
+ (format #f (_ "address@hidden: binding not found")
+ (package-name package)
+ (package-version package)))))))
+ ((mod . modules)
+ (let ((next (lambda () (search modules))))
+ (local-search (module-name mod) mod next))))))
+ (define (local-search module-name iface k)
+ (let lp ((bindings (module-map cons iface)))
+ (match bindings
+ (() (k))
+ (((sym . var) . bindings)
+ (if (eq? (variable-ref var) package)
+ (values module-name sym)
+ (lp bindings))))))
+ (cond
+ ((package-location package)
+ => (lambda (loc)
+ (cond
+ ((file-name->module-name (location-file loc))
+ => (lambda (module-name)
+ (cond
+ ((false-if-exception (resolve-interface module-name))
+ => (lambda (iface)
+ (let ((def (string->symbol (package-name package))))
+ (cond
+ ((and (module-variable iface def)
+ (eq? (module-ref iface def) package))
+ (values module-name def))
+ (else
+ (local-search module-name iface global-search))))))
+ (else (global-search)))))
+ (else (global-search)))))
+ (else (global-search))))
--
2.12.2
- bug#26645: guix potluck, Andy Wingo, 2017/04/24
- bug#26645: [PATCH 1/9] guix: Add "potluck" packages., Andy Wingo, 2017/04/24
- bug#26645: [PATCH 4/9] guix: Add "potluck" command., Andy Wingo, 2017/04/24
- bug#26645: [PATCH 9/9] doc: Document guix potluck., Andy Wingo, 2017/04/24
- bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout., Andy Wingo, 2017/04/24
- bug#26645: [PATCH 3/9] guix: Add git utility module., Andy Wingo, 2017/04/24
- bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package., Andy Wingo, 2017/04/24
- bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand., Andy Wingo, 2017/04/24
- bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox., Andy Wingo, 2017/04/24
- bug#26645: [PATCH 6/9] gnu: Add find-package-binding.,
Andy Wingo <=
- bug#26645: guix potluck, ng0, 2017/04/24