03/04: Add (guix modules).

[Ludovic Courtès]

civodul pushed a commit to branch master
in repository guix.

commit 7ca87354db53fd1e1a7a3dfeddb9a598ea064bbe
Author: Ludovic Courtès <address@hidden>
Date:   Sun Sep 4 23:41:53 2016 +0200

    Add (guix modules).
    
    * guix/modules.scm, tests/modules.scm: New files.
    * Makefile.am (MODULES, SCM_TESTS): Add them.
    * doc/guix.texi (G-Expressions): Add an example of
    'source-module-closure'.
---
 Makefile.am       |    2 +
 doc/guix.texi     |   22 ++++++++
 guix/modules.scm  |  155 +++++++++++++++++++++++++++++++++++++++++++++++++++++
 tests/modules.scm |   45 ++++++++++++++++
 4 files changed, 224 insertions(+)

diff --git a/Makefile.am b/Makefile.am
index 165dfe9..1a34e0d 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -41,6 +41,7 @@ MODULES =                                     \
   guix/combinators.scm                         \
   guix/utils.scm                               \
   guix/sets.scm                                        \
+  guix/modules.scm                             \
   guix/download.scm                            \
   guix/git-download.scm                                \
   guix/hg-download.scm                         \
@@ -222,6 +223,7 @@ SCM_TESTS =                                 \
   tests/pk-crypto.scm                          \
   tests/pki.scm                                        \
   tests/sets.scm                               \
+  tests/modules.scm                            \
   tests/gnu-maintenance.scm                    \
   tests/substitute.scm                         \
   tests/builders.scm                           \
diff --git a/doc/guix.texi b/doc/guix.texi
index d6c0418..b6ca34a 100644
--- a/doc/guix.texi
+++ b/doc/guix.texi
@@ -3825,6 +3825,28 @@ In this example, the @code{(guix build utils)} module is 
automatically
 pulled into the isolated build environment of our gexp, such that
 @code{(use-modules (guix build utils))} works as expected.
 
address@hidden module closure
address@hidden source-module-closure
+Usually you want the @emph{closure} of the module to be imported---i.e.,
+the module itself and all the modules it depends on---rather than just
+the module; failing to do that, attempts to use the module will fail
+because of missing dependent modules.  The @code{source-module-closure}
+procedure computes the closure of a module by looking at its source file
+headers, which comes in handy in this case:
+
address@hidden
+(use-modules (guix modules))   ;for 'source-module-closure'
+
+(with-imported-modules (source-module-closure
+                         '((guix build utils)
+                           (gnu build vm)))
+  (gexp->derivation "something-with-vms"
+                    #~(begin
+                        (use-modules (guix build utils)
+                                     (gnu build vm))
+                        @dots{})))
address@hidden example
+
 The syntactic form to construct gexps is summarized below.
 
 @deffn {Scheme Syntax} address@hidden
