From mboxrd@z Thu Jan 1 00:00:00 1970 Received: from eggs.gnu.org ([2001:4830:134:3::10]:52270) by lists.gnu.org with esmtp (Exim 4.71) (envelope-from ) id 1d2lQr-0008Ay-TL for guix-patches@gnu.org; Mon, 24 Apr 2017 17:22:07 -0400 Received: from Debian-exim by eggs.gnu.org with spam-scanned (Exim 4.71) (envelope-from ) id 1d2lQo-0003Ce-Hw for guix-patches@gnu.org; Mon, 24 Apr 2017 17:22:05 -0400 Received: from debbugs.gnu.org ([208.118.235.43]:40391) by eggs.gnu.org with esmtps (TLS1.0:RSA_AES_128_CBC_SHA1:16) (Exim 4.71) (envelope-from ) id 1d2lQo-0003CW-Bf for guix-patches@gnu.org; Mon, 24 Apr 2017 17:22:02 -0400 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1d2lQo-0005Bq-79 for guix-patches@gnu.org; Mon, 24 Apr 2017 17:22:02 -0400 Subject: bug#26645: [PATCH 6/9] gnu: Add find-package-binding. Resent-Message-ID: From: Andy Wingo Date: Mon, 24 Apr 2017 22:59:20 +0200 Message-Id: <20170424205923.27726-6-wingo@igalia.com> In-Reply-To: <20170424205923.27726-1-wingo@igalia.com> References: <20170424205923.27726-1-wingo@igalia.com> List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+kyle=kyleam.com@gnu.org Sender: "Guix-patches" To: 26645@debbugs.gnu.org * 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 (_ "~a@~a: 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