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
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
|
#lang racket/base
(require (only-in openssl/md5 md5)
racket/contract
racket/match
(only-in racket/path path-only)
syntax/modread
syntax/parse/define
"mod.rkt"
(prefix-in online-check-syntax-monitor: "online-check-syntax.rkt"))
(provide with-expanded-syntax-caching-evaluator
file->syntax
file->expanded-syntax
string->expanded-syntax
path->existing-syntax
path->existing-expanded-syntax)
(define-logger racket-mode-syntax-cache)
;; Return a syntax object for the contents of `path`. The resulting
;; syntax is applied to `k` while the parameter
;; current-load-relative-directory is set correctly for `path`.
(define/contract (file->syntax path [k values])
(->* (path-string?)
((-> syntax? any))
any)
(define dir (path-only path))
(parameterize ([current-load-relative-directory dir]
[current-directory dir])
(k
(with-module-reading-parameterization
(λ ()
(with-input-from-file path
(λ ()
(port-count-lines! (current-input-port))
(match (read-syntax)
[(? eof-object?) #'""]
[stx stx]))))))))
;; Same but from a string, where `path` is used for the load relative
;; directory and given to read-syntax as the source
(define/contract (string->syntax path code-str [k values])
(->* (path-string? string?)
((-> syntax? any))
any)
(define dir (path-only path))
(parameterize ([current-load-relative-directory dir]
[current-directory dir])
(k
(with-module-reading-parameterization
(λ ()
(define in (open-input-string code-str))
(port-count-lines! in)
(match (read-syntax path in)
[(? eof-object?) #'""]
[stx stx]))))))
;;; expanded syntax caching
(define/contract (call-with-expanded-syntax-caching-evaluator maybe-mod thk)
(-> (or/c mod? #f) (-> any) any)
(parameterize ([current-eval (make-eval-handler maybe-mod)])
(thk)))
(define-simple-macro (with-expanded-syntax-caching-evaluator mm:expr e:expr ...+)
(call-with-expanded-syntax-caching-evaluator mm (λ () e ...)))
(define ((make-eval-handler _maybe-mod [orig-eval (current-eval)]) e)
(cond [(and (syntax? e)
(syntax-source e)
(path-string? (syntax-source e))
(complete-path? (syntax-source e))
(file-exists? (syntax-source e))
(not (compiled-expression? (syntax-e e))))
(define expanded-stx (expand e))
(cache-set! (syntax-source e)
e
expanded-stx
(file->digest (syntax-source e))
(current-namespace)
(current-load-relative-directory))
(orig-eval expanded-stx)]
[else (orig-eval e)]))
;; cache : (hash/c path? cache-entry?)
(struct cache-entry (stx exp-stx digest namespace load-relative-directory))
(define cache (make-hash))
(define last-mod #f)
(define/contract (cache-set! path stx exp-stx digest namespace load-rel-dir)
(-> path? syntax? syntax? string? namespace? (or/c #f (and/c path-string? complete-path?)) any)
(hash-set! cache path
(cache-entry stx
exp-stx
digest
namespace
load-rel-dir)))
(define (->path v)
(cond [(path? v) v]
[(path-string? v) (string->path v)]
[else (error '->path "not path? or path-string?" v)]))
;; Returns the result of applying `k` to the expanded syntax, with the
;; correct parameterization of current-namespace and
;; current-load-relative-directory. Note that `k` deliberately does
;; not default to `values` because trying to use the syntax without
;; the correct parameterizations will often result in bugs, sometimes
;; subtle and confusing. So this "CPS" approach guides you to do the
;; right thing.
(define/contract (file->expanded-syntax path-str k)
(-> path-string? (-> syntax? any) any)
(define path (->path path-str))
(define digest (file->digest path))
(match (hash-ref cache path #f)
[(cache-entry _stx exp-stx (== digest) namespace load-rel-dir)
(log-racket-mode-syntax-cache-info "file->expanded-syntax cache hit ~v ~v" path digest)
(parameterize ([current-namespace namespace]
[current-load-relative-directory load-rel-dir]
[current-directory load-rel-dir])
(k exp-stx))]
[_
(log-racket-mode-syntax-cache-info "file->expanded-syntax cache MISS ~v ~v" path digest)
(online-check-syntax-monitor:reset! path)
(file->syntax
path
(λ (stx)
;; Create and parameterize a namespace here. file->syntax
;; already parameterized the directory before calling us.
(parameterize ([current-namespace (make-base-namespace)])
(define exp-stx (expand stx))
(cache-set! path stx exp-stx digest (current-namespace) (current-load-relative-directory))
(k exp-stx))))]))
;; Same but when you don't have a file.
(define/contract (string->expanded-syntax path-str code-str k)
(-> path-string? string? (-> syntax? any) any)
(define path (->path path-str))
(define digest (string->digest code-str))
(match (hash-ref cache path #f)
[(cache-entry _stx exp-stx (== digest) namespace load-rel-dir)
(log-racket-mode-syntax-cache-info "string->expanded-syntax cache hit ~v ~v" path digest)
(parameterize ([current-namespace namespace]
[current-load-relative-directory load-rel-dir]
[current-directory load-rel-dir])
(k exp-stx))]
[_
(log-racket-mode-syntax-cache-info "string->expanded-syntax cache MISS ~v ~v" path digest)
(online-check-syntax-monitor:reset! path)
(string->syntax
path-str code-str
(λ (stx)
;; Create and parameterize a namespace here. string->syntax
;; already parameterized the directory before calling us.
(parameterize ([current-namespace (make-base-namespace)])
(define exp-stx (expand stx))
(cache-set! path stx exp-stx digest (current-namespace) (current-load-relative-directory))
(k exp-stx))))]))
(define/contract (file->digest path)
(-> path? string?)
(call-with-input-file path md5))
(define/contract (string->digest str)
(-> string? string?)
(md5 (open-input-string str)))
;; Like string->syntax but given only the path-str and only if syntax
;; already in the cache, as a result of previously calling
;; string->expanded-syntax. Intended for use by identifier.rkt.
(define/contract (path->existing-syntax path-str k)
(-> path-string? (-> syntax? any) any)
(define path (->path path-str))
(match (hash-ref cache path #f)
[(cache-entry stx _exp-stx _digest namespace load-rel-dir)
(log-racket-mode-syntax-cache-info "path->existing-syntax cache hit ~v (ignoring digest)" path)
(parameterize ([current-namespace namespace]
[current-load-relative-directory load-rel-dir]
[current-directory load-rel-dir])
(k stx))]
[#f
(log-racket-mode-syntax-cache-warning "path->existing-syntax cache MISS ~v (ignoring digest)" path)
#f]))
;; Like string->expanded-syntax but given only the path-str and only
;; if expanded syntax already in the cache, as a result of previously
;; calling string->expanded-syntax. Intended for use by
;; identifier.rkt.
(define/contract (path->existing-expanded-syntax path-str k)
(-> path-string? (-> syntax? any) any)
(define path (->path path-str))
(match (hash-ref cache path #f)
[(cache-entry _stx exp-stx _digest namespace load-rel-dir)
(log-racket-mode-syntax-cache-info "path->existing-expanded-syntax cache hit ~v (ignoring digest)" path)
(parameterize ([current-namespace namespace]
[current-load-relative-directory load-rel-dir]
[current-directory load-rel-dir])
(k exp-stx))]
[#f
(log-racket-mode-syntax-cache-warning "path->existing-expanded-syntax cache MISS ~v (ignoring digest)" path)
#f]))
(module+ test
(require rackunit
racket/file)
(define this-path (syntax-source #'here))
(define this-string (file->string this-path))
(check-equal? (file->digest this-path)
(string->digest this-string))
(check-equal? (file->expanded-syntax this-path values)
(string->expanded-syntax this-path this-string values))
(check-equal? (path->existing-expanded-syntax this-path (λ (_stx) 42))
42))
|
