guix/modules.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2016, 2017 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
  29             source-module-closure
  30             live-module-closure
  31             guix-module-name?))
  32
  33 ;;; Commentary:
  34 ;;;
  35 ;;; This module provides introspection tools for Guile modules at the source
  36 ;;; level.  Namely, it allows you to determine the closure of a module; it
  37 ;;; does so just by reading the 'define-module' clause of the module and its
  38 ;;; dependencies.  This is primarily useful as an argument to
  39 ;;; 'with-imported-modules'.
  40 ;;;
  41 ;;; Code:
  42
  43 ;; The error corresponding to a missing module.
  44 (define-condition-type &missing-dependency-error &error
  45   missing-dependency-error?
  46   (module  missing-dependency-module))
  47
  48 (define (colon-symbol? obj)
  49   "Return true if OBJ is a symbol that starts with a colon."
  50   (and (symbol? obj)
  51        (string-prefix? ":" (symbol->string obj))))
  52
  53 (define (colon-symbol->keyword symbol)
  54   "Convert SYMBOL to a keyword after stripping its initial ':'."
  55   (symbol->keyword
  56    (string->symbol (string-drop (symbol->string symbol) 1))))
  57
  58 (define (extract-dependencies clauses)
  59   "Return the list of modules imported according to the given 'define-module'
  60 CLAUSES."
  61   (let loop ((clauses clauses)
  62              (result  '()))
  63     (match clauses
  64       (()
  65        (reverse result))
  66       ((#:use-module (module (or #:select #:hide #:prefix #:renamer) _)
  67         rest ...)
  68        (loop rest (cons module result)))
  69       ((#:use-module module rest ...)
  70        (loop rest (cons module result)))
  71       ((#:autoload module _ rest ...)
  72        (loop rest (cons module result)))
  73       (((or #:export #:re-export #:export-syntax #:re-export-syntax
  74             #:replace #:version)
  75         _ rest ...)
  76        (loop rest result))
  77       (((or #:pure #:no-backtrace) rest ...)
  78        (loop rest result))
  79       (((? colon-symbol? symbol) rest ...)
  80        (loop (cons (colon-symbol->keyword symbol) rest)
  81              result)))))
  82
  83 (define module-file-dependencies
  84   (mlambda (file)
  85     "Return the list of the names of modules that the Guile module in FILE
  86 depends on."
  87     (call-with-input-file file
  88       (lambda (port)
  89         (match (read port)
  90           (('define-module name clauses ...)
  91            (extract-dependencies clauses))
  92           ;; XXX: R6RS 'library' form is ignored.
  93           (_
  94            '()))))))
  95
  96 (define (module-name->file-name module)
  97   "Return the file name for MODULE."
  98   (string-append (string-join (map symbol->string module) "/")
  99                  ".scm"))
 100
 101 (define (guix-module-name? name)
 102   "Return true if NAME (a list of symbols) denotes a Guix or GuixSD module."
 103   (match name
 104     (('guix _ ...) #t)
 105     (('gnu _ ...) #t)
 106     (_ #f)))
 107
 108 (define %source-less-modules
 109   ;; These are modules that have no corresponding source files or a source
 110   ;; file different from what you'd expect.
 111   '((system syntax)                             ;2.0, defined in boot-9
 112     (ice-9 ports internal)                      ;2.2, defined in (ice-9 ports)
 113     (system syntax internal)))                  ;2.2, defined in boot-9
 114
 115 (define* (source-module-dependencies module #:optional (load-path %load-path))
 116   "Return the modules used by MODULE by looking at its source code."
 117   (if (member module %source-less-modules)
 118       '()
 119       (match (search-path load-path (module-name->file-name module))
 120         ((? string? file)
 121          (module-file-dependencies file))
 122         (#f
 123          (raise (condition (&missing-dependency-error
 124                             (module module))))))))
 125
 126 (define* (module-closure modules
 127                          #:key
 128                          (select? guix-module-name?)
 129                          (dependencies source-module-dependencies))
 130   "Return the closure of MODULES, calling DEPENDENCIES to determine the list
 131 of modules used by a given module.  MODULES and the result are a list of Guile
 132 module names.  Only modules that match SELECT? are considered."
 133   (let loop ((modules modules)
 134              (result  '())
 135              (visited  (set)))
 136     (match modules
 137       (()
 138        (reverse result))
 139       ((module rest ...)
 140        (cond ((set-contains? visited module)
 141               (loop rest result visited))
 142              ((select? module)
 143               (loop (append (dependencies module) rest)
 144                     (cons module result)
 145                     (set-insert module visited)))
 146              (else
 147               (loop rest result visited)))))))
 148
 149 (define* (source-module-closure modules
 150                                 #:optional (load-path %load-path)
 151                                 #:key (select? guix-module-name?))
 152   "Return the closure of MODULES by reading 'define-module' forms in their
 153 source code.  MODULES and the result are a list of Guile module names.  Only
 154 modules that match SELECT?  are considered."
 155   (module-closure modules
 156                   #:dependencies (cut source-module-dependencies <> load-path)
 157                   #:select? select?))
 158
 159 (define* (live-module-closure modules
 160                               #:key (select? guix-module-name?))
 161   "Return the closure of MODULES, determined by looking at live (loaded)
 162 module information.  MODULES and the result are a list of Guile module names.
 163 Only modules that match SELECT? are considered."
 164   (define (dependencies module)
 165     (map module-name
 166          (delq the-scm-module (module-uses (resolve-module module)))))
 167
 168   (module-closure modules
 169                   #:dependencies dependencies
 170                   #:select? select?))
 171
 172 ;;; modules.scm ends here