forked from
jonmsterling.com/ocaml-forester
ocaml
Use mutable state instead of effects in Eval
+51
-50
+45
-50
lib/compiler/Eval.ml
+45
-50
lib/compiler/Eval.ml
···
11
11
module T = Types
12
12
module String_map = Value.String_map
13
13
module Symbol_map = Value.Symbol_map
14
+
module Symbol_table = Value.Symbol_table
14
15
15
16
type located = Value.t Range.located
16
17
end
···
90
91
91
92
module Tape = Tape_effect.Make ()
92
93
93
-
module Heap = Algaeff.State.Make (struct
94
-
type t = Value.obj Symbol_map.t
95
-
end)
96
-
97
-
module Emitted_trees = Algaeff.State.Make (struct
98
-
type t = T.content T.article list
99
-
end)
100
-
101
-
module Jobs = Algaeff.State.Make (struct
102
-
type t = Job.job Range.located list
103
-
end)
104
-
105
-
module Frontmatter = Algaeff.State.Make (struct
106
-
type t = T.content T.frontmatter
107
-
end)
108
-
109
94
type eval_env = {
110
95
mode: eval_mode;
111
96
config: Config.t;
112
97
lex_env: Value.t String_map.t;
113
98
dyn_env: Value.t Symbol_map.t;
99
+
jobs: Job.job Range.located Stack.t;
100
+
emitted_trees: T.content T.article Stack.t;
101
+
heap: Value.obj Symbol_table.t;
102
+
mutable frontmatter: T.content T.frontmatter;
114
103
}
115
104
116
-
let initial_eval_env config : eval_env =
105
+
let initial_eval_env config frontmatter : eval_env =
117
106
{
118
107
mode = Text_mode;
119
108
config;
120
109
lex_env = String_map.empty;
121
110
dyn_env = Symbol_map.empty;
111
+
jobs = Stack.create ();
112
+
emitted_trees = Stack.create ();
113
+
heap = Symbol_table.create 100;
114
+
frontmatter;
122
115
}
123
116
124
-
let get_current_uri ~loc =
125
-
match (Frontmatter.get ()).uri with
117
+
let get_current_uri ~env ~loc =
118
+
match env.frontmatter.uri with
126
119
| Some uri -> uri
127
120
| None ->
128
121
Reporter.fatal ?loc Internal_error
···
319
312
| None -> None
320
313
in
321
314
let subtree = eval_tree_inner ~env ?uri nodes in
322
-
let frontmatter = Frontmatter.get () in
315
+
let frontmatter = env.frontmatter in
323
316
let subtree =
324
317
{
325
318
subtree with
···
329
322
in
330
323
begin match uri with
331
324
| Some uri ->
332
-
Emitted_trees.modify @@ List.cons subtree;
325
+
Stack.push subtree env.emitted_trees;
333
326
let transclusion = T.{href = uri; target = Full flags} in
334
327
emit_content_node ~env ~loc @@ Transclude transclusion
335
328
| None ->
···
354
347
begin match query_arg.value with
355
348
| Dx_query query ->
356
349
let job = Job.Syndicate (Json_blob {blob_uri; query}) in
357
-
Jobs.modify @@ List.cons @@ Range.locate_opt loc job;
350
+
Stack.push (Range.locate_opt loc job) env.jobs;
358
351
process_tape ~env ()
359
352
| other ->
360
353
Reporter.fatal ?loc:query_arg.loc
361
354
(Type_error {expected = [Dx_query]; got = Some other})
362
355
end
363
356
| Syndicate_current_tree_as_atom_feed ->
364
-
let source_uri = get_current_uri ~loc:node.loc in
357
+
let source_uri = get_current_uri ~env ~loc:node.loc in
365
358
let feed_uri =
366
359
let components =
367
360
URI.append_path_component (URI.path_components source_uri) "atom.xml"
···
369
362
URI.with_path_components components source_uri
370
363
in
371
364
let job = Job.Syndicate (Atom_feed {source_uri; feed_uri}) in
372
-
Jobs.modify @@ List.cons @@ Range.locate_opt loc job;
365
+
Stack.push (Range.locate_opt loc job) env.jobs;
373
366
process_tape ~env ()
374
367
| Embed_tex ->
375
368
let preamble, body =
···
411
404
]
412
405
in
413
406
let artefact = T.{hash; content; sources} in
414
-
Jobs.modify (List.cons (Range.locate_opt loc (Job.LaTeX_to_svg job)));
407
+
Stack.push (Range.locate_opt loc (Job.LaTeX_to_svg job)) env.jobs;
415
408
emit_content_node ~env ~loc @@ T.Artefact artefact
416
409
| Route_asset ->
417
410
let Range.{value = source_path; loc = path_loc} =
···
428
421
List.fold_right add methods Value.Method_table.empty
429
422
in
430
423
let sym = Symbol.named ["obj"] in
431
-
Heap.modify @@ Symbol_map.add sym Value.{prototype = None; methods = table};
424
+
Symbol_table.replace env.heap sym Value.{prototype = None; methods = table};
432
425
focus ~env ?loc:node.loc @@ Value.Obj sym
433
426
| Patch {obj; self; super; methods} ->
434
427
let obj_ptr =
···
441
434
List.fold_right add methods Value.Method_table.empty
442
435
in
443
436
let sym = Symbol.named ["obj"] in
444
-
Heap.modify
445
-
@@ Symbol_map.add sym Value.{prototype = Some obj_ptr; methods = table};
437
+
Symbol_table.replace env.heap sym
438
+
Value.{prototype = Some obj_ptr; methods = table};
446
439
focus ~env ?loc:node.loc @@ Value.Obj sym
447
440
| Group (d, body) ->
448
441
let l, r = delim_to_strings d in
···
475
468
eval_tape ~env:{env with lex_env} mthd.body
476
469
| None -> (
477
470
match obj.prototype with
478
-
| Some proto -> call_method ~env @@ Symbol_map.find proto @@ Heap.get ()
471
+
| Some proto -> call_method ~env @@ Symbol_table.find env.heap proto
479
472
| None ->
480
473
Reporter.fatal ?loc:node.loc (Unbound_method (method_name, obj)))
481
474
in
482
-
let result = call_method ~env @@ Symbol_map.find sym @@ Heap.get () in
475
+
let result = call_method ~env @@ Symbol_table.find env.heap sym in
483
476
focus ~env ?loc:node.loc result
484
477
| Put (k, v, body) ->
485
478
let k =
···
515
508
| Verbatim str -> emit_content_node ~env ~loc @@ CDATA str
516
509
| Title ->
517
510
let title = pop_content_arg ~env ~loc in
518
-
Frontmatter.modify (fun fm -> {fm with title = Some title});
511
+
env.frontmatter <- {env.frontmatter with title = Some title};
519
512
process_tape ~env ()
520
513
| Parent ->
521
514
let parent_arg = eval_pop_arg ~env ~loc in
···
527
520
~extra_remarks:
528
521
[Asai.Diagnostic.loctext "Expected valid URI in parent declaration"]
529
522
in
530
-
Frontmatter.modify (fun fm -> {fm with designated_parent = Some parent});
523
+
env.frontmatter <- {env.frontmatter with designated_parent = Some parent};
531
524
process_tape ~env ()
532
525
| Meta ->
533
526
let k = pop_text_arg ~env ~loc in
534
527
let v = pop_content_arg ~env ~loc in
535
-
Frontmatter.modify (fun fm -> {fm with metas = fm.metas @ [(k, v)]});
528
+
env.frontmatter <-
529
+
{env.frontmatter with metas = env.frontmatter.metas @ [(k, v)]};
536
530
process_tape ~env ()
537
531
| Attribution (role, type_) ->
538
532
let arg = eval_pop_arg ~env ~loc in
···
556
550
T.Content_vertex (extract_content arg)
557
551
in
558
552
let attribution = T.{role; vertex} in
559
-
Frontmatter.modify (fun fm ->
560
-
{fm with attributions = fm.attributions @ [attribution]});
553
+
env.frontmatter <-
554
+
{
555
+
env.frontmatter with
556
+
attributions = env.frontmatter.attributions @ [attribution];
557
+
};
561
558
process_tape ~env ()
562
559
| Tag type_ ->
563
560
let arg = eval_pop_arg ~env ~loc in
···
576
573
];
577
574
T.Content_vertex (extract_content arg)
578
575
in
579
-
Frontmatter.modify (fun fm -> {fm with tags = fm.tags @ [vertex]});
576
+
env.frontmatter <-
577
+
{env.frontmatter with tags = env.frontmatter.tags @ [vertex]};
580
578
process_tape ~env ()
581
579
| Date ->
582
580
let date_str = pop_text_arg ~env ~loc in
···
586
584
~extra_remarks:
587
585
[Asai.Diagnostic.loctextf "Invalid date string `%s`" date_str]
588
586
| Some date ->
589
-
Frontmatter.modify (fun fm -> {fm with dates = fm.dates @ [date]});
587
+
env.frontmatter <-
588
+
{env.frontmatter with dates = env.frontmatter.dates @ [date]};
590
589
process_tape ~env ()
591
590
end
592
591
| Number ->
593
592
let num = pop_text_arg ~env ~loc in
594
-
Frontmatter.modify (fun fm -> {fm with number = Some num});
593
+
env.frontmatter <- {env.frontmatter with number = Some num};
595
594
process_tape ~env ()
596
595
| Taxon ->
597
596
let taxon = Some (pop_content_arg ~env ~loc) in
598
-
Frontmatter.modify (fun fm -> {fm with taxon});
597
+
env.frontmatter <- {env.frontmatter with taxon};
599
598
process_tape ~env ()
600
599
| Sym sym -> focus ~env ?loc:node.loc @@ Value.Sym sym
601
600
| Dx_prop (rel, args) ->
···
648
647
emit_content_node ~env ~loc:node.loc @@ T.Datalog_script [script]
649
648
| Current_tree ->
650
649
emit_content_node ~env ~loc:node.loc
651
-
@@ T.Uri (get_current_uri ~loc:node.loc)
650
+
@@ T.Uri (get_current_uri ~env ~loc:node.loc)
652
651
653
652
and eval_var ~env ~loc (x : string) =
654
653
match String_map.find_opt x env.lex_env with
···
715
714
let attribution_is_author attr =
716
715
match T.(attr.role) with T.Author -> true | _ -> false
717
716
in
718
-
let outer_frontmatter = Frontmatter.get () in
717
+
let outer_frontmatter = env.frontmatter in
719
718
let attributions =
720
719
List.filter attribution_is_author outer_frontmatter.attributions
721
720
in
···
724
723
?source_path:outer_frontmatter.source_path ~dates:outer_frontmatter.dates
725
724
()
726
725
in
727
-
let@ () = Frontmatter.run ~init:frontmatter in
726
+
let env = {env with frontmatter} in
728
727
let mainmatter =
729
728
{value = eval_tape ~env syn; loc = None} |> extract_content
730
729
in
731
-
let frontmatter = Frontmatter.get () in
730
+
let frontmatter = env.frontmatter in
732
731
let backmatter =
733
732
match uri with Some uri -> default_backmatter ~uri | None -> Content []
734
733
in
···
748
747
~emit:push
749
748
@@ fun () ->
750
749
let fm = T.default_frontmatter ~uri ?source_path () in
751
-
let env = initial_eval_env config in
752
-
let@ () = Frontmatter.run ~init:fm in
753
-
let@ () = Emitted_trees.run ~init:[] in
754
-
let@ () = Jobs.run ~init:[] in
755
-
let@ () = Heap.run ~init:Symbol_map.empty in
750
+
let env = initial_eval_env config fm in
756
751
let main = eval_tree_inner ~env ~uri tree in
757
-
let side = Emitted_trees.get () in
758
-
let jobs = Jobs.get () in
752
+
let side = env.emitted_trees |> Stack.to_seq |> List.of_seq in
753
+
let jobs = env.jobs |> Stack.to_seq |> List.of_seq in
759
754
{articles = main :: side; jobs}
760
755
in
761
756
(res, !diagnostics)
+3
lib/core/Symbol.ml
+3
lib/core/Symbol.ml
···
8
8
9
9
let counter = ref 0
10
10
11
+
let hash = Hashtbl.hash
12
+
11
13
let named path =
12
14
counter := !counter + 1;
13
15
(path, !counter)
···
17
19
let pp fmt (sym, ix) = Format.fprintf fmt "%a@%i" Trie.pp_path sym ix
18
20
let show x = Format.asprintf "%a" pp x
19
21
let compare = compare
22
+
let equal = ( = )
20
23
let name (sym, _) = sym
21
24
let repr : t Repr.t = Repr.pair (Repr.list Repr.string) Repr.int
+2
lib/core/Symbol.mli
+2
lib/core/Symbol.mli