blob: 2934603288403a7deefded7c958b39ddb9c39f99 (
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
|
;;; 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-filename
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 (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-filename name) #f))
(define module-filename (@@ (ice-9 session) module-filename))
(define (all-modules)
(let ((roots ((@@ (ice-9 session) root-modules))))
(map (lambda (m)
(format "~A" (module-name m)))
(fold (lambda (m all)
(append (all-child-modules m) all))
roots
roots))))
(define (module-exports mod-name)
(let* ((elts (hash-fold classify-module-object
(list '() '() '())
(module-obarray (maybe-module-interface mod-name))))
(elts (map sort-symbols! elts)))
(list (cons 'modules (map (lambda (m) `(,@mod-name ,m)) (car elts)))
(cons 'procs (cadr elts))
(cons 'vars (caddr elts)))))
(define (maybe-module-interface mod-name)
(catch #t
(lambda () (resolve-interface mod-name))
(lambda args (resolve-module mod-name))))
(define (child-modules mod)
(delq mod ((@@ (ice-9 session) submodules) mod)))
(define (all-child-modules mod)
(let ((children (child-modules mod)))
(fold (lambda (m all)
(append (all-child-modules m) all))
children children)))
(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
|
