forked from
jonmsterling.com/ocaml-forester
ocaml
Remove Eval_env effects: just pass local environment as argument
+162
-168
+162
-168
lib/compiler/Eval.ml
+162
-168
lib/compiler/Eval.ml
···
121
121
dyn_env = Symbol_map.empty;
122
122
}
123
123
124
-
module Eval_env = struct
125
-
include Algaeff.Reader.Make (struct
126
-
type t = eval_env
127
-
end)
128
-
end
129
-
130
124
let get_current_uri ~loc =
131
125
match (Frontmatter.get ()).uri with
132
126
| Some uri -> uri
···
134
128
Reporter.fatal ?loc Internal_error
135
129
~extra_remarks:[Asai.Diagnostic.loctext "No uri for tree"]
136
130
137
-
let get_transclusion_flags ~loc =
138
-
let {dyn_env; _} = Eval_env.read () in
131
+
let get_transclusion_flags ~env ~loc =
139
132
let get_bool key =
140
-
let@ value = Option.map @~ Symbol_map.find_opt key dyn_env in
133
+
let@ value = Option.map @~ Symbol_map.find_opt key env.dyn_env in
141
134
extract_bool @@ Range.locate_opt loc value
142
135
in
143
136
let module S = Expand.Builtins.Transclude in
···
153
146
override (get_bool S.show_metadata_sym) flags.metadata_shown;
154
147
}
155
148
156
-
let resolve_uri ~loc:_ str =
149
+
let resolve_uri ~env ~loc:_ str =
157
150
match URI.of_string_exn str with
158
151
| uri -> (
159
152
(* If the URI is just a single component without anything else, we should
160
153
treat it as a link to a local tree. *)
161
154
match (URI.scheme uri, URI.host uri, URI.path_components uri) with
162
155
| None, None, ([] | [_]) ->
163
-
let {config; _} = Eval_env.read () in
164
-
let uri = URI_scheme.named_uri ~base:config.url str in
156
+
let uri = URI_scheme.named_uri ~base:env.config.url str in
165
157
Result.ok uri
166
158
| _ -> Ok uri
167
159
| exception _ -> Error "Invalid URI")
···
194
186
Reporter.fatal ?loc:node.loc
195
187
(Type_error {expected = [Dx_sequent]; got = Some other})
196
188
197
-
let extract_vertex ~type_ (node : located) =
189
+
let extract_vertex ~env ~type_ (node : located) =
198
190
match type_ with
199
191
| `Content -> Ok (T.Content_vertex (extract_content node))
200
192
| `Uri ->
201
-
let@ uri = Result.map @~ extract_uri node in
193
+
let@ uri = Result.map @~ extract_uri ~env node in
202
194
T.Uri_vertex uri
203
195
204
196
let pp_tex_cs fmt = function
205
197
| TeX_cs.Symbol x -> Format.fprintf fmt "\\%c" x
206
198
| TeX_cs.Word x -> Format.fprintf fmt "\\%s " x
207
199
208
-
let rec process_tape () =
200
+
let rec process_tape ~env () =
209
201
match Tape.pop_node_opt () with
210
202
| None -> Value.Content (T.Content [])
211
-
| Some node -> eval_node node
203
+
| Some node -> eval_node ~env node
212
204
213
-
and eval_tape tape = Tape.run ~tape process_tape
205
+
and eval_tape ~env tape = Tape.run ~tape (process_tape ~env)
214
206
215
-
and eval_pop_arg ~loc = Tape.pop_arg ~loc |> Range.map eval_tape
207
+
and eval_pop_arg ~env ~loc = Tape.pop_arg ~loc |> Range.map (eval_tape ~env)
216
208
217
-
and pop_content_arg ~loc = eval_pop_arg ~loc |> extract_content
209
+
and pop_content_arg ~env ~loc = eval_pop_arg ~env ~loc |> extract_content
218
210
219
-
and pop_text_arg ~loc = eval_pop_arg ~loc |> extract_text
211
+
and pop_text_arg ~env ~loc = eval_pop_arg ~env ~loc |> extract_text
220
212
221
-
and pop_text_arg_loc ~loc = eval_pop_arg ~loc |> extract_text_loc
213
+
and pop_text_arg_loc ~env ~loc = eval_pop_arg ~env ~loc |> extract_text_loc
222
214
223
-
and eval_node node : Value.t =
215
+
and eval_node ~env node : Value.t =
224
216
let loc = node.loc in
225
217
match node.value with
226
-
| Var x -> eval_var ~loc x
227
-
| Text str -> emit_content_node ~loc @@ T.Text str
218
+
| Var x -> eval_var ~env ~loc x
219
+
| Text str -> emit_content_node ~env ~loc @@ T.Text str
228
220
| Prim p ->
229
221
let content =
230
-
pop_content_arg ~loc |> T.extract_content |> T.trim_whitespace
222
+
pop_content_arg ~env ~loc |> T.extract_content |> T.trim_whitespace
231
223
in
232
-
emit_content_node ~loc @@ T.prim p @@ T.Content content
224
+
emit_content_node ~env ~loc @@ T.prim p @@ T.Content content
233
225
| Fun (xs, body) ->
234
-
let {lex_env; _}= Eval_env.read () in
235
-
focus_clo ?loc lex_env (List.map (fun (info, x) -> (info, Some x)) xs) body
226
+
focus_clo ~env ?loc env.lex_env
227
+
(List.map (fun (info, x) -> (info, Some x)) xs)
228
+
body
236
229
| Ref -> begin
237
-
match eval_pop_arg ~loc |> extract_uri with
230
+
match eval_pop_arg ~env ~loc |> extract_uri ~env with
238
231
| Ok href ->
239
232
let content =
240
233
T.Content
···
244
237
T.Contextual_number href;
245
238
]
246
239
in
247
-
emit_content_node ~loc @@ Link {href; content}
240
+
emit_content_node ~env ~loc @@ Link {href; content}
248
241
| Error _ ->
249
242
Reporter.fatal ?loc
250
243
(Type_error {got = None; expected = [URI]})
251
244
~extra_remarks:[Asai.Diagnostic.loctextf "Expected valid URI in ref"]
252
245
end
253
246
| Link {title; dest} ->
254
-
let dest = {node with value = dest} |> Range.map eval_tape in
247
+
let dest = {node with value = dest} |> Range.map (eval_tape ~env) in
255
248
let href =
256
-
match extract_uri dest with
249
+
match extract_uri ~env dest with
257
250
| Ok uri -> uri
258
251
| Error error ->
259
252
Reporter.fatal ?loc
···
266
259
| None ->
267
260
T.Content
268
261
[T.Transclude {href; target = T.Title {empty_when_untitled = false}}]
269
-
| Some title -> {node with value = eval_tape title} |> extract_content
262
+
| Some title ->
263
+
{node with value = eval_tape ~env title} |> extract_content
270
264
in
271
-
emit_content_node ~loc @@ Link {href; content}
265
+
emit_content_node ~env ~loc @@ Link {href; content}
272
266
| Math (mode, body) ->
273
267
let content =
274
-
let@ () = Eval_env.scope @@ fun env -> {env with mode = TeX_mode} in
275
-
{node with value = eval_tape body} |> extract_content
268
+
{node with value = eval_tape ~env:{env with mode = TeX_mode} body}
269
+
|> extract_content
276
270
in
277
-
emit_content_node ~loc @@ KaTeX (mode, content)
271
+
emit_content_node ~env ~loc @@ KaTeX (mode, content)
278
272
| Xml_tag (name, attrs, body) ->
279
273
let rec process : _ list -> _ T.xml_attr list = function
280
274
| [] -> []
281
275
| (key, v) :: attrs ->
282
-
{T.key; value = extract_content {node with value = eval_tape v}}
276
+
{T.key; value = extract_content {node with value = eval_tape ~env v}}
283
277
:: process attrs
284
278
in
285
279
let name =
286
280
T.{prefix = name.prefix; uname = name.uname; xmlns = name.xmlns}
287
281
in
288
-
let content = {node with value = eval_tape body} |> extract_content in
289
-
emit_content_node ~loc @@ T.Xml_elt {name; attrs = process attrs; content}
282
+
let content = {node with value = eval_tape ~env body} |> extract_content in
283
+
emit_content_node ~env ~loc
284
+
@@ T.Xml_elt {name; attrs = process attrs; content}
290
285
| TeX_cs cs ->
291
-
emit_content_node ~loc @@ T.Text (Format.asprintf "%a" pp_tex_cs cs)
286
+
emit_content_node ~env ~loc @@ T.Text (Format.asprintf "%a" pp_tex_cs cs)
292
287
| Unresolved_ident (visible, path) ->
293
288
let tex_cs_opt =
294
289
match path with [name] -> TeX_cs.parse name | _ -> None
295
290
in
296
-
let {mode; _} = Eval_env.read () in
297
-
begin match (mode, tex_cs_opt) with
291
+
begin match (env.mode, tex_cs_opt) with
298
292
| TeX_mode, Some (cs, rest) ->
299
-
emit_content_node ~loc
293
+
emit_content_node ~env ~loc
300
294
@@ T.Text (Format.asprintf "%a%s" pp_tex_cs cs rest)
301
295
| _, _ ->
302
296
let extra_remarks = Suggestions.create_suggestions ~visible path in
303
297
Reporter.emit ?loc ~extra_remarks (Unresolved_identifier (visible, path));
304
-
emit_content_node ~loc
298
+
emit_content_node ~env ~loc
305
299
@@ T.Text (Format.asprintf "\\%a" Resolver.Scope.pp_path path)
306
300
end
307
301
| Transclude ->
308
-
let flags = get_transclusion_flags ~loc in
309
-
let href_arg = eval_pop_arg ~loc in
302
+
let flags = get_transclusion_flags ~env ~loc in
303
+
let href_arg = eval_pop_arg ~env ~loc in
310
304
let href =
311
-
match extract_uri href_arg with
305
+
match extract_uri ~env href_arg with
312
306
| Ok uri -> uri
313
307
| Error _ ->
314
308
Reporter.fatal ?loc
···
316
310
~extra_remarks:
317
311
[Asai.Diagnostic.loctext "Expected valid URI in transclusion"]
318
312
in
319
-
emit_content_node ~loc @@ T.Transclude {href; target = Full flags}
313
+
emit_content_node ~env ~loc @@ T.Transclude {href; target = Full flags}
320
314
| Subtree (addr_opt, nodes) ->
321
-
let flags = get_transclusion_flags ~loc in
322
-
let {config; _} = Eval_env.read () in
315
+
let flags = get_transclusion_flags ~env ~loc in
323
316
let uri =
324
317
match addr_opt with
325
-
| Some addr -> Some (URI_scheme.named_uri ~base:config.url addr)
318
+
| Some addr -> Some (URI_scheme.named_uri ~base:env.config.url addr)
326
319
| None -> None
327
320
in
328
-
let subtree = eval_tree_inner ?uri nodes in
321
+
let subtree = eval_tree_inner ~env ?uri nodes in
329
322
let frontmatter = Frontmatter.get () in
330
323
let subtree =
331
324
{
···
338
331
| Some uri ->
339
332
Emitted_trees.modify @@ List.cons subtree;
340
333
let transclusion = T.{href = uri; target = Full flags} in
341
-
emit_content_node ~loc @@ Transclude transclusion
334
+
emit_content_node ~env ~loc @@ Transclude transclusion
342
335
| None ->
343
-
emit_content_node ~loc @@ T.Section (T.article_to_section ~flags subtree)
336
+
emit_content_node ~env ~loc
337
+
@@ T.Section (T.article_to_section ~flags subtree)
344
338
end
345
339
| Results_of_query ->
346
-
let arg = eval_pop_arg ~loc in
340
+
let arg = eval_pop_arg ~env ~loc in
347
341
begin match arg.value with
348
342
| Value.Dx_query query ->
349
-
emit_content_node ~loc @@ Results_of_datalog_query query
343
+
emit_content_node ~env ~loc @@ Results_of_datalog_query query
350
344
| other ->
351
345
Reporter.fatal ?loc:arg.loc
352
346
(Type_error {expected = [Dx_query]; got = Some other})
353
347
end
354
348
| Syndicate_query_as_json_blob ->
355
-
let name = pop_text_arg ~loc in
356
-
let {config; _} = Eval_env.read () in
357
-
let blob_uri = URI_scheme.named_uri ~base:config.url @@ name ^ ".json" in
358
-
let query_arg = eval_pop_arg ~loc in
349
+
let name = pop_text_arg ~env ~loc in
350
+
let blob_uri =
351
+
URI_scheme.named_uri ~base:env.config.url @@ name ^ ".json"
352
+
in
353
+
let query_arg = eval_pop_arg ~env ~loc in
359
354
begin match query_arg.value with
360
355
| Dx_query query ->
361
356
let job = Job.Syndicate (Json_blob {blob_uri; query}) in
362
357
Jobs.modify @@ List.cons @@ Range.locate_opt loc job;
363
-
process_tape ()
358
+
process_tape ~env ()
364
359
| other ->
365
360
Reporter.fatal ?loc:query_arg.loc
366
361
(Type_error {expected = [Dx_query]; got = Some other})
···
375
370
in
376
371
let job = Job.Syndicate (Atom_feed {source_uri; feed_uri}) in
377
372
Jobs.modify @@ List.cons @@ Range.locate_opt loc job;
378
-
process_tape ()
373
+
process_tape ~env ()
379
374
| Embed_tex ->
380
-
let {config; _} = Eval_env.read () in
381
375
let preamble, body =
382
-
let@ () = Eval_env.scope @@ fun env -> {env with mode = TeX_mode} in
383
-
let preamble = pop_content_arg ~loc |> TeX_like.string_of_content in
384
-
let body = pop_content_arg ~loc |> TeX_like.string_of_content in
376
+
let env = {env with mode = TeX_mode} in
377
+
let preamble = pop_content_arg ~env ~loc |> TeX_like.string_of_content in
378
+
let body = pop_content_arg ~env ~loc |> TeX_like.string_of_content in
385
379
(preamble, body)
386
380
in
387
381
let source = LaTeX_template.to_string ~preamble ~body in
388
382
let hash = Digest.to_hex @@ Digest.string source in
389
383
let job = Job.{hash; source} in
390
-
let uri = Job.uri_for_latex_to_svg_job ~base:config.url job in
384
+
let uri = Job.uri_for_latex_to_svg_job ~base:env.config.url job in
391
385
let content =
392
386
T.Content
393
387
[
···
418
412
in
419
413
let artefact = T.{hash; content; sources} in
420
414
Jobs.modify (List.cons (Range.locate_opt loc (Job.LaTeX_to_svg job)));
421
-
emit_content_node ~loc @@ T.Artefact artefact
415
+
emit_content_node ~env ~loc @@ T.Artefact artefact
422
416
| Route_asset ->
423
-
let Range.{value = source_path; loc = path_loc} = pop_text_arg_loc ~loc in
417
+
let Range.{value = source_path; loc = path_loc} =
418
+
pop_text_arg_loc ~env ~loc
419
+
in
424
420
let uri = Asset_router.uri_of_asset ?loc:path_loc ~source_path () in
425
-
emit_content_nodes ~loc @@ [T.Route_of_uri uri]
421
+
emit_content_nodes ~env ~loc @@ [T.Route_of_uri uri]
426
422
| Object {self; methods} ->
427
423
let table =
428
-
let {lex_env;_} = Eval_env.read () in
429
424
let add (name, body) =
430
-
Value.Method_table.add name Value.{body; self; super = None; env = lex_env}
425
+
Value.Method_table.add name
426
+
Value.{body; self; super = None; env = env.lex_env}
431
427
in
432
428
List.fold_right add methods Value.Method_table.empty
433
429
in
434
430
let sym = Symbol.named ["obj"] in
435
431
Heap.modify @@ Symbol_map.add sym Value.{prototype = None; methods = table};
436
-
focus ?loc:node.loc @@ Value.Obj sym
432
+
focus ~env ?loc:node.loc @@ Value.Obj sym
437
433
| Patch {obj; self; super; methods} ->
438
434
let obj_ptr =
439
-
{node with value = obj} |> Range.map eval_tape |> extract_obj_ptr
435
+
{node with value = obj} |> Range.map (eval_tape ~env) |> extract_obj_ptr
440
436
in
441
437
let table =
442
-
let {lex_env;_} = Eval_env.read () in
443
438
let add (name, body) =
444
-
Value.Method_table.add name Value.{body; self; super; env = lex_env}
439
+
Value.Method_table.add name Value.{body; self; super; env = env.lex_env}
445
440
in
446
441
List.fold_right add methods Value.Method_table.empty
447
442
in
448
443
let sym = Symbol.named ["obj"] in
449
444
Heap.modify
450
445
@@ Symbol_map.add sym Value.{prototype = Some obj_ptr; methods = table};
451
-
focus ?loc:node.loc @@ Value.Obj sym
446
+
focus ~env ?loc:node.loc @@ Value.Obj sym
452
447
| Group (d, body) ->
453
448
let l, r = delim_to_strings d in
454
449
let content =
455
-
let body = extract_content {node with value = eval_tape body} in
450
+
let body = extract_content {node with value = eval_tape ~env body} in
456
451
T.Content ((T.Text l :: T.extract_content body) @ [T.Text r])
457
452
in
458
-
focus ?loc:node.loc @@ Value.Content (T.compress_content content)
453
+
focus ~env ?loc:node.loc @@ Value.Content (T.compress_content content)
459
454
| Call (obj, method_name) ->
460
455
let sym =
461
-
{node with value = obj} |> Range.map eval_tape |> extract_obj_ptr
456
+
{node with value = obj} |> Range.map (eval_tape ~env) |> extract_obj_ptr
462
457
in
463
-
let rec call_method (obj : Value.obj) =
458
+
let rec call_method ~env (obj : Value.obj) =
464
459
let proto_val = obj.prototype |> Option.map @@ fun ptr -> Value.Obj ptr in
465
460
match Value.Method_table.find_opt method_name obj.methods with
466
461
| Some mthd ->
···
477
472
| None -> env
478
473
| Some super -> String_map.add super proto_val env)
479
474
in
480
-
let@ () = Eval_env.scope @@ fun env -> {env with lex_env} in
481
-
eval_tape mthd.body
475
+
eval_tape ~env:{env with lex_env} mthd.body
482
476
| None -> (
483
477
match obj.prototype with
484
-
| Some proto -> call_method @@ Symbol_map.find proto @@ Heap.get ()
478
+
| Some proto -> call_method ~env @@ Symbol_map.find proto @@ Heap.get ()
485
479
| None ->
486
480
Reporter.fatal ?loc:node.loc (Unbound_method (method_name, obj)))
487
481
in
488
-
let result = call_method @@ Symbol_map.find sym @@ Heap.get () in
489
-
focus ?loc:node.loc result
482
+
let result = call_method ~env @@ Symbol_map.find sym @@ Heap.get () in
483
+
focus ~env ?loc:node.loc result
490
484
| Put (k, v, body) ->
491
-
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
485
+
let k =
486
+
{node with value = k} |> Range.map (eval_tape ~env) |> extract_sym
487
+
in
492
488
let body =
493
-
let@ () =
494
-
Eval_env.scope @@ fun env ->
495
-
{env with dyn_env = Symbol_map.add k (eval_tape v) env.dyn_env}
496
-
in
497
-
eval_tape body
489
+
eval_tape
490
+
~env:
491
+
{env with dyn_env = Symbol_map.add k (eval_tape ~env v) env.dyn_env}
492
+
body
498
493
in
499
-
focus ?loc:node.loc body
494
+
focus ~env ?loc:node.loc body
500
495
| Default (k, v, body) ->
501
-
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
496
+
let k =
497
+
{node with value = k} |> Range.map (eval_tape ~env) |> extract_sym
498
+
in
502
499
let body =
503
500
let upd flenv =
504
501
if Symbol_map.mem k flenv then flenv
505
-
else Symbol_map.add k (eval_tape v) flenv
502
+
else Symbol_map.add k (eval_tape ~env v) flenv
506
503
in
507
-
let@ () =
508
-
Eval_env.scope @@ fun env -> {env with dyn_env = upd env.dyn_env}
509
-
in
510
-
eval_tape body
504
+
eval_tape ~env:{env with dyn_env = upd env.dyn_env} body
511
505
in
512
-
focus ?loc:node.loc body
506
+
focus ~env ?loc:node.loc body
513
507
| Get k ->
514
-
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
515
-
let {dyn_env; _} = Eval_env.read () in
516
-
begin match Symbol_map.find_opt k dyn_env with
508
+
let k =
509
+
{node with value = k} |> Range.map (eval_tape ~env) |> extract_sym
510
+
in
511
+
begin match Symbol_map.find_opt k env.dyn_env with
517
512
| None -> Reporter.fatal ?loc:node.loc (Unbound_fluid_symbol k)
518
-
| Some v -> focus ?loc:node.loc v
513
+
| Some v -> focus ~env ?loc:node.loc v
519
514
end
520
-
| Verbatim str -> emit_content_node ~loc @@ CDATA str
515
+
| Verbatim str -> emit_content_node ~env ~loc @@ CDATA str
521
516
| Title ->
522
-
let title = pop_content_arg ~loc in
517
+
let title = pop_content_arg ~env ~loc in
523
518
Frontmatter.modify (fun fm -> {fm with title = Some title});
524
-
process_tape ()
519
+
process_tape ~env ()
525
520
| Parent ->
526
-
let parent_arg = eval_pop_arg ~loc in
521
+
let parent_arg = eval_pop_arg ~env ~loc in
527
522
let parent =
528
-
match extract_uri parent_arg with
523
+
match extract_uri ~env parent_arg with
529
524
| Ok uri -> uri
530
525
| Error _ ->
531
526
Reporter.fatal ?loc Invalid_URI
···
533
528
[Asai.Diagnostic.loctext "Expected valid URI in parent declaration"]
534
529
in
535
530
Frontmatter.modify (fun fm -> {fm with designated_parent = Some parent});
536
-
process_tape ()
531
+
process_tape ~env ()
537
532
| Meta ->
538
-
let k = pop_text_arg ~loc in
539
-
let v = pop_content_arg ~loc in
533
+
let k = pop_text_arg ~env ~loc in
534
+
let v = pop_content_arg ~env ~loc in
540
535
Frontmatter.modify (fun fm -> {fm with metas = fm.metas @ [(k, v)]});
541
-
process_tape ()
536
+
process_tape ~env ()
542
537
| Attribution (role, type_) ->
543
-
let arg = eval_pop_arg ~loc in
538
+
let arg = eval_pop_arg ~env ~loc in
544
539
let vertex =
545
-
match extract_vertex ~type_ arg with
540
+
match extract_vertex ~env ~type_ arg with
546
541
| Ok vtx -> vtx
547
542
| Error _ ->
548
543
let corrected_attribution_code =
···
563
558
let attribution = T.{role; vertex} in
564
559
Frontmatter.modify (fun fm ->
565
560
{fm with attributions = fm.attributions @ [attribution]});
566
-
process_tape ()
561
+
process_tape ~env ()
567
562
| Tag type_ ->
568
-
let arg = eval_pop_arg ~loc in
563
+
let arg = eval_pop_arg ~env ~loc in
569
564
let vertex =
570
-
match extract_vertex ~type_ arg with
565
+
match extract_vertex ~env ~type_ arg with
571
566
| Ok vtx -> vtx
572
567
| Error _ ->
573
568
let corrected = "\\tag/content" in
···
582
577
T.Content_vertex (extract_content arg)
583
578
in
584
579
Frontmatter.modify (fun fm -> {fm with tags = fm.tags @ [vertex]});
585
-
process_tape ()
580
+
process_tape ~env ()
586
581
| Date ->
587
-
let date_str = pop_text_arg ~loc in
582
+
let date_str = pop_text_arg ~env ~loc in
588
583
begin match Human_datetime.parse_string date_str with
589
584
| None ->
590
585
Reporter.fatal ?loc:node.loc Parse_error
···
592
587
[Asai.Diagnostic.loctextf "Invalid date string `%s`" date_str]
593
588
| Some date ->
594
589
Frontmatter.modify (fun fm -> {fm with dates = fm.dates @ [date]});
595
-
process_tape ()
590
+
process_tape ~env ()
596
591
end
597
592
| Number ->
598
-
let num = pop_text_arg ~loc in
593
+
let num = pop_text_arg ~env ~loc in
599
594
Frontmatter.modify (fun fm -> {fm with number = Some num});
600
-
process_tape ()
595
+
process_tape ~env ()
601
596
| Taxon ->
602
-
let taxon = Some (pop_content_arg ~loc) in
597
+
let taxon = Some (pop_content_arg ~env ~loc) in
603
598
Frontmatter.modify (fun fm -> {fm with taxon});
604
-
process_tape ()
605
-
| Sym sym -> focus ?loc:node.loc @@ Value.Sym sym
599
+
process_tape ~env ()
600
+
| Sym sym -> focus ~env ?loc:node.loc @@ Value.Sym sym
606
601
| Dx_prop (rel, args) ->
607
-
let rel = {node with value = eval_tape rel} |> extract_text in
602
+
let rel = {node with value = eval_tape ~env rel} |> extract_text in
608
603
let args =
609
604
let@ arg = List.map @~ args in
610
-
{node with value = eval_tape arg} |> extract_dx_term
605
+
{node with value = eval_tape ~env arg} |> extract_dx_term
611
606
in
612
-
focus ?loc:node.loc @@ Dx_prop {rel; args}
607
+
focus ~env ?loc:node.loc @@ Dx_prop {rel; args}
613
608
| Dx_sequent (conclusion, premises) ->
614
609
let conclusion =
615
-
{node with value = eval_tape conclusion} |> extract_dx_prop
610
+
{node with value = eval_tape ~env conclusion} |> extract_dx_prop
616
611
in
617
612
let premises =
618
613
let@ premise = List.map @~ premises in
619
-
{node with value = eval_tape premise} |> extract_dx_prop
614
+
{node with value = eval_tape ~env premise} |> extract_dx_prop
620
615
in
621
-
focus ?loc:node.loc @@ Dx_sequent {conclusion; premises}
616
+
focus ~env ?loc:node.loc @@ Dx_sequent {conclusion; premises}
622
617
| Dx_query (var, positives, negatives) ->
623
618
let positives =
624
619
let@ premise = List.map @~ positives in
625
-
{node with value = eval_tape premise} |> extract_dx_prop
620
+
{node with value = eval_tape ~env premise} |> extract_dx_prop
626
621
in
627
622
let negatives =
628
623
let@ premise = List.map @~ negatives in
629
-
{node with value = eval_tape premise} |> extract_dx_prop
624
+
{node with value = eval_tape ~env premise} |> extract_dx_prop
630
625
in
631
-
focus ?loc:node.loc @@ Dx_query {var; positives; negatives}
632
-
| Dx_var name -> focus ?loc:node.loc @@ Dx_var name
626
+
focus ~env ?loc:node.loc @@ Dx_query {var; positives; negatives}
627
+
| Dx_var name -> focus ~env ?loc:node.loc @@ Dx_var name
633
628
| Dx_const (type_, arg) ->
634
-
let arg = {node with value = eval_tape arg} in
629
+
let arg = {node with value = eval_tape ~env arg} in
635
630
let const =
636
631
match type_ with
637
632
| `Content -> T.Content_vertex (extract_content arg)
638
633
| `Uri -> begin
639
-
match extract_uri arg with
634
+
match extract_uri ~env arg with
640
635
| Ok uri -> T.Uri_vertex uri
641
636
| Error _ ->
642
637
Reporter.fatal ?loc:node.loc Invalid_URI
···
647
642
]
648
643
end
649
644
in
650
-
focus ?loc:node.loc @@ Dx_const const
645
+
focus ~env ?loc:node.loc @@ Dx_const const
651
646
| Dx_execute ->
652
-
let script = eval_pop_arg ~loc:node.loc |> extract_dx_sequent in
653
-
emit_content_node ~loc:node.loc @@ T.Datalog_script [script]
647
+
let script = eval_pop_arg ~env ~loc:node.loc |> extract_dx_sequent in
648
+
emit_content_node ~env ~loc:node.loc @@ T.Datalog_script [script]
654
649
| Current_tree ->
655
-
emit_content_node ~loc:node.loc @@ T.Uri (get_current_uri ~loc:node.loc)
650
+
emit_content_node ~env ~loc:node.loc
651
+
@@ T.Uri (get_current_uri ~loc:node.loc)
656
652
657
-
and eval_var ~loc (x : string) =
658
-
let {lex_env; _} = Eval_env.read () in
659
-
match String_map.find_opt x lex_env with
660
-
| Some v -> focus ?loc v
653
+
and eval_var ~env ~loc (x : string) =
654
+
match String_map.find_opt x env.lex_env with
655
+
| Some v -> focus ~env ?loc v
661
656
| None -> Reporter.fatal ?loc (Unbound_variable x)
662
657
663
-
and focus ?loc = function
664
-
| Clo (rho, xs, body) -> focus_clo ?loc rho xs body
658
+
and focus ~env ?loc = function
659
+
| Clo (rho, xs, body) -> focus_clo ~env ?loc rho xs body
665
660
| Content content -> begin
666
-
match process_tape () with
661
+
match process_tape ~env () with
667
662
| Content content' ->
668
663
Value.Content (T.concat_compressed_content content content')
669
664
| value -> value
670
665
end
671
666
| ( Sym _ | Obj _ | Dx_prop _ | Dx_sequent _ | Dx_query _ | Dx_var _
672
667
| Dx_const _ ) as v -> begin
673
-
match process_tape () with
668
+
match process_tape ~env () with
674
669
| Content content when T.strip_whitespace content = T.Content [] -> v
675
670
| v' ->
676
671
Reporter.fatal ?loc
···
682
677
]
683
678
end
684
679
685
-
and focus_clo ?loc rho (xs : string option binding list) body =
680
+
and focus_clo ~env ?loc rho (xs : string option binding list) body =
686
681
match xs with
687
-
| [] ->
688
-
focus ?loc
689
-
@@
690
-
let@ () = Eval_env.scope @@ fun env -> {env with lex_env = rho} in
691
-
eval_tape body
682
+
| [] -> focus ~env ?loc @@ eval_tape ~env:{env with lex_env = rho} body
692
683
| (info, y) :: ys -> (
693
684
match Tape.pop_arg_opt () with
694
685
| Some arg ->
695
686
let yval =
696
687
match info with
697
-
| Strict -> eval_tape arg.value
698
-
| Lazy -> Clo ((Eval_env.read ()).lex_env, [(Strict, None)], arg.value)
688
+
| Strict -> eval_tape ~env arg.value
689
+
| Lazy -> Clo (env.lex_env, [(Strict, None)], arg.value)
699
690
in
700
691
let rhoy =
701
692
match y with Some y -> String_map.add y yval rho | None -> rho
702
693
in
703
-
focus_clo ?loc rhoy ys body
694
+
focus_clo ~env ?loc rhoy ys body
704
695
| None -> begin
705
-
match process_tape () with
696
+
match process_tape ~env () with
706
697
| Content nodes when T.strip_whitespace nodes = T.Content [] ->
707
698
Clo (rho, xs, body)
708
699
| _ ->
···
714
705
]
715
706
end)
716
707
717
-
and emit_content_nodes ~loc content =
718
-
focus ?loc @@ Content (T.Content (T.compress_nodes content))
708
+
and emit_content_nodes ~env ~loc content =
709
+
focus ~env ?loc @@ Content (T.Content (T.compress_nodes content))
719
710
720
-
and emit_content_node ~loc content = emit_content_nodes ~loc [content]
711
+
and emit_content_node ~env ~loc content = emit_content_nodes ~env ~loc [content]
721
712
722
-
and eval_tree_inner ?(uri : URI.t option) (syn : Syn.t) : T.content T.article =
713
+
and eval_tree_inner ~env ?(uri : URI.t option) (syn : Syn.t) :
714
+
T.content T.article =
723
715
let attribution_is_author attr =
724
716
match T.(attr.role) with T.Author -> true | _ -> false
725
717
in
···
733
725
()
734
726
in
735
727
let@ () = Frontmatter.run ~init:frontmatter in
736
-
let mainmatter = {value = eval_tape syn; loc = None} |> extract_content in
728
+
let mainmatter =
729
+
{value = eval_tape ~env syn; loc = None} |> extract_content
730
+
in
737
731
let frontmatter = Frontmatter.get () in
738
732
let backmatter =
739
733
match uri with Some uri -> default_backmatter ~uri | None -> Content []
···
754
748
~emit:push
755
749
@@ fun () ->
756
750
let fm = T.default_frontmatter ~uri ?source_path () in
757
-
let@ () = Eval_env.run ~env:(initial_eval_env config) in
751
+
let env = initial_eval_env config in
758
752
let@ () = Frontmatter.run ~init:fm in
759
753
let@ () = Emitted_trees.run ~init:[] in
760
754
let@ () = Jobs.run ~init:[] in
761
755
let@ () = Heap.run ~init:Symbol_map.empty in
762
-
let main = eval_tree_inner ~uri tree in
756
+
let main = eval_tree_inner ~env ~uri tree in
763
757
let side = Emitted_trees.get () in
764
758
let jobs = Jobs.get () in
765
759
{articles = main :: side; jobs}