blob: 780d39e419c2fcc687d6e0261dde0e30e118796a (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
|
;;; modules.scm -- module metadata
;; Copyright (C) 2009, 2010, 2011 Jose Antonio Ortega Ruiz
;; This program is free software; you can redistribute it and/or
;; modify it under the terms of the Modified BSD License. You should
;; have received a copy of the license along with this program. If
;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
;; Start date: Mon Mar 02, 2009 02:00
(define-module (geiser modules)
#:export (symbol-module
module-name?
module-path
find-module
all-modules
submodules
module-location)
#:use-module (geiser utils)
#:use-module (system vm program)
#:use-module (ice-9 regex)
#:use-module (ice-9 session)
#:use-module (srfi srfi-1))
(define (module-name? module-name)
(and (list? module-name)
(not (null? module-name))
(every symbol? module-name)))
(define (symbol-module sym . all)
(and sym
(catch 'module-name
(lambda ()
(apropos-fold (lambda (module name var init)
(if (eq? name sym)
(throw 'module-name (module-name module))
init))
#f
(regexp-quote (symbol->string sym))
(if (or (null? all) (not (car all)))
(apropos-fold-accessible (current-module))
apropos-fold-all)))
(lambda (key . args)
(and (eq? key 'module-name) (car args))))))
(define (module-location name)
(make-location (module-path name) #f))
(define (find-module mod-name)
(and (module-name? mod-name)
(resolve-module mod-name #f #:ensure #f)))
(define (module-path module-name)
(and (module-name? module-name)
(or ((@@ (ice-9 session) module-filename) module-name)
(module-filename (resolve-module module-name #f)))))
(define (submodules mod)
(hash-map->list (lambda (k v) v) (module-submodules mod)))
(define (root-modules)
(submodules (resolve-module '() #f)))
(define (all-modules)
(define (maybe-name m)
(and (module-kind m) (format #f "~A" (module-name m))))
(let* ((guile (resolve-module '(guile)))
(roots (remove (lambda (m) (eq? m guile)) (root-modules)))
(children (append-map all-child-modules roots)))
(cons "(guile)" (filter-map maybe-name children))))
(define* (all-child-modules mod #:optional (seen '()))
(let ((cs (filter (lambda (m) (not (member m seen))) (submodules mod))))
(fold (lambda (m all) (append (all-child-modules m all) all))
(list mod)
cs)))
|
