guix/discovery.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 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 discovery)
  20   #:use-module (guix ui)
  21   #:use-module (guix combinators)
  22   #:use-module (guix build syscalls)
  23   #:use-module (srfi srfi-1)
  24   #:use-module (ice-9 match)
  25   #:use-module (ice-9 vlist)
  26   #:use-module (ice-9 ftw)
  27   #:export (scheme-modules
  28             fold-modules
  29             all-modules
  30             fold-module-public-variables))
  31
  32 ;;; Commentary:
  33 ;;;
  34 ;;; This module provides tools to discover Guile modules and the variables
  35 ;;; they export.
  36 ;;;
  37 ;;; Code:
  38
  39 (define* (scheme-files directory)
  40   "Return the list of Scheme files found under DIRECTORY, recursively.  The
  41 returned list is sorted in alphabetical order.  Return the empty list if
  42 DIRECTORY is not accessible."
  43   (define (entry-type name properties)
  44     (match (assoc-ref properties 'type)
  45       ('unknown
  46        (stat:type (lstat name)))
  47       ((? symbol? type)
  48        type)))
  49
  50   ;; Use 'scandir*' so we can avoid an extra 'lstat' for each entry, as
  51   ;; opposed to Guile's 'scandir' or 'file-system-fold'.
  52   (fold-right (lambda (entry result)
  53                 (match entry
  54                   (("." . _)
  55                    result)
  56                   ((".." . _)
  57                    result)
  58                   ((name . properties)
  59                    (let ((absolute (string-append directory "/" name)))
  60                      (case (entry-type absolute properties)
  61                        ((directory)
  62                         (append (scheme-files absolute) result))
  63                        ((regular symlink)
  64                         ;; XXX: We don't recurse if we find a symlink.
  65                         (if (string-suffix? ".scm" name)
  66                             (cons absolute result)
  67                             result))
  68                        (else
  69                         result))))))
  70               '()
  71               (catch 'system-error
  72                 (lambda ()
  73                   (scandir* directory))
  74                 (lambda args
  75                   (let ((errno (system-error-errno args)))
  76                     (unless (= errno ENOENT)
  77                       (warning (G_ "cannot access `~a': ~a~%")
  78                                directory (strerror errno)))
  79                     '())))))
  80
  81 (define file-name->module-name
  82   (let ((not-slash (char-set-complement (char-set #\/))))
  83     (lambda (file)
  84       "Return the module name (a list of symbols) corresponding to FILE."
  85       (map string->symbol
  86            (string-tokenize (string-drop-right file 4) not-slash)))))
  87
  88 (define* (scheme-modules directory #:optional sub-directory)
  89   "Return the list of Scheme modules available under DIRECTORY.
  90 Optionally, narrow the search to SUB-DIRECTORY."
  91   (define prefix-len
  92     (string-length directory))
  93
  94   (filter-map (lambda (file)
  95                 (let* ((file   (substring file prefix-len))
  96                        (module (file-name->module-name file)))
  97                   (catch #t
  98                     (lambda ()
  99                       (resolve-interface module))
 100                     (lambda args
 101                       ;; Report the error, but keep going.
 102                       (warn-about-load-error module args)
 103                       #f))))
 104               (scheme-files (if sub-directory
 105                                 (string-append directory "/" sub-directory)
 106                                 directory))))
 107
 108 (define (fold-modules proc init path)
 109   "Fold over all the Scheme modules present in PATH, a list of directories.
 110 Call (PROC MODULE RESULT) for each module that is found."
 111   (fold (lambda (spec result)
 112           (match spec
 113             ((? string? directory)
 114              (fold proc result (scheme-modules directory)))
 115             ((directory . sub-directory)
 116              (fold proc result
 117                    (scheme-modules directory sub-directory)))))
 118         '()
 119         path))
 120
 121 (define (all-modules path)
 122   "Return the list of package modules found in PATH, a list of directories to
 123 search.  Entries in PATH can be directory names (strings) or (DIRECTORY
 124 . SUB-DIRECTORY) pairs, in which case modules are searched for beneath
 125 SUB-DIRECTORY."
 126   (fold-modules cons '() path))
 127
 128 (define (fold-module-public-variables proc init modules)
 129   "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES,
 130 using INIT as the initial value of RESULT.  It is guaranteed to never traverse
 131 the same object twice."
 132   (identity   ; discard second return value
 133    (fold2 (lambda (module result seen)
 134             (fold2 (lambda (var result seen)
 135                      (if (not (vhash-assq var seen))
 136                          (values (proc var result)
 137                                  (vhash-consq var #t seen))
 138                          (values result seen)))
 139                    result
 140                    seen
 141                    (module-map (lambda (sym var)
 142                                  (false-if-exception (variable-ref var)))
 143                                module)))
 144           init
 145           vlist-null
 146           modules)))
 147
 148 ;;; discovery.scm ends here