kreyren/guix-kreyren
1
0
Fork 0
Code Issues 1 Pull Requests 1 Releases Activity

Add (guix discovery).

Browse Source 
* 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.
This commit is contained in:
Ludovic Courtès 2017-05-03 23:03:20 +02:00
parent 1dc0a66591
commit cd903ef787
No known key found for this signature in database
GPG Key ID: 090B11993D9AEBB5
5 changed files with 194 additions and 86 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
Makefile.am
View File

@ -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 \

91
gnu/packages.scm
View File

@ -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)))
(fold-module-public-variables (lambda (object result)
(if (and (package? object)
(not (hidden-package? object)))
(proc object result)
result))
init
vlist-null
(all-package-modules))))
(all-modules (%package-module-path))))
(define find-packages-by-name
(let ((packages (delay

2
gnu/tests.scm
View File

@ -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)

131
guix/discovery.scm Normal file
View File

@ -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

52
tests/discovery.scm Normal file
View File

@ -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")