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 (srfi srfi-1)
  23   #:use-module (ice-9 match)
  24   #:use-module (ice-9 vlist)
  25   #:use-module (ice-9 ftw)
  26   #:export (scheme-modules
  27             fold-modules
  28             all-modules
  29             fold-module-public-variables))
  30
  31 ;;; Commentary:
  32 ;;;
  33 ;;; This module provides tools to discover Guile modules and the variables
  34 ;;; they export.
  35 ;;;
  36 ;;; Code:
  37
  38 (define* (scheme-files directory)
  39   "Return the list of Scheme files found under DIRECTORY, recursively.  The
  40 returned list is sorted in alphabetical order."
  41
  42   ;; Sort entries so that 'fold-packages' works in a deterministic fashion
  43   ;; regardless of details of the underlying file system.
  44   (sort (file-system-fold (const #t)                 ;enter?
  45                           (lambda (path stat result) ;leaf
  46                             (if (string-suffix? ".scm" path)
  47                                 (cons path result)
  48                                 result))
  49                           (lambda (path stat result) ;down
  50                             result)
  51                           (lambda (path stat result) ;up
  52                             result)
  53                           (const #f)                 ;skip
  54                           (lambda (path stat errno result)
  55                             (unless (= ENOENT errno)
  56                               (warning (G_ "cannot access `~a': ~a~%")
  57                                        path (strerror errno)))
  58                             result)
  59                           '()
  60                           directory
  61                           stat)
  62         string<?))
  63
  64 (define file-name->module-name
  65   (let ((not-slash (char-set-complement (char-set #\/))))
  66     (lambda (file)
  67       "Return the module name (a list of symbols) corresponding to FILE."
  68       (map string->symbol
  69            (string-tokenize (string-drop-right file 4) not-slash)))))
  70
  71 (define* (scheme-modules directory #:optional sub-directory)
  72   "Return the list of Scheme modules available under DIRECTORY.
  73 Optionally, narrow the search to SUB-DIRECTORY."
  74   (define prefix-len
  75     (string-length directory))
  76
  77   (filter-map (lambda (file)
  78                 (let* ((file   (substring file prefix-len))
  79                        (module (file-name->module-name file)))
  80                   (catch #t
  81                     (lambda ()
  82                       (resolve-interface module))
  83                     (lambda args
  84                       ;; Report the error, but keep going.
  85                       (warn-about-load-error module args)
  86                       #f))))
  87               (scheme-files (if sub-directory
  88                                 (string-append directory "/" sub-directory)
  89                                 directory))))
  90
  91 (define (fold-modules proc init path)
  92   "Fold over all the Scheme modules present in PATH, a list of directories.
  93 Call (PROC MODULE RESULT) for each module that is found."
  94   (fold (lambda (spec result)
  95           (match spec
  96             ((? string? directory)
  97              (fold proc result (scheme-modules directory)))
  98             ((directory . sub-directory)
  99              (fold proc result
 100                    (scheme-modules directory sub-directory)))))
 101         '()
 102         path))
 103
 104 (define (all-modules path)
 105   "Return the list of package modules found in PATH, a list of directories to
 106 search.  Entries in PATH can be directory names (strings) or (DIRECTORY
 107 . SUB-DIRECTORY) pairs, in which case modules are searched for beneath
 108 SUB-DIRECTORY."
 109   (fold-modules cons '() path))
 110
 111 (define (fold-module-public-variables proc init modules)
 112   "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES,
 113 using INIT as the initial value of RESULT.  It is guaranteed to never traverse
 114 the same object twice."
 115   (identity   ; discard second return value
 116    (fold2 (lambda (module result seen)
 117             (fold2 (lambda (var result seen)
 118                      (if (not (vhash-assq var seen))
 119                          (values (proc var result)
 120                                  (vhash-consq var #t seen))
 121                          (values result seen)))
 122                    result
 123                    seen
 124                    (module-map (lambda (sym var)
 125                                  (false-if-exception (variable-ref var)))
 126                                module)))
 127           init
 128           vlist-null
 129           modules)))
 130
 131 ;;; discovery.scm ends here