guix/discovery.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 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 discovery)
  20   #:use-module (guix i18n)
  21   #:use-module (guix modules)
  22   #:use-module (guix combinators)
  23   #:use-module (guix build syscalls)
  24   #:use-module (srfi srfi-1)
  25   #:use-module (ice-9 match)
  26   #:use-module (ice-9 vlist)
  27   #:use-module (ice-9 ftw)
  28   #:export (scheme-files
  29             scheme-modules
  30             scheme-modules*
  31             fold-modules
  32             all-modules
  33             fold-module-public-variables
  34             fold-module-public-variables*))
  35
  36 ;;; Commentary:
  37 ;;;
  38 ;;; This module provides tools to discover Guile modules and the variables
  39 ;;; they export.
  40 ;;;
  41 ;;; Code:
  42
  43 (define* (scheme-files directory)
  44   "Return the list of Scheme files found under DIRECTORY, recursively.  The
  45 returned list is sorted in alphabetical order.  Return the empty list if
  46 DIRECTORY is not accessible."
  47   (define (entry-type name properties)
  48     (match (assoc-ref properties 'type)
  49       ('unknown
  50        (stat:type (lstat name)))
  51       ((? symbol? type)
  52        type)))
  53
  54   (define (dot-prefixed? file)
  55     (string-prefix? "." file))
  56
  57   ;; Use 'scandir*' so we can avoid an extra 'lstat' for each entry, as
  58   ;; opposed to Guile's 'scandir' or 'file-system-fold'.
  59   (fold-right (lambda (entry result)
  60                 (match entry
  61                   (((? dot-prefixed?) . _)
  62                    ;; Exclude ".", "..", and hidden files such as backups.
  63                    result)
  64                   ((name . properties)
  65                    (let ((absolute (string-append directory "/" name)))
  66                      (case (entry-type absolute properties)
  67                        ((directory)
  68                         (append (scheme-files absolute) result))
  69                        ((regular)
  70                         (if (string-suffix? ".scm" name)
  71                             (cons absolute result)
  72                             result))
  73                        ((symlink)
  74                         (cond ((string-suffix? ".scm" name)
  75                                (cons absolute result))
  76                               ((stat absolute #f)
  77                                =>
  78                                (match-lambda
  79                                  (#f result)
  80                                  ((= stat:type 'directory)
  81                                   (append (scheme-files absolute)
  82                                           result))
  83                                  (_ result)))
  84                               (else
  85                                result)))
  86                        (else
  87                         result))))))
  88               '()
  89               (catch 'system-error
  90                 (lambda ()
  91                   (scandir* directory))
  92                 (lambda args
  93                   (let ((errno (system-error-errno args)))
  94                     (unless (= errno ENOENT)
  95                       (format (current-error-port) ;XXX
  96                               (G_ "cannot access `~a': ~a~%")
  97                               directory (strerror errno)))
  98                     '())))))
  99
 100 (define* (scheme-modules directory #:optional sub-directory
 101                          #:key (warn (const #f)))
 102   "Return the list of Scheme modules available under DIRECTORY.
 103 Optionally, narrow the search to SUB-DIRECTORY.
 104
 105 WARN is called when a module could not be loaded.  It is passed the module
 106 name and the exception key and arguments."
 107   (define prefix-len
 108     (string-length directory))
 109
 110   ;; Hide Guile warnings such as "source file [...] newer than compiled" when
 111   ;; loading user code, unless we're hacking on Guix proper.  See
 112   ;; <https://issues.guix.gnu.org/43747>.
 113   (parameterize ((current-warning-port (if (getenv "GUIX_UNINSTALLED")
 114                                            (current-warning-port)
 115                                            (%make-void-port "w"))))
 116     (filter-map (lambda (file)
 117                   (let* ((relative (string-drop file prefix-len))
 118                          (module   (file-name->module-name relative)))
 119                     (catch #t
 120                       (lambda ()
 121                         (resolve-interface module))
 122                       (lambda args
 123                         ;; Report the error, but keep going.
 124                         (warn file module args)
 125                         #f))))
 126                 (scheme-files (if sub-directory
 127                                   (string-append directory "/" sub-directory)
 128                                   directory)))))
 129
 130 (define* (scheme-modules* directory #:optional sub-directory)
 131   "Return the list of module names found under SUB-DIRECTORY in DIRECTORY.
 132 This is a source-only variant that does not try to load files."
 133   (let ((prefix (string-length directory)))
 134     (map (lambda (file)
 135            (file-name->module-name (string-drop file prefix)))
 136          (scheme-files (if sub-directory
 137                            (string-append directory "/" sub-directory)
 138                            directory)))))
 139
 140 (define* (fold-modules proc init path #:key (warn (const #f)))
 141   "Fold over all the Scheme modules present in PATH, a list of directories.
 142 Call (PROC MODULE RESULT) for each module that is found."
 143   (fold (lambda (spec result)
 144           (match spec
 145             ((? string? directory)
 146              (fold proc result (scheme-modules directory #:warn warn)))
 147             ((directory . sub-directory)
 148              (fold proc result
 149                    (scheme-modules directory sub-directory
 150                                    #:warn warn)))))
 151         '()
 152         path))
 153
 154 (define* (all-modules path #:key (warn (const #f)))
 155   "Return the list of package modules found in PATH, a list of directories to
 156 search.  Entries in PATH can be directory names (strings) or (DIRECTORY
 157 . SUB-DIRECTORY) pairs, in which case modules are searched for beneath
 158 SUB-DIRECTORY. Modules are listed in the order they appear on the path."
 159   (reverse (fold-modules cons '() path #:warn warn)))
 160
 161 (define (fold-module-public-variables* proc init modules)
 162   "Call (PROC MODULE SYMBOL VARIABLE RESULT) for each variable exported by one
 163 of MODULES, using INIT as the initial value of RESULT.  It is guaranteed to
 164 never traverse the same object twice."
 165   ;; Here SEEN is populated by variables; if two different variables refer to
 166   ;; the same object, we still let them through.
 167   (identity                                       ;discard second return value
 168    (fold2 (lambda (module result seen)
 169             (fold2 (lambda (sym+var result seen)
 170                      (match sym+var
 171                        ((sym . var)
 172                         (if (not (vhash-assq var seen))
 173                             (values (proc module sym var result)
 174                                     (vhash-consq var #t seen))
 175                             (values result seen)))))
 176                    result
 177                    seen
 178                    (module-map cons module)))
 179           init
 180           vlist-null
 181           modules)))
 182
 183 (define (fold-module-public-variables proc init modules)
 184   "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES,
 185 using INIT as the initial value of RESULT.  It is guaranteed to never traverse
 186 the same object twice."
 187   ;; Note: here SEEN is populated by objects, not by variables.
 188   (identity   ; discard second return value
 189    (fold2 (lambda (module result seen)
 190             (fold2 (lambda (var result seen)
 191                      (if (not (vhash-assq var seen))
 192                          (values (proc var result)
 193                                  (vhash-consq var #t seen))
 194                          (values result seen)))
 195                    result
 196                    seen
 197                    (module-map (lambda (sym var)
 198                                  (false-if-exception (variable-ref var)))
 199                                module)))
 200           init
 201           vlist-null
 202           modules)))
 203
 204 ;;; discovery.scm ends here