guix/modules.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org>
   3 ;;;
   4 ;;; This file is part of GNU Guix.
   5 ;;;
   6 ;;; GNU Guix is free software; you can redistribute it and/or modify it
   7 ;;; under the terms of the GNU General Public License as published by
   8 ;;; the Free Software Foundation; either version 3 of the License, or (at
   9 ;;; your option) any later version.
  10 ;;;
  11 ;;; GNU Guix is distributed in the hope that it will be useful, but
  12 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  14 ;;; GNU General Public License for more details.
  15 ;;;
  16 ;;; You should have received a copy of the GNU General Public License
  17 ;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
  18
  19 (define-module (guix modules)
  20   #:use-module (guix memoization)
  21   #:use-module (guix sets)
  22   #:use-module (srfi srfi-26)
  23   #:use-module (srfi srfi-34)
  24   #:use-module (srfi srfi-35)
  25   #:use-module (ice-9 match)
  26   #:export (missing-dependency-error?
  27             missing-dependency-module
  28             missing-dependency-search-path
  29
  30             file-name->module-name
  31             module-name->file-name
  32
  33             source-module-dependencies
  34             source-module-closure
  35             live-module-closure
  36             guix-module-name?))
  37
  38 ;;; Commentary:
  39 ;;;
  40 ;;; This module provides introspection tools for Guile modules at the source
  41 ;;; level.  Namely, it allows you to determine the closure of a module; it
  42 ;;; does so just by reading the 'define-module' clause of the module and its
  43 ;;; dependencies.  This is primarily useful as an argument to
  44 ;;; 'with-imported-modules'.
  45 ;;;
  46 ;;; Code:
  47
  48 ;; The error corresponding to a missing module.
  49 (define-condition-type &missing-dependency-error &error
  50   missing-dependency-error?
  51   (module      missing-dependency-module)
  52   (search-path missing-dependency-search-path))
  53
  54 (define (colon-symbol? obj)
  55   "Return true if OBJ is a symbol that starts with a colon."
  56   (and (symbol? obj)
  57        (string-prefix? ":" (symbol->string obj))))
  58
  59 (define (colon-symbol->keyword symbol)
  60   "Convert SYMBOL to a keyword after stripping its initial ':'."
  61   (symbol->keyword
  62    (string->symbol (string-drop (symbol->string symbol) 1))))
  63
  64 (define (extract-dependencies clauses)
  65   "Return the list of modules imported according to the given 'define-module'
  66 CLAUSES."
  67   (let loop ((clauses clauses)
  68              (result  '()))
  69     (match clauses
  70       (()
  71        (reverse result))
  72       ((#:use-module (module (or #:select #:hide #:prefix #:renamer) _)
  73         rest ...)
  74        (loop rest (cons module result)))
  75       ((#:use-module module rest ...)
  76        (loop rest (cons module result)))
  77       ((#:autoload module _ rest ...)
  78        (loop rest (cons module result)))
  79       (((or #:export #:re-export #:export-syntax #:re-export-syntax
  80             #:replace #:version)
  81         _ rest ...)
  82        (loop rest result))
  83       (((or #:pure #:no-backtrace) rest ...)
  84        (loop rest result))
  85       (((? colon-symbol? symbol) rest ...)
  86        (loop (cons (colon-symbol->keyword symbol) rest)
  87              result)))))
  88
  89 (define module-file-dependencies
  90   (mlambda (file)
  91     "Return the list of the names of modules that the Guile module in FILE
  92 depends on."
  93     (call-with-input-file file
  94       (lambda (port)
  95         (match (read port)
  96           (('define-module name clauses ...)
  97            (extract-dependencies clauses))
  98           ;; XXX: R6RS 'library' form is ignored.
  99           (_
 100            '()))))))
 101
 102 (define file-name->module-name
 103   (let ((not-slash (char-set-complement (char-set #\/))))
 104     (lambda (file)
 105       "Return the module name (a list of symbols) corresponding to FILE."
 106       (map string->symbol
 107            (string-tokenize (string-drop-right file 4) not-slash)))))
 108
 109 (define (module-name->file-name module)
 110   "Return the file name for MODULE."
 111   (string-append (string-join (map symbol->string module) "/")
 112                  ".scm"))
 113
 114 (define (guix-module-name? name)
 115   "Return true if NAME (a list of symbols) denotes a Guix module."
 116   (match name
 117     (('guix _ ...) #t)
 118     (('gnu _ ...) #t)
 119     (_ #f)))
 120
 121 (define %source-less-modules
 122   ;; These are modules that have no corresponding source files or a source
 123   ;; file different from what you'd expect.
 124   '((system syntax)                             ;2.0, defined in boot-9
 125     (ice-9 ports internal)                      ;2.2, defined in (ice-9 ports)
 126     (system syntax internal)))                  ;2.2, defined in boot-9
 127
 128 (define* (source-module-dependencies module #:optional (load-path %load-path))
 129   "Return the modules used by MODULE by looking at its source code."
 130   (if (member module %source-less-modules)
 131       '()
 132       (match (search-path load-path (module-name->file-name module))
 133         ((? string? file)
 134          (module-file-dependencies file))
 135         (#f
 136          (raise (condition (&missing-dependency-error
 137                             (module module)
 138                             (search-path load-path))))))))
 139
 140 (define* (module-closure modules
 141                          #:key
 142                          (select? guix-module-name?)
 143                          (dependencies source-module-dependencies))
 144   "Return the closure of MODULES, calling DEPENDENCIES to determine the list
 145 of modules used by a given module.  MODULES and the result are a list of Guile
 146 module names.  Only modules that match SELECT? are considered."
 147   (let loop ((modules modules)
 148              (result  '())
 149              (visited  (set)))
 150     (match modules
 151       (()
 152        (reverse result))
 153       ((module rest ...)
 154        (cond ((set-contains? visited module)
 155               (loop rest result visited))
 156              ((select? module)
 157               (loop (append (dependencies module) rest)
 158                     (cons module result)
 159                     (set-insert module visited)))
 160              (else
 161               (loop rest result visited)))))))
 162
 163 (define* (source-module-closure modules
 164                                 #:optional (load-path %load-path)
 165                                 #:key (select? guix-module-name?))
 166   "Return the closure of MODULES by reading 'define-module' forms in their
 167 source code.  MODULES and the result are a list of Guile module names.  Only
 168 modules that match SELECT?  are considered."
 169   (module-closure modules
 170                   #:dependencies (cut source-module-dependencies <> load-path)
 171                   #:select? select?))
 172
 173 (define* (live-module-closure modules
 174                               #:key (select? guix-module-name?))
 175   "Return the closure of MODULES, determined by looking at live (loaded)
 176 module information.  MODULES and the result are a list of Guile module names.
 177 Only modules that match SELECT? are considered."
 178   (define (dependencies module)
 179     (map module-name
 180          (delq the-scm-module (module-uses (resolve-module module)))))
 181
 182   (module-closure modules
 183                   #:dependencies dependencies
 184                   #:select? select?))
 185
 186 ;;; modules.scm ends here