blob: 0ef9ac5e5e25d2b027b7f582772a725c1fbb3753 (
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
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
|
;;; enter.rkt -- custom module loaders
;; Copyright (C) 2010, 2012, 2013 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: Wed Mar 31, 2010 21:53
#lang racket/base
(require syntax/modcode
(for-syntax racket/base)
racket/path)
(provide get-namespace visit-module module-loader)
(struct mod (name load-path timestamp depends) #:transparent)
(define (make-mod name path ts code)
(let ([deps (if code
(apply append (map cdr (module-compiled-imports code)))
null)])
(mod name (path->string path) ts deps)))
(define loaded (make-hash))
(define (mod->path mod)
(with-handlers ([exn? (lambda (_) #f)])
(let ([rp (module-path-index-resolve (module-path-index-join mod #f))])
(resolved-module-path-name rp))))
(define (visit-module mod)
(parameterize ([current-load/use-compiled
(make-loader (current-load/use-compiled) #f)])
(dynamic-require mod #f))
(check-latest mod))
(define (module-loader orig)
(make-loader orig #f))
(define inhibit-eval (make-parameter #f))
(define (get-namespace mod)
(let ([mod (cond [(symbol? mod) mod]
[(string? mod) (find-module! (string->path mod) mod)]
[(path? mod) (find-module! mod (path->string mod))]
[else mod])])
(and mod
(with-handlers ([exn? (lambda (_) #f)])
(parameterize ([inhibit-eval #t])
(module->namespace mod))))))
(define (find-module! path path-str)
(let ([m (or (hash-ref loaded path #f)
(let loop ([ps (remove path (resolve-paths path))]
[seen '()])
(cond [(null? ps) #f]
[(hash-ref loaded (car ps) #f) =>
(lambda (m)
(add-paths! m (cdr ps))
(add-paths! m (cons path seen))
m)]
[else (loop (cdr ps) (cons (car ps) seen))])))])
(list 'file (or (and m (mod-load-path m)) path-str))))
(define (add-paths! m ps)
(let* ([name (mod-name m)]
[pm (if (pair? name) (lambda (p) (cons p (cdr name))) (lambda (p) p))])
(for-each (lambda (p) (hash-set! loaded (pm p) m)) ps)))
(define (resolve-paths path)
(define (find root rest)
(let* ([alt-root (resolve-path root)]
[same? (equal? root alt-root)])
(cond [(null? rest) (cons root (if same? '() `(,alt-root)))]
[else (let* ([c (car rest)]
[cs (cdr rest)]
[rps (find (build-path root c) cs)])
(if same?
rps
(append rps (find (build-path alt-root c) cs))))])))
(let ([cmps (explode-path path)])
(find (car cmps) (cdr cmps))))
(define (notify re? path)
(when re? (fprintf (current-error-port) " [re-loading ~a]\n" path)))
(define (module-name? name)
(and name (not (and (pair? name) (not (car name))))))
(define (module-code re? name path)
(printf "Code for module ~a at ~a~%" name path)
(get-module-code path
"compiled"
(lambda (e)
(parameterize ([compile-enforce-module-constants #f])
(compile e)))
(lambda (ext loader?) (load-extension ext) #f)
#:submodule-path (if (pair? name) (cdr name) '())
#:notify (lambda (chosen) (notify re? chosen))))
(define ((make-loader orig re?) path name)
(when (inhibit-eval)
(raise (make-exn:fail "namespace not found" (current-continuation-marks))))
(if (module-name? name)
;; Module load:
(with-handlers ([(lambda (exn)
(and (pair? name) (exn:get-module-code? exn)))
;; Load-handler protocol: quiet failure when a
;; submodule is not found
(lambda (exn) (void))])
(let* ([code (module-code re? name path)]
[dir (or (current-load-relative-directory) (current-directory))]
[path (path->complete-path path dir)]
[path (normal-case-path (simplify-path path))])
(define-values (ts real-path) (get-timestamp path))
(add-paths! (make-mod name path ts code) (resolve-paths path))
(parameterize ([current-module-declare-source real-path])
(eval code))))
;; Not a module:
(begin (notify re? path) (orig path name))))
(define (get-timestamp path)
(let ([ts (file-or-directory-modify-seconds path #f (lambda () #f))])
(if ts
(values ts path)
(if (regexp-match? #rx#"[.]rkt$" (path->bytes path))
(let* ([alt-path (path-replace-suffix path #".ss")]
[ts (file-or-directory-modify-seconds alt-path
#f
(lambda () #f))])
(if ts
(values ts alt-path)
(values -inf.0 path)))
(values -inf.0 path)))))
(define (check-latest mod)
(define mpi (module-path-index-join mod #f))
(define done (make-hash))
(let loop ([mpi mpi])
(define rindex (module-path-index-resolve mpi))
(define rpath (resolved-module-path-name rindex))
(define path (if (pair? rpath) (car rpath) rpath))
(when (path? path)
(define npath (normal-case-path path))
(unless (hash-ref done npath #f)
(hash-set! done npath #t)
(define mod (hash-ref loaded rpath #f))
(when mod
(for-each loop (mod-depends mod))
(define-values (ts actual-path) (get-timestamp npath))
(when (> ts (mod-timestamp mod))
(define orig (current-load/use-compiled))
(parameterize ([current-load/use-compiled
(make-loader orig #f)]
[current-module-declare-name rindex]
[current-module-declare-source actual-path])
((make-loader orig #t) npath (mod-name mod)))))))))
|
