1#lang mzscheme
2
3  (require syntax/moddep
4           mzlib/class
5           racket/private/namespace
6           mred)
7
8  (provide eval/annotations
9           require/annotations
10           require/sandbox+annotations
11           load-module/annotate)
12
13  ;; Like REQUIRE/ANNOTATIONS but the evaluation happens under the given
14  ;; custodian and the given error display handler.
15  (define (require/sandbox+annotations custodian err-display-handler initial-module annotate-module? annotator)
16    (parameterize ([current-custodian custodian]
17                   [current-namespace (make-gui-namespace)]
18                   [error-display-handler err-display-handler])
19      (require/annotations initial-module annotate-module? annotator)))
20
21
22  ;; Like EVAL/ANNOTATION, but loads the required spec INITIAL-MODULE using EVAL.
23  (define (require/annotations initial-module annotate-module? annotator)
24    (eval/annotations #`(require #,initial-module) annotate-module? annotator))
25
26  ;; Evaluates STX. For each module loaded during the evaluation,
27  ;; ANNOTATE-MODULE? is queried, if it returns true, ANNOTATOR is ran on the
28  ;; expanded module being loaded, and the return value is loaded instead.
29  (define (eval/annotations stx annotate-module? annotator)
30    (parameterize
31      ([current-load/use-compiled
32        (let ([ocload/use-compiled (current-load/use-compiled)])
33          (lambda (fn m)
34            (cond [(annotate-module? fn m)
35                   (load-module/annotate annotator fn m)]
36                  [else
37                   (ocload/use-compiled fn m)])))])
38      (eval-syntax (annotator stx))))
39
40  ;; Loads the file FN expecting a definition for a module called M.  The
41  ;; code read from the file is expanded, then it is annotated using the
42  ;; ANNOTATOR function, then it is evaluated
43  (define (load-module/annotate annotator fn m)
44    (let-values ([(base _ __) (split-path fn)]
45                 [(in-port src) (build-input-port fn)])
46      (dynamic-wind
47       (lambda () (void))
48
49       (lambda ()
50         (parameterize ([read-accept-compiled #f]
51                        [current-load-relative-directory base])
52           (unless m (raise 'module-name-not-passed-to-load-module/annotate))
53           (with-module-reading-parameterization
54            (lambda ()
55              (let* ([first (parameterize ([current-namespace (make-base-namespace)])
56                              (expand (read-syntax src in-port)))]
57                     [module-ized-exp (annotator (check-module-form first m fn))]
58                     [second (read in-port)])
59                (unless (eof-object? second)
60                  (raise-syntax-error
61                   'load-module/annotate
62                   (format "expected only a `module' declaration for `~s', but found an extra expression" m)
63                   second))
64                (eval module-ized-exp))))))
65
66       (lambda () (close-input-port in-port)))))
67
68
69
70  ; taken directly from mred.rkt -- it's not exported...
71  (define (build-input-port filename)
72    (let ([p (open-input-file filename)])
73      (port-count-lines! p)
74      (let ([p (cond [(regexp-match-peek "^WXME01[0-9][0-9] ## " p)
75                      (let ([t (make-object text%)])
76                        (send t insert-file p 'standard)
77                        (close-input-port p)
78                        (open-input-text-editor t))]
79                     [else p])])
80        (port-count-lines! p)
81        (values p filename))))
82
83