From: ludo@gnu.org (Ludovic Courtès)
To: Andy Wingo <wingo@igalia.com>
Cc: 26645@debbugs.gnu.org
Subject: bug#26645: [PATCH 6/9] gnu: Add find-package-binding.
Date: Thu, 04 May 2017 22:29:58 +0200 [thread overview]
Message-ID: <87lgqc9xh5.fsf@gnu.org> (raw)
In-Reply-To: <20170424205923.27726-6-wingo@igalia.com> (Andy Wingo's message of "Mon, 24 Apr 2017 22:59:20 +0200")
Andy Wingo <wingo@igalia.com> skribis:
> * gnu/packages.scm (find-package-binding): New export.
[...]
> +(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))))
I think it would be enough to assume that (package-location package) is
always valid (which is the case by default), and bail out if it’s not.
WDYT?
Otherwise LGTM, thanks!
Ludo’.
next prev parent reply other threads:[~2017-05-04 20:31 UTC|newest]
Thread overview: 24+ messages / expand[flat|nested] mbox.gz Atom feed top
2017-04-24 20:53 bug#26645: guix potluck Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 2/9] guix hash: Add --git option to hash a git checkout Andy Wingo
2017-04-24 20:59 ` bug#26645: [PATCH 3/9] guix: Add git utility module Andy Wingo
2017-05-03 20:23 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 4/9] guix: Add "potluck" command Andy Wingo
2017-05-04 20:23 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 5/9] potluck: Add ability to load potluck package in sandbox Andy Wingo
2017-05-04 20:27 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 6/9] gnu: Add find-package-binding Andy Wingo
2017-05-04 20:29 ` Ludovic Courtès [this message]
2017-04-24 20:59 ` bug#26645: [PATCH 7/9] potluck: Add ability to lower potluck package to guix package Andy Wingo
2017-05-04 20:31 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 8/9] potluck: Add host-channel subcommand Andy Wingo
2017-05-04 20:55 ` Ludovic Courtès
2017-04-24 20:59 ` bug#26645: [PATCH 9/9] doc: Document guix potluck Andy Wingo
2017-05-04 20:56 ` Ludovic Courtès
2017-05-03 20:19 ` bug#26645: [PATCH 1/9] guix: Add "potluck" packages Ludovic Courtès
2017-05-03 21:55 ` Ludovic Courtès
2017-04-24 21:09 ` bug#26645: guix potluck ng0
2020-03-18 20:03 ` [bug#26645] Potluck still relivant Jack Hill
2020-04-01 16:11 ` Brice Waegeneire
2020-04-29 6:02 ` Ricardo Wurmus
2023-07-21 16:57 ` bug#26645: guix potluck Maxim Cournoyer
Reply instructions:
You may reply publicly to this message via plain-text email
using any one of the following methods:
* Save the following mbox file, import it into your mail client,
and reply-to-all from there: mbox
Avoid top-posting and favor interleaved quoting:
https://en.wikipedia.org/wiki/Posting_style#Interleaved_style
List information: https://guix.gnu.org/
* Reply using the --to, --cc, and --in-reply-to
switches of git-send-email(1):
git send-email \
--in-reply-to=87lgqc9xh5.fsf@gnu.org \
--to=ludo@gnu.org \
--cc=26645@debbugs.gnu.org \
--cc=wingo@igalia.com \
/path/to/YOUR_REPLY
https://kernel.org/pub/software/scm/git/docs/git-send-email.html
* If your mail client supports setting the In-Reply-To header
via mailto: links, try the mailto: link
Be sure your reply has a Subject: header at the top and a blank line
before the message body.
Code repositories for project(s) associated with this public inbox
https://git.savannah.gnu.org/cgit/guix.git
This is a public inbox, see mirroring instructions
for how to clone and mirror all data and code used for this inbox;
as well as URLs for read-only IMAP folder(s) and NNTP newsgroup(s).