forked from
jonmsterling.com/ocaml-forester
ocaml
Eval: consolidate the local effects into one reader
+56
-44
+56
-44
lib/compiler/Eval.ml
+56
-44
lib/compiler/Eval.ml
···
90
90
91
91
module Tape = Tape_effect.Make ()
92
92
93
-
module Lex_env = Algaeff.Reader.Make (struct
94
-
type t = Value.t String_map.t
95
-
end)
96
-
97
-
module Dyn_env = Algaeff.Reader.Make (struct
98
-
type t = Value.t Symbol_map.t
99
-
end)
100
-
101
-
module Config_env = Algaeff.Reader.Make (struct
102
-
type t = Config.t
103
-
end)
104
-
105
93
module Heap = Algaeff.State.Make (struct
106
94
type t = Value.obj Symbol_map.t
107
95
end)
···
118
106
type t = T.content T.frontmatter
119
107
end)
120
108
121
-
module Mode_env = Algaeff.Reader.Make (struct
122
-
type t = eval_mode
123
-
end)
109
+
type eval_env = {
110
+
mode: eval_mode;
111
+
config: Config.t;
112
+
lex_env: Value.t String_map.t;
113
+
dyn_env: Value.t Symbol_map.t;
114
+
}
115
+
116
+
let initial_eval_env config : eval_env =
117
+
{
118
+
mode = Text_mode;
119
+
config;
120
+
lex_env = String_map.empty;
121
+
dyn_env = Symbol_map.empty;
122
+
}
123
+
124
+
module Eval_env = struct
125
+
include Algaeff.Reader.Make (struct
126
+
type t = eval_env
127
+
end)
128
+
end
124
129
125
130
let get_current_uri ~loc =
126
131
match (Frontmatter.get ()).uri with
···
130
135
~extra_remarks:[Asai.Diagnostic.loctext "No uri for tree"]
131
136
132
137
let get_transclusion_flags ~loc =
133
-
let dynenv = Dyn_env.read () in
138
+
let {dyn_env; _} = Eval_env.read () in
134
139
let get_bool key =
135
-
let@ value = Option.map @~ Symbol_map.find_opt key dynenv in
140
+
let@ value = Option.map @~ Symbol_map.find_opt key dyn_env in
136
141
extract_bool @@ Range.locate_opt loc value
137
142
in
138
143
let module S = Expand.Builtins.Transclude in
···
155
160
treat it as a link to a local tree. *)
156
161
match (URI.scheme uri, URI.host uri, URI.path_components uri) with
157
162
| None, None, ([] | [_]) ->
158
-
let config = Config_env.read () in
163
+
let {config; _} = Eval_env.read () in
159
164
let uri = URI_scheme.named_uri ~base:config.url str in
160
165
Result.ok uri
161
166
| _ -> Ok uri
···
206
211
| Some node -> eval_node node
207
212
208
213
and eval_tape tape = Tape.run ~tape process_tape
214
+
209
215
and eval_pop_arg ~loc = Tape.pop_arg ~loc |> Range.map eval_tape
216
+
210
217
and pop_content_arg ~loc = eval_pop_arg ~loc |> extract_content
218
+
211
219
and pop_text_arg ~loc = eval_pop_arg ~loc |> extract_text
220
+
212
221
and pop_text_arg_loc ~loc = eval_pop_arg ~loc |> extract_text_loc
213
222
214
223
and eval_node node : Value.t =
···
222
231
in
223
232
emit_content_node ~loc @@ T.prim p @@ T.Content content
224
233
| Fun (xs, body) ->
225
-
let env = Lex_env.read () in
226
-
focus_clo ?loc env (List.map (fun (info, x) -> (info, Some x)) 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
227
236
| Ref -> begin
228
237
match eval_pop_arg ~loc |> extract_uri with
229
238
| Ok href ->
···
262
271
emit_content_node ~loc @@ Link {href; content}
263
272
| Math (mode, body) ->
264
273
let content =
265
-
let@ () = Mode_env.run ~env:TeX_mode in
274
+
let@ () = Eval_env.scope @@ fun env -> {env with mode = TeX_mode} in
266
275
{node with value = eval_tape body} |> extract_content
267
276
in
268
277
emit_content_node ~loc @@ KaTeX (mode, content)
···
284
293
let tex_cs_opt =
285
294
match path with [name] -> TeX_cs.parse name | _ -> None
286
295
in
287
-
begin match (Mode_env.read (), tex_cs_opt) with
296
+
let {mode; _} = Eval_env.read () in
297
+
begin match (mode, tex_cs_opt) with
288
298
| TeX_mode, Some (cs, rest) ->
289
299
emit_content_node ~loc
290
300
@@ T.Text (Format.asprintf "%a%s" pp_tex_cs cs rest)
···
309
319
emit_content_node ~loc @@ T.Transclude {href; target = Full flags}
310
320
| Subtree (addr_opt, nodes) ->
311
321
let flags = get_transclusion_flags ~loc in
312
-
let config = Config_env.read () in
322
+
let {config; _} = Eval_env.read () in
313
323
let uri =
314
324
match addr_opt with
315
325
| Some addr -> Some (URI_scheme.named_uri ~base:config.url addr)
···
343
353
end
344
354
| Syndicate_query_as_json_blob ->
345
355
let name = pop_text_arg ~loc in
346
-
let config = Config_env.read () in
356
+
let {config; _} = Eval_env.read () in
347
357
let blob_uri = URI_scheme.named_uri ~base:config.url @@ name ^ ".json" in
348
358
let query_arg = eval_pop_arg ~loc in
349
359
begin match query_arg.value with
···
367
377
Jobs.modify @@ List.cons @@ Range.locate_opt loc job;
368
378
process_tape ()
369
379
| Embed_tex ->
370
-
let config = Config_env.read () in
380
+
let {config; _} = Eval_env.read () in
371
381
let preamble, body =
372
-
let@ () = Mode_env.run ~env:TeX_mode in
382
+
let@ () = Eval_env.scope @@ fun env -> {env with mode = TeX_mode} in
373
383
let preamble = pop_content_arg ~loc |> TeX_like.string_of_content in
374
384
let body = pop_content_arg ~loc |> TeX_like.string_of_content in
375
385
(preamble, body)
···
415
425
emit_content_nodes ~loc @@ [T.Route_of_uri uri]
416
426
| Object {self; methods} ->
417
427
let table =
418
-
let env = Lex_env.read () in
428
+
let {lex_env;_} = Eval_env.read () in
419
429
let add (name, body) =
420
-
Value.Method_table.add name Value.{body; self; super = None; env}
430
+
Value.Method_table.add name Value.{body; self; super = None; env = lex_env}
421
431
in
422
432
List.fold_right add methods Value.Method_table.empty
423
433
in
···
429
439
{node with value = obj} |> Range.map eval_tape |> extract_obj_ptr
430
440
in
431
441
let table =
432
-
let env = Lex_env.read () in
442
+
let {lex_env;_} = Eval_env.read () in
433
443
let add (name, body) =
434
-
Value.Method_table.add name Value.{body; self; super; env}
444
+
Value.Method_table.add name Value.{body; self; super; env = lex_env}
435
445
in
436
446
List.fold_right add methods Value.Method_table.empty
437
447
in
···
454
464
let proto_val = obj.prototype |> Option.map @@ fun ptr -> Value.Obj ptr in
455
465
match Value.Method_table.find_opt method_name obj.methods with
456
466
| Some mthd ->
457
-
let env =
467
+
let lex_env =
458
468
let env =
459
469
match mthd.self with
460
470
| None -> mthd.env
···
467
477
| None -> env
468
478
| Some super -> String_map.add super proto_val env)
469
479
in
470
-
let@ () = Lex_env.run ~env in
480
+
let@ () = Eval_env.scope @@ fun env -> {env with lex_env} in
471
481
eval_tape mthd.body
472
482
| None -> (
473
483
match obj.prototype with
···
480
490
| Put (k, v, body) ->
481
491
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
482
492
let body =
483
-
let@ () = Dyn_env.scope (Symbol_map.add k (eval_tape v)) in
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
484
497
eval_tape body
485
498
in
486
499
focus ?loc:node.loc body
···
491
504
if Symbol_map.mem k flenv then flenv
492
505
else Symbol_map.add k (eval_tape v) flenv
493
506
in
494
-
let@ () = Dyn_env.scope upd in
507
+
let@ () =
508
+
Eval_env.scope @@ fun env -> {env with dyn_env = upd env.dyn_env}
509
+
in
495
510
eval_tape body
496
511
in
497
512
focus ?loc:node.loc body
498
513
| Get k ->
499
514
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
500
-
let env = Dyn_env.read () in
501
-
begin match Symbol_map.find_opt k env with
515
+
let {dyn_env; _} = Eval_env.read () in
516
+
begin match Symbol_map.find_opt k dyn_env with
502
517
| None -> Reporter.fatal ?loc:node.loc (Unbound_fluid_symbol k)
503
518
| Some v -> focus ?loc:node.loc v
504
519
end
···
640
655
emit_content_node ~loc:node.loc @@ T.Uri (get_current_uri ~loc:node.loc)
641
656
642
657
and eval_var ~loc (x : string) =
643
-
let env = Lex_env.read () in
644
-
match String_map.find_opt x env with
658
+
let {lex_env; _} = Eval_env.read () in
659
+
match String_map.find_opt x lex_env with
645
660
| Some v -> focus ?loc v
646
661
| None -> Reporter.fatal ?loc (Unbound_variable x)
647
662
···
672
687
| [] ->
673
688
focus ?loc
674
689
@@
675
-
let@ () = Lex_env.run ~env:rho in
690
+
let@ () = Eval_env.scope @@ fun env -> {env with lex_env = rho} in
676
691
eval_tape body
677
692
| (info, y) :: ys -> (
678
693
match Tape.pop_arg_opt () with
···
680
695
let yval =
681
696
match info with
682
697
| Strict -> eval_tape arg.value
683
-
| Lazy -> Clo (Lex_env.read (), [(Strict, None)], arg.value)
698
+
| Lazy -> Clo ((Eval_env.read ()).lex_env, [(Strict, None)], arg.value)
684
699
in
685
700
let rhoy =
686
701
match y with Some y -> String_map.add y yval rho | None -> rho
···
739
754
~emit:push
740
755
@@ fun () ->
741
756
let fm = T.default_frontmatter ~uri ?source_path () in
742
-
let@ () = Mode_env.run ~env:Text_mode in
757
+
let@ () = Eval_env.run ~env:(initial_eval_env config) in
743
758
let@ () = Frontmatter.run ~init:fm in
744
759
let@ () = Emitted_trees.run ~init:[] in
745
760
let@ () = Jobs.run ~init:[] in
746
761
let@ () = Heap.run ~init:Symbol_map.empty in
747
-
let@ () = Lex_env.run ~env:String_map.empty in
748
-
let@ () = Dyn_env.run ~env:Symbol_map.empty in
749
-
let@ () = Config_env.run ~env:config in
750
762
let main = eval_tree_inner ~uri tree in
751
763
let side = Emitted_trees.get () in
752
764
let jobs = Jobs.get () in