blob: 7ca18c95ae5c896a0a35f90b9d6011d6790b510a (
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
|
;;; modules.scm -- module metadata
;; Copyright (C) 2009, 2010 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
module-exports
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 module-name)
(and (module-name? module-name)
(or (nested-ref (resolve-module '() #f) module-name)
(let ((m (resolve-module module-name #f)))
(beautify-user-module! m)
m))))
(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)
(let ((name (module-name m)))
(and (not (gensym? (car name)))
(format "~A" name))))
(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)))
(define (module-exports mod-name)
(let* ((mod (catch #t
(lambda () (resolve-interface mod-name))
(lambda args (resolve-module mod-name))))
(elts (hash-fold classify-module-object
(list '() '() '())
(module-obarray mod)))
(elts (map sort-symbols! elts))
(subs (map module-name (submodules (resolve-module mod-name #f)))))
(list (cons 'modules (append subs
(map (lambda (m)
`(,@mod-name ,m)) (car elts))))
(cons 'procs (cadr elts))
(cons 'vars (caddr elts)))))
(define (classify-module-object name var elts)
(let ((obj (and (variable-bound? var)
(variable-ref var))))
(cond ((not obj) elts)
((and (module? obj) (eq? (module-kind obj) 'directory))
(list (cons name (car elts))
(cadr elts)
(caddr elts)))
((or (procedure? obj) (program? obj) (macro? obj))
(list (car elts)
(cons name (cadr elts))
(caddr elts)))
(else (list (car elts)
(cadr elts)
(cons name (caddr elts)))))))
;;; modules.scm ends here
|