diff --git a/guix/modules.scm b/guix/modules.scm
new file mode 100644
index 0000000..24f613f
--- /dev/null
+++ b/guix/modules.scm
@@ -0,0 +1,155 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; 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 modules)
+  #:use-module ((guix utils) #:select (memoize))
+  #:use-module (guix sets)
+  #:use-module (srfi srfi-26)
+  #:use-module (ice-9 match)
+  #:export (source-module-closure
+            live-module-closure
+            guix-module-name?))
+
+;;; Commentary:
+;;;
+;;; This module provides introspection tools for Guile modules at the source
+;;; level.  Namely, it allows you to determine the closure of a module; it
+;;; does so just by reading the 'define-module' clause of the module and its
+;;; dependencies.  This is primarily useful as an argument to
+;;; 'with-imported-modules'.
+;;;
+;;; Code:
+
+(define (colon-symbol? obj)
+  "Return true if OBJ is a symbol that starts with a colon."
+  (and (symbol? obj)
+       (string-prefix? ":" (symbol->string obj))))
+
+(define (colon-symbol->keyword symbol)
+  "Convert SYMBOL to a keyword after stripping its initial ':'."
+  (symbol->keyword
+   (string->symbol (string-drop (symbol->string symbol) 1))))
+
+(define (extract-dependencies clauses)
+  "Return the list of modules imported according to the given 'define-module'
+CLAUSES."
+  (let loop ((clauses clauses)
+             (result  '()))
+    (match clauses
+      (()
+       (reverse result))
+      ((#:use-module (module (or #:select #:hide #:prefix #:renamer) _)
+        rest ...)
+       (loop rest (cons module result)))
+      ((#:use-module module rest ...)
+       (loop rest (cons module result)))
+      ((#:autoload module _ rest ...)
+       (loop rest (cons module result)))
+      (((or #:export #:re-export #:export-syntax #:re-export-syntax
+            #:replace #:version)
+        _ rest ...)
+       (loop rest result))
+      (((or #:pure #:no-backtrace) rest ...)
+       (loop rest result))
+      (((? colon-symbol? symbol) rest ...)
+       (loop (cons (colon-symbol->keyword symbol) rest)
+             result)))))
+
+(define module-file-dependencies
+  (memoize
+   (lambda (file)
+     "Return the list of the names of modules that the Guile module in FILE
+depends on."
+     (call-with-input-file file
+       (lambda (port)
+         (match (read port)
+           (('define-module name clauses ...)
+            (extract-dependencies clauses))
+           ;; XXX: R6RS 'library' form is ignored.
+           (_
+            '())))))))
+
+(define (module-name->file-name module)
+  "Return the file name for MODULE."
+  (string-append (string-join (map symbol->string module) "/")
+                 ".scm"))
+
+(define (guix-module-name? name)
+  "Return true if NAME (a list of symbols) denotes a Guix or GuixSD module."
+  (match name
+    (('guix _ ...) #t)
+    (('gnu _ ...) #t)
+    (_ #f)))
+
+(define* (source-module-dependencies module #:optional (load-path %load-path))
+  "Return the modules used by MODULE by looking at its source code."
+  ;; The (system syntax) module is a special-case because it has no
+  ;; corresponding source file (as of Guile 2.0.)
+  (if (equal? module '(system syntax))
+      '()
+      (module-file-dependencies
+       (search-path load-path
+                    (module-name->file-name module)))))
+
+(define* (module-closure modules
+                         #:key
+                         (select? guix-module-name?)
+                         (dependencies source-module-dependencies))
+  "Return the closure of MODULES, calling DEPENDENCIES to determine the list
+of modules used by a given module.  MODULES and the result are a list of Guile
+module names.  Only modules that match SELECT? are considered."
+  (let loop ((modules modules)
+             (result  '())
+             (visited  (set)))
+    (match modules
+      (()
+       (reverse result))
+      ((module rest ...)
+       (cond ((set-contains? visited module)
+              (loop rest result visited))
+             ((select? module)
+              (loop (append (dependencies module) rest)
+                    (cons module result)
+                    (set-insert module visited)))
+             (else
+              (loop rest result visited)))))))
+
+(define* (source-module-closure modules
+                                #:optional (load-path %load-path)
+                                #:key (select? guix-module-name?))
+  "Return the closure of MODULES by reading 'define-module' forms in their
+source code.  MODULES and the result are a list of Guile module names.  Only
+modules that match SELECT?  are considered."
+  (module-closure modules
+                  #:dependencies (cut source-module-dependencies <> load-path)
+                  #:select? select?))
+
+(define* (live-module-closure modules
+                              #:key (select? guix-module-name?))
+  "Return the closure of MODULES, determined by looking at live (loaded)
+module information.  MODULES and the result are a list of Guile module names.
+Only modules that match SELECT? are considered."
+  (define (dependencies module)
+    (map module-name
+         (delq the-scm-module (module-uses (resolve-module module)))))
+
+  (module-closure modules
+                  #:dependencies dependencies
+                  #:select? select?))
+
+;;; modules.scm ends here
diff --git a/tests/modules.scm b/tests/modules.scm
new file mode 100644
index 0000000..04945e5
--- /dev/null
+++ b/tests/modules.scm
@@ -0,0 +1,45 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2016 Ludovic Courtès <address@hidden>
+;;;
+;;; 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-modules)
+  #:use-module (guix modules)
+  #:use-module ((guix build-system gnu) #:select (%gnu-build-system-modules))
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-64))
+
+(test-begin "modules")
+
+(test-assert "closure of (guix build gnu-build-system)"
+  (lset= equal?
+         (live-module-closure '((guix build gnu-build-system)))
+         (source-module-closure '((guix build gnu-build-system)))
+         %gnu-build-system-modules
+         (source-module-closure %gnu-build-system-modules)
+         (live-module-closure %gnu-build-system-modules)))
+
+(test-assert "closure of (gnu build install)"
+  (lset= equal?
+         (live-module-closure '((gnu build install)))
+         (source-module-closure '((gnu build install)))))
+
+(test-assert "closure of (gnu build vm)"
+  (lset= equal?
+         (live-module-closure '((gnu build vm)))
+         (source-module-closure '((gnu build vm)))))
+
+(test-end)