You can not select more than 25 topics Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.

170 lines
6.7 KiB

  1. ;;; GNU Guix --- Functional package management for GNU
  2. ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 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. (define-module (guix discovery)
  19. #:use-module (guix i18n)
  20. #:use-module (guix modules)
  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-files
  28. scheme-modules
  29. scheme-modules*
  30. fold-modules
  31. all-modules
  32. fold-module-public-variables))
  33. ;;; Commentary:
  34. ;;;
  35. ;;; This module provides tools to discover Guile modules and the variables
  36. ;;; they export.
  37. ;;;
  38. ;;; Code:
  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. ;; Use 'scandir*' so we can avoid an extra 'lstat' for each entry, as
  50. ;; opposed to Guile's 'scandir' or 'file-system-fold'.
  51. (fold-right (lambda (entry result)
  52. (match entry
  53. (("." . _)
  54. result)
  55. ((".." . _)
  56. result)
  57. ((name . properties)
  58. (let ((absolute (string-append directory "/" name)))
  59. (case (entry-type absolute properties)
  60. ((directory)
  61. (append (scheme-files absolute) result))
  62. ((regular)
  63. (if (string-suffix? ".scm" name)
  64. (cons absolute result)
  65. result))
  66. ((symlink)
  67. (cond ((string-suffix? ".scm" name)
  68. (cons absolute result))
  69. ((stat absolute #f)
  70. =>
  71. (match-lambda
  72. (#f result)
  73. ((= stat:type 'directory)
  74. (append (scheme-files absolute)
  75. result))
  76. (_ result)))))
  77. (else
  78. result))))))
  79. '()
  80. (catch 'system-error
  81. (lambda ()
  82. (scandir* directory))
  83. (lambda args
  84. (let ((errno (system-error-errno args)))
  85. (unless (= errno ENOENT)
  86. (format (current-error-port) ;XXX
  87. (G_ "cannot access `~a': ~a~%")
  88. directory (strerror errno)))
  89. '())))))
  90. (define* (scheme-modules directory #:optional sub-directory
  91. #:key (warn (const #f)))
  92. "Return the list of Scheme modules available under DIRECTORY.
  93. Optionally, narrow the search to SUB-DIRECTORY.
  94. WARN is called when a module could not be loaded. It is passed the module
  95. name and the exception key and arguments."
  96. (define prefix-len
  97. (string-length directory))
  98. (filter-map (lambda (file)
  99. (let* ((file (substring file prefix-len))
  100. (module (file-name->module-name file)))
  101. (catch #t
  102. (lambda ()
  103. (resolve-interface module))
  104. (lambda args
  105. ;; Report the error, but keep going.
  106. (warn module args)
  107. #f))))
  108. (scheme-files (if sub-directory
  109. (string-append directory "/" sub-directory)
  110. directory))))
  111. (define* (scheme-modules* directory #:optional sub-directory)
  112. "Return the list of module names found under SUB-DIRECTORY in DIRECTORY.
  113. This is a source-only variant that does not try to load files."
  114. (let ((prefix (string-length directory)))
  115. (map (lambda (file)
  116. (file-name->module-name (string-drop file prefix)))
  117. (scheme-files (if sub-directory
  118. (string-append directory "/" sub-directory)
  119. directory)))))
  120. (define* (fold-modules proc init path #:key (warn (const #f)))
  121. "Fold over all the Scheme modules present in PATH, a list of directories.
  122. Call (PROC MODULE RESULT) for each module that is found."
  123. (fold (lambda (spec result)
  124. (match spec
  125. ((? string? directory)
  126. (fold proc result (scheme-modules directory #:warn warn)))
  127. ((directory . sub-directory)
  128. (fold proc result
  129. (scheme-modules directory sub-directory
  130. #:warn warn)))))
  131. '()
  132. path))
  133. (define* (all-modules path #:key (warn (const #f)))
  134. "Return the list of package modules found in PATH, a list of directories to
  135. search. Entries in PATH can be directory names (strings) or (DIRECTORY
  136. . SUB-DIRECTORY) pairs, in which case modules are searched for beneath
  137. SUB-DIRECTORY."
  138. (fold-modules cons '() path #:warn warn))
  139. (define (fold-module-public-variables proc init modules)
  140. "Call (PROC OBJECT RESULT) for each variable exported by one of MODULES,
  141. using INIT as the initial value of RESULT. It is guaranteed to never traverse
  142. the same object twice."
  143. (identity ; discard second return value
  144. (fold2 (lambda (module result seen)
  145. (fold2 (lambda (var result seen)
  146. (if (not (vhash-assq var seen))
  147. (values (proc var result)
  148. (vhash-consq var #t seen))
  149. (values result seen)))
  150. result
  151. seen
  152. (module-map (lambda (sym var)
  153. (false-if-exception (variable-ref var)))
  154. module)))
  155. init
  156. vlist-null
  157. modules)))
  158. ;;; discovery.scm ends here