1 ;;; enter.rkt -- custom module loaders
3 ;; Copyright (C) 2010, 2012, 2013 Jose Antonio Ortega Ruiz
5 ;; This program is free software; you can redistribute it and/or
6 ;; modify it under the terms of the Modified BSD License. You should
7 ;; have received a copy of the license along with this program. If
8 ;; not, see <http://www.xfree86.org/3.3.6/COPYRIGHT2.html#5>.
10 ;; Start date: Wed Mar 31, 2010 21:53
14 (require syntax/modcode
15 (for-syntax racket/base)
18 (provide get-namespace visit-module module-loader)
20 (struct mod (name load-path timestamp depends) #:transparent)
22 (define (make-mod name path ts code)
24 (apply append (map cdr (module-compiled-imports code)))
26 (mod name (path->string path) ts deps)))
28 (define loaded (make-hash))
30 (define (mod->path mod)
31 (with-handlers ([exn? (lambda (_) #f)])
32 (let ([rp (module-path-index-resolve (module-path-index-join mod #f))])
33 (resolved-module-path-name rp))))
35 (define (visit-module mod)
36 (parameterize ([current-load/use-compiled
37 (make-loader (current-load/use-compiled) #f)])
38 (dynamic-require mod #f))
41 (define (module-loader orig)
42 (make-loader orig #f))
44 (define inhibit-eval (make-parameter #f))
46 (define (get-namespace mod)
47 (let ([mod (cond [(symbol? mod) mod]
48 [(string? mod) (find-module! (string->path mod) mod)]
49 [(path? mod) (find-module! mod (path->string mod))]
52 (with-handlers ([exn? (lambda (_) #f)])
53 (parameterize ([inhibit-eval #t])
54 (module->namespace mod))))))
56 (define (find-module! path path-str)
57 (let ([m (or (hash-ref loaded path #f)
58 (let loop ([ps (remove path (resolve-paths path))]
61 [(hash-ref loaded (car ps) #f) =>
63 (add-paths! m (cdr ps))
64 (add-paths! m (cons path seen))
66 [else (loop (cdr ps) (cons (car ps) seen))])))])
67 (list 'file (or (and m (mod-load-path m)) path-str))))
69 (define (add-paths! m ps)
70 (for-each (lambda (p) (hash-set! loaded p m)) ps))
72 (define (resolve-paths path)
73 (define (find root rest)
74 (let* ([alt-root (resolve-path root)]
75 [same? (equal? root alt-root)])
76 (cond [(null? rest) (cons root (if same? '() `(,alt-root)))]
77 [else (let* ([c (car rest)]
79 [rps (find (build-path root c) cs)])
82 (append rps (find (build-path alt-root c) cs))))])))
83 (let ([cmps (explode-path path)])
84 (find (car cmps) (cdr cmps))))
86 (define (notify re? path)
87 (when re? (fprintf (current-error-port) " [re-loading ~a]\n" path)))
89 (define (module-name? name)
90 (and name (not (and (pair? name) (not (car name))))))
92 (define (module-code re? name path)
96 (parameterize ([compile-enforce-module-constants #f])
98 (lambda (ext loader?) (load-extension ext) #f)
99 #:notify (lambda (chosen) (notify re? chosen))))
101 (define ((make-loader orig re?) path name)
103 (raise (make-exn:fail "namespace not found" (current-continuation-marks))))
104 (if (module-name? name)
106 (with-handlers ([(lambda (exn)
107 (and (pair? name) (exn:get-module-code? exn)))
108 ;; Load-handler protocol: quiet failure when a
109 ;; submodule is not found
110 (lambda (exn) (void))])
111 (let* ([code (module-code re? name path)]
112 [dir (or (current-load-relative-directory) (current-directory))]
113 [path (path->complete-path path dir)]
114 [path (normal-case-path (simplify-path path))])
115 (define-values (ts real-path) (get-timestamp path))
116 (add-paths! (make-mod name path ts code) (resolve-paths path))
117 (parameterize ([current-module-declare-source real-path])
120 (begin (notify re? path) (orig path name))))
122 (define (get-timestamp path)
123 (let ([ts (file-or-directory-modify-seconds path #f (lambda () #f))])
126 (if (regexp-match? #rx#"[.]rkt$" (path->bytes path))
127 (let* ([alt-path (path-replace-suffix path #".ss")]
128 [ts (file-or-directory-modify-seconds alt-path
133 (values -inf.0 path)))
134 (values -inf.0 path)))))
136 (define (check-latest mod)
137 (define mpi (module-path-index-join mod #f))
138 (define done (make-hash))
139 (let loop ([mpi mpi])
140 (define rindex (module-path-index-resolve mpi))
141 (define rpath (resolved-module-path-name rindex))
142 (define path (if (pair? rpath) (car rpath) rpath))
144 (define npath (normal-case-path path))
145 (unless (hash-ref done npath #f)
146 (hash-set! done npath #t)
147 (define mod (hash-ref loaded rpath #f))
149 (for-each loop (mod-depends mod))
150 (define-values (ts actual-path) (get-timestamp npath))
151 (when (> ts (mod-timestamp mod))
152 (define orig (current-load/use-compiled))
153 (parameterize ([current-load/use-compiled
154 (make-loader orig #f)]
155 [current-module-declare-name rindex]
156 [current-module-declare-source actual-path])
157 ((make-loader orig #t) npath (mod-name mod)))))))))