Add (guix discovery).
* guix/discovery.scm, tests/discovery.scm: New files. * gnu/packages.scm (scheme-files, file-name->module-name) (scheme-modules, all-package-modules): Remove. (fold-packages): Rewrite in terms of 'fold-module-public-variables'. * gnu/tests.scm: Use (guix discovery). * Makefile.am (MODULES): Add guix/discovery.scm. (SCM_TESTS): Add tests/discovery.scm.master
Ludovic Courtès
parent
1dc0a66591
commit
cd903ef787
|
|
@ -50,6 +50,7 @@ MODULES = \
|
|||
guix/sets.scm \
|
||||
guix/modules.scm \
|
||||
guix/download.scm \
|
||||
guix/discovery.scm \
|
||||
guix/git-download.scm \
|
||||
guix/hg-download.scm \
|
||||
guix/monads.scm \
|
||||
|
|
@ -279,6 +280,7 @@ SCM_TESTS = \
|
|||
tests/records.scm \
|
||||
tests/upstream.scm \
|
||||
tests/combinators.scm \
|
||||
tests/discovery.scm \
|
||||
tests/utils.scm \
|
||||
tests/build-utils.scm \
|
||||
tests/packages.scm \
|
||||
|
|
|
|||
|
|
@ -24,12 +24,11 @@
|
|||
#:use-module (guix packages)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix utils)
|
||||
#:use-module (guix discovery)
|
||||
#:use-module (guix memoization)
|
||||
#:use-module (guix combinators)
|
||||
#:use-module ((guix build utils)
|
||||
#:select ((package-name->name+version
|
||||
. hyphen-separated-name->name+version)))
|
||||
#:use-module (ice-9 ftw)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (srfi srfi-1)
|
||||
|
|
@ -48,7 +47,6 @@
|
|||
%package-module-path
|
||||
|
||||
fold-packages
|
||||
scheme-modules ;XXX: for lack of a better place
|
||||
|
||||
find-packages-by-name
|
||||
find-best-packages-by-name
|
||||
|
|
@ -140,92 +138,17 @@ for system '~a'")
|
|||
directory))
|
||||
%load-path)))
|
||||
|
||||
(define* (scheme-files directory)
|
||||
"Return the list of Scheme files found under DIRECTORY, recursively. The
|
||||
returned list is sorted in alphabetical order."
|
||||
|
||||
;; Sort entries so that 'fold-packages' works in a deterministic fashion
|
||||
;; regardless of details of the underlying file system.
|
||||
(sort (file-system-fold (const #t) ; enter?
|
||||
(lambda (path stat result) ; leaf
|
||||
(if (string-suffix? ".scm" path)
|
||||
(cons path result)
|
||||
result))
|
||||
(lambda (path stat result) ; down
|
||||
result)
|
||||
(lambda (path stat result) ; up
|
||||
result)
|
||||
(const #f) ; skip
|
||||
(lambda (path stat errno result)
|
||||
(warning (G_ "cannot access `~a': ~a~%")
|
||||
path (strerror errno))
|
||||
result)
|
||||
'()
|
||||
directory
|
||||
stat)
|
||||
string<?))
|
||||
|
||||
(define file-name->module-name
|
||||
(let ((not-slash (char-set-complement (char-set #\/))))
|
||||
(lambda (file)
|
||||
"Return the module name (a list of symbols) corresponding to FILE."
|
||||
(map string->symbol
|
||||
(string-tokenize (string-drop-right file 4) not-slash)))))
|
||||
|
||||
(define* (scheme-modules directory #:optional sub-directory)
|
||||
"Return the list of Scheme modules available under DIRECTORY.
|
||||
Optionally, narrow the search to SUB-DIRECTORY."
|
||||
(define prefix-len
|
||||
(string-length directory))
|
||||
|
||||
(filter-map (lambda (file)
|
||||
(let* ((file (substring file prefix-len))
|
||||
(module (file-name->module-name file)))
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(resolve-interface module))
|
||||
(lambda args
|
||||
;; Report the error, but keep going.
|
||||
(warn-about-load-error module args)
|
||||
#f))))
|
||||
(scheme-files (if sub-directory
|
||||
(string-append directory "/" sub-directory)
|
||||
directory))))
|
||||
|
||||
(define* (all-package-modules #:optional (path (%package-module-path)))
|
||||
"Return the list of package modules found in PATH, a list of directories to
|
||||
search."
|
||||
(fold-right (lambda (spec result)
|
||||
(match spec
|
||||
((? string? directory)
|
||||
(append (scheme-modules directory) result))
|
||||
((directory . sub-directory)
|
||||
(append (scheme-modules directory sub-directory)
|
||||
result))))
|
||||
'()
|
||||
path))
|
||||
|
||||
(define (fold-packages proc init)
|
||||
"Call (PROC PACKAGE RESULT) for each available package, using INIT as
|
||||
the initial value of RESULT. It is guaranteed to never traverse the
|
||||
same package twice."
|
||||
(identity ; discard second return value
|
||||
(fold2 (lambda (module result seen)
|
||||
(fold2 (lambda (var result seen)
|
||||
(if (and (package? var)
|
||||
(not (vhash-assq var seen))
|
||||
(not (hidden-package? var)))
|
||||
(values (proc var result)
|
||||
(vhash-consq var #t seen))
|
||||
(values result seen)))
|
||||
result
|
||||
seen
|
||||
(module-map (lambda (sym var)
|
||||
(false-if-exception (variable-ref var)))
|
||||
module)))
|
||||
init
|
||||
vlist-null
|
||||
(all-package-modules))))
|
||||
(fold-module-public-variables (lambda (object result)
|
||||
(if (and (package? object)
|
||||
(not (hidden-package? object)))
|
||||
(proc object result)
|
||||
result))
|
||||
init
|
||||
(all-modules (%package-module-path))))
|
||||
|
||||
(define find-packages-by-name
|
||||
(let ((packages (delay
|
||||
|
|
|
|||
|
|
@ -27,7 +27,7 @@
|
|||
#:use-module (gnu services)
|
||||
#:use-module (gnu services base)
|
||||
#:use-module (gnu services shepherd)
|
||||
#:use-module ((gnu packages) #:select (scheme-modules))
|
||||
#:use-module ((guix discovery) #:select (scheme-modules))
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (srfi srfi-9 gnu)
|
||||
#:use-module (ice-9 match)
|
||||
|
|
|
|||
|
|
@ -0,0 +1,131 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (guix discovery)
|
||||
#:use-module (guix ui)
|
||||
#:use-module (guix combinators)
|
||||
#:use-module (srfi srfi-1)
|
||||
#:use-module (ice-9 match)
|
||||
#:use-module (ice-9 vlist)
|
||||
#:use-module (ice-9 ftw)
|
||||
#:export (scheme-modules
|
||||
fold-modules
|
||||
all-modules
|
||||
fold-module-public-variables))
|
||||
|
||||
;;; Commentary:
|
||||
;;;
|
||||
;;; This module provides tools to discover Guile modules and the variables
|
||||
;;; they export.
|
||||
;;;
|
||||
;;; Code:
|
||||
|
||||
(define* (scheme-files directory)
|
||||
"Return the list of Scheme files found under DIRECTORY, recursively. The
|
||||
returned list is sorted in alphabetical order."
|
||||
|
||||
;; Sort entries so that 'fold-packages' works in a deterministic fashion
|
||||
;; regardless of details of the underlying file system.
|
||||
(sort (file-system-fold (const #t) ;enter?
|
||||
(lambda (path stat result) ;leaf
|
||||
(if (string-suffix? ".scm" path)
|
||||
(cons path result)
|
||||
result))
|
||||
(lambda (path stat result) ;down
|
||||
result)
|
||||
(lambda (path stat result) ;up
|
||||
result)
|
||||
(const #f) ;skip
|
||||
(lambda (path stat errno result)
|
||||
(unless (= ENOENT errno)
|
||||
(warning (G_ "cannot access `~a': ~a~%")
|
||||
path (strerror errno)))
|
||||
result)
|
||||
'()
|
||||
directory
|
||||
stat)
|
||||
string<?))
|
||||
|
||||
(define file-name->module-name
|
||||
(let ((not-slash (char-set-complement (char-set #\/))))
|
||||
(lambda (file)
|
||||
"Return the module name (a list of symbols) corresponding to FILE."
|
||||
(map string->symbol
|
||||
(string-tokenize (string-drop-right file 4) not-slash)))))
|
||||
|
||||
(define* (scheme-modules directory #:optional sub-directory)
|
||||
"Return the list of Scheme modules available under DIRECTORY.
|
||||
Optionally, narrow the search to SUB-DIRECTORY."
|
||||
(define prefix-len
|
||||
(string-length directory))
|
||||
|
||||
(filter-map (lambda (file)
|
||||
(let* ((file (substring file prefix-len))
|
||||
(module (file-name->module-name file)))
|
||||
(catch #t
|
||||
(lambda ()
|
||||
(resolve-interface module))
|
||||
(lambda args
|
||||
;; Report the error, but keep going.
|
||||
(warn-about-load-error module args)
|
||||
#f))))
|
||||
(scheme-files (if sub-directory
|
||||
(string-append directory "/" sub-directory)
|
||||
directory))))
|
||||
|
||||
(define (fold-modules proc init path)
|
||||
"Fold over all the Scheme modules present in PATH, a list of directories.
|
||||
Call (PROC MODULE RESULT) for each module that is found."
|
||||
(fold (lambda (spec result)
|
||||
(match spec
|
||||
((? string? directory)
|
||||
(fold proc result (scheme-modules directory)))
|
||||
((directory . sub-directory)
|
||||
(fold proc result
|
||||
(scheme-modules directory sub-directory)))))
|
||||
'()
|
||||
path))
|
||||
|
||||
(define (all-modules path)
|
||||
"Return the list of package modules found in PATH, a list of directories to
|
||||
search. Entries in PATH can be directory names (strings) or (DIRECTORY
|
||||
. SUB-DIRECTORY) pairs, in which case modules are searched for beneath
|
||||
SUB-DIRECTORY."
|
||||
(fold-modules cons '() path))
|
||||
|
||||
(define (fold-module-public-variables proc init modules)
|
||||
"Call (PROC OBJECT RESULT) for each variable exported by one of MODULES,
|
||||
using INIT as the initial value of RESULT. It is guaranteed to never traverse
|
||||
the same object twice."
|
||||
(identity ; discard second return value
|
||||
(fold2 (lambda (module result seen)
|
||||
(fold2 (lambda (var result seen)
|
||||
(if (not (vhash-assq var seen))
|
||||
(values (proc var result)
|
||||
(vhash-consq var #t seen))
|
||||
(values result seen)))
|
||||
result
|
||||
seen
|
||||
(module-map (lambda (sym var)
|
||||
(false-if-exception (variable-ref var)))
|
||||
module)))
|
||||
init
|
||||
vlist-null
|
||||
modules)))
|
||||
|
||||
;;; discovery.scm ends here
|
||||
|
|
@ -0,0 +1,52 @@
|
|||
;;; GNU Guix --- Functional package management for GNU
|
||||
;;; Copyright © 2017 Ludovic Courtès <ludo@gnu.org>
|
||||
;;;
|
||||
;;; This file is part of GNU Guix.
|
||||
;;;
|
||||
;;; GNU Guix is free software; you can redistribute it and/or modify it
|
||||
;;; under the terms of the GNU General Public License as published by
|
||||
;;; the Free Software Foundation; either version 3 of the License, or (at
|
||||
;;; your option) any later version.
|
||||
;;;
|
||||
;;; GNU Guix is distributed in the hope that it will be useful, but
|
||||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||||
;;; GNU General Public License for more details.
|
||||
;;;
|
||||
;;; You should have received a copy of the GNU General Public License
|
||||
;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
|
||||
|
||||
(define-module (test-discovery)
|
||||
#:use-module (guix discovery)
|
||||
#:use-module (guix build-system)
|
||||
#:use-module (srfi srfi-64)
|
||||
#:use-module (ice-9 match))
|
||||
|
||||
(define %top-srcdir
|
||||
(dirname (search-path %load-path "guix.scm")))
|
||||
|
||||
(test-begin "discovery")
|
||||
|
||||
(test-assert "scheme-modules"
|
||||
(match (map module-name (scheme-modules %top-srcdir "guix/import"))
|
||||
((('guix 'import _ ...) ..1)
|
||||
#t)))
|
||||
|
||||
(test-assert "all-modules"
|
||||
(match (map module-name
|
||||
(all-modules `((,%top-srcdir . "guix/build-system"))))
|
||||
((('guix 'build-system names) ..1)
|
||||
names)))
|
||||
|
||||
(test-assert "fold-module-public-variables"
|
||||
(let ((modules (all-modules `((,%top-srcdir . "guix/build-system")))))
|
||||
(match (fold-module-public-variables (lambda (obj result)
|
||||
(if (build-system? obj)
|
||||
(cons obj result)
|
||||
result))
|
||||
'()
|
||||
modules)
|
||||
(((? build-system? bs) ..1)
|
||||
bs))))
|
||||
|
||||
(test-end "discovery")
|
||||
Loading…
Reference in New Issue