blob: 88e34ec8368f95ad7aae07596c3731b76ebd0c55 (
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
|
(use-modules (ice-9 match)
(srfi srfi-1)
(test-subject game))
(define (root-module)
(resolve-module '() #f #f #:ensure #f))
(define (loaded-modules)
(define (scan-submodules module)
(hash-fold (lambda (k m memo)
(if (module-filename m)
(cons (module-filename m)
(append (scan-submodules m)
memo))
(append (scan-submodules m) memo)))
'()
(module-submodules module)))
(delete-duplicates (cons* "ice-9/eval.scm"
"ice-9/i18n.scm"
"ice-9/posix.scm"
"ice-9/psyntax-pp.scm"
"ice-9/quasisyntax.scm"
"ice-9/match.upstream.scm"
"ice-9/networking.scm"
"ice-9/r6rs-libraries.scm"
"ice-9/r7rs-libraries.scm"
(scan-submodules (root-module)))
string=?))
(define (in-load-path path file-name)
(let loop ((path path))
(match path
(() #f)
((dir . rest)
(let ((f (string-append dir "/" file-name)))
(if (file-exists? f)
f
(loop rest)))))))
(define (scm->go file-name)
(string-append (substring file-name 0 (- (string-length file-name) 4)) ".go"))
(define (shake-tree)
(map (lambda (f)
(list f
(in-load-path %load-path f)
(in-load-path %load-compiled-path
(scm->go f))))
(sort (loaded-modules) string<)))
;; Snarfed from Guix
(define (mkdir-p dir)
"Create directory DIR and all its ancestors."
(define absolute?
(string-prefix? "/" dir))
(define not-slash
(char-set-complement (char-set #\/)))
(let loop ((components (string-tokenize dir not-slash))
(root (if absolute?
""
".")))
(match components
((head tail ...)
(let ((path (string-append root "/" head)))
(catch 'system-error
(lambda ()
(mkdir path)
(loop tail path))
(lambda args
(if (= EEXIST (system-error-errno args))
(loop tail path)
(apply throw args))))))
(() #t))))
(define (install-modules spec prefix)
(let ((v (string-append (major-version) ".0")))
(for-each (match-lambda
((suffix source compiled)
(let ((scm-dest (string-append prefix "/share/guile/" v "/"
suffix))
(go-dest (string-append prefix "/lib/guile/" v "/ccache/"
(scm->go suffix))))
(mkdir-p (dirname scm-dest))
(mkdir-p (dirname go-dest))
(display (string-append "copy " source " to " scm-dest))
(newline)
(copy-file source scm-dest)
(when compiled
(display (string-append "copy " compiled " to " go-dest))
(newline)
(copy-file compiled go-dest)))))
spec)))
(install-modules (shake-tree) "/home/dthompson/Code/bundle2/the-test-subject")
|
