forked from
jonmsterling.com/ocaml-forester
ocaml
Restrict use of Symbol.t to dynamically bound things
+88
-78
+27
-20
lib/compiler/Eval.ml
+27
-20
lib/compiler/Eval.ml
···
10
10
open struct
11
11
module T = Types
12
12
module Env = Value.Env
13
+
module Symbol_map = Value.Symbol_map
13
14
type located = Value.t Range.located
14
15
end
15
16
···
73
74
74
75
module Tape = Tape_effect.Make ()
75
76
module Lex_env = Algaeff.Reader.Make(struct type t = Value.t Env.t end)
76
-
module Dyn_env = Algaeff.Reader.Make(struct type t = Value.t Env.t end)
77
+
module Dyn_env = Algaeff.Reader.Make(struct type t = Value.t Symbol_map.t end)
77
78
module Config_env = Algaeff.Reader.Make(struct type t = Config.t end)
78
-
module Heap = Algaeff.State.Make(struct type t = Value.obj Env.t end)
79
+
module Heap = Algaeff.State.Make(struct type t = Value.obj Symbol_map.t end)
79
80
module Emitted_trees = Algaeff.State.Make(struct type t = T.content T.article list end)
80
81
module Jobs = Algaeff.State.Make(struct type t = Job.job Range.located list end)
81
82
module Frontmatter = Algaeff.State.Make(struct type t = T.content T.frontmatter end)
···
89
90
let get_transclusion_flags ~loc =
90
91
let dynenv = Dyn_env.read () in
91
92
let get_bool key =
92
-
let@ value = Option.map @~ Env.find_opt key dynenv in
93
+
let@ value = Option.map @~ Symbol_map.find_opt key dynenv in
93
94
extract_bool @@ Range.locate_opt loc value
94
95
in
95
96
let module S = Expand.Builtins.Transclude in
···
185
186
emit_content_node ~loc @@ T.prim p @@ T.Content content
186
187
| Fun (xs, body) ->
187
188
let env = Lex_env.read () in
188
-
focus_clo ?loc env xs body
189
+
focus_clo ?loc env (List.map (fun (info, x) -> info, Some x) xs) body
189
190
| Ref ->
190
191
begin
191
192
match eval_pop_arg ~loc |> extract_uri with
···
360
361
let env = Lex_env.read () in
361
362
let add (name, body) =
362
363
let super = Symbol.fresh () in
363
-
Value.Method_table.add name Value.{body; self; super; env}
364
+
Value.Method_table.add name Value.{body; self; super = None; env}
364
365
in
365
366
List.fold_right add methods Value.Method_table.empty
366
367
in
367
368
let sym = Symbol.named ["obj"] in
368
-
Heap.modify @@ Env.add sym Value.{prototype = None; methods = table};
369
+
Heap.modify @@ Symbol_map.add sym Value.{prototype = None; methods = table};
369
370
focus ?loc: node.loc @@ Value.Obj sym
370
371
| Patch {obj; self; super; methods} ->
371
372
let obj_ptr = {node with value = obj} |> Range.map eval_tape |> extract_obj_ptr in
···
379
380
List.fold_right add methods Value.Method_table.empty
380
381
in
381
382
let sym = Symbol.named ["obj"] in
382
-
Heap.modify @@ Env.add sym Value.{prototype = Some obj_ptr; methods = table};
383
+
Heap.modify @@ Symbol_map.add sym Value.{prototype = Some obj_ptr; methods = table};
383
384
focus ?loc: node.loc @@ Value.Obj sym
384
385
| Group (d, body) ->
385
386
let l, r = delim_to_strings d in
···
395
396
match Value.Method_table.find_opt method_name obj.methods with
396
397
| Some mthd ->
397
398
let env =
398
-
let env = Env.add mthd.self (Value.Obj sym) mthd.env in
399
+
let env =
400
+
match mthd.self with
401
+
| None -> mthd.env
402
+
| Some self -> Env.add self (Value.Obj sym) mthd.env
403
+
in
399
404
match proto_val with
400
405
| None -> env
401
406
| Some proto_val ->
402
-
Env.add mthd.super proto_val env
407
+
match mthd.super with
408
+
| None -> env
409
+
| Some super -> Env.add super proto_val env
403
410
in
404
411
let@ () = Lex_env.run ~env in
405
412
eval_tape mthd.body
406
413
| None ->
407
414
match obj.prototype with
408
415
| Some proto ->
409
-
call_method @@ Env.find proto @@ Heap.get ()
416
+
call_method @@ Symbol_map.find proto @@ Heap.get ()
410
417
| None ->
411
418
Reporter.fatal
412
419
?loc: node.loc
413
420
(Unbound_method (method_name, obj))
414
421
in
415
-
let result = call_method @@ Env.find sym @@ Heap.get () in
422
+
let result = call_method @@ Symbol_map.find sym @@ Heap.get () in
416
423
focus ?loc: node.loc result
417
424
| Put (k, v, body) ->
418
425
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
419
426
let body =
420
-
let@ () = Dyn_env.scope (Env.add k (eval_tape v)) in
427
+
let@ () = Dyn_env.scope (Symbol_map.add k (eval_tape v)) in
421
428
eval_tape body
422
429
in
423
430
focus ?loc: node.loc body
424
431
| Default (k, v, body) ->
425
432
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
426
433
let body =
427
-
let upd flenv = if Env.mem k flenv then flenv else Env.add k (eval_tape v) flenv in
434
+
let upd flenv = if Symbol_map.mem k flenv then flenv else Symbol_map.add k (eval_tape v) flenv in
428
435
let@ () = Dyn_env.scope upd in
429
436
eval_tape body
430
437
in
···
433
440
let k = {node with value = k} |> Range.map eval_tape |> extract_sym in
434
441
let env = Dyn_env.read () in
435
442
begin
436
-
match Env.find_opt k env with
443
+
match Symbol_map.find_opt k env with
437
444
| None ->
438
445
Reporter.fatal
439
446
?loc: node.loc
···
558
565
| Current_tree ->
559
566
emit_content_node ~loc: node.loc @@ T.Uri (get_current_uri ~loc: node.loc)
560
567
561
-
and eval_var ~loc x =
568
+
and eval_var ~loc (x : string) =
562
569
let env = Lex_env.read () in
563
570
match Env.find_opt x env with
564
571
| Some v -> focus ?loc v
···
587
594
~extra_remarks: [Asai.Diagnostic.loctextf "Expected solitary node but got %a / %a" Value.pp v Value.pp v']
588
595
end
589
596
590
-
and focus_clo ?loc rho xs body =
597
+
and focus_clo ?loc rho (xs : string option binding list) body =
591
598
match xs with
592
599
| [] ->
593
600
focus ?loc @@
···
599
606
let yval =
600
607
match info with
601
608
| Strict -> eval_tape arg.value
602
-
| Lazy -> Clo (Lex_env.read (), [(Strict, Symbol.fresh ())], arg.value)
609
+
| Lazy -> Clo (Lex_env.read (), [(Strict, None)], arg.value)
603
610
in
604
-
let rhoy = Env.add y yval rho in
611
+
let rhoy = match y with Some y -> Env.add y yval rho | None -> rho in
605
612
focus_clo ?loc rhoy ys body
606
613
| None ->
607
614
begin
···
662
669
let@ () = Frontmatter.run ~init: fm in
663
670
let@ () = Emitted_trees.run ~init: [] in
664
671
let@ () = Jobs.run ~init: [] in
665
-
let@ () = Heap.run ~init: Env.empty in
672
+
let@ () = Heap.run ~init: Symbol_map.empty in
666
673
let@ () = Lex_env.run ~env: Env.empty in
667
-
let@ () = Dyn_env.run ~env: Env.empty in
674
+
let@ () = Dyn_env.run ~env: Symbol_map.empty in
668
675
let@ () = Config_env.run ~env: config in
669
676
let main = eval_tree_inner ~uri tree in
670
677
let side = Emitted_trees.get () in
+17
-21
lib/compiler/Expand.ml
+17
-21
lib/compiler/Expand.ml
···
158
158
Sc.include_singleton path @@ (Xmlns {prefix; xmlns}, node.loc);
159
159
expand_eff ~forest rest
160
160
| Object {self; methods} ->
161
-
let self, methods =
161
+
let methods =
162
162
let@ () = Sc.section [] in
163
-
let sym = Symbol.fresh () in
164
-
let var = Range.{value = Syn.Var sym; loc = node.loc} in (* TODO: correct the location *)
165
163
begin
166
164
let@ self = Option.iter @~ self in
167
-
Sc.import_singleton self @@ (Term [var], node.loc) (* TODO: correct the location*)
165
+
let var = Range.{value = Syn.Var self; loc = node.loc} in (* TODO: correct the location *)
166
+
Sc.import_singleton [self] @@ (Term [var], node.loc) (* TODO: correct the location*)
168
167
end;
169
-
sym, List.map (expand_method ~forest) methods
168
+
List.map (expand_method ~forest) methods
170
169
in
171
170
{node with value = Object {self; methods}} :: expand_eff ~forest rest
172
-
| Patch {obj; self; methods} ->
171
+
| Patch {obj; self; super; methods} ->
173
172
let obj = expand_eff ~forest obj in
174
-
let self, super, methods =
173
+
let methods =
175
174
let@ () = Sc.section [] in
176
-
let self_sym = Symbol.fresh () in
177
-
let super_sym = Symbol.fresh () in
178
-
let self_var = Range.locate_opt None @@ Syn.Var self_sym in
179
-
let super_var = Range.locate_opt None @@ Syn.Var super_sym in
180
175
begin
181
176
let@ self = Option.iter @~ self in
182
-
Sc.import_singleton self @@ (Term [self_var], node.loc);
183
-
(* TODO: correct location*)
184
-
Sc.import_singleton (self @ ["super"]) @@ (Term [super_var], node.loc)
177
+
let self_var = Range.locate_opt None @@ Syn.Var self in
178
+
Sc.import_singleton [self] @@ (Term [self_var], node.loc);
179
+
let@ super = Option.iter @~ super in
180
+
let super_var = Range.locate_opt None @@ Syn.Var super in
181
+
Sc.import_singleton [super] @@ (Term [super_var], node.loc)
185
182
end;
186
-
self_sym, super_sym, List.map (expand_method ~forest) methods
183
+
List.map (expand_method ~forest) methods
187
184
in
188
185
let patched = Syn.Patch {obj; self; super; methods} in
189
186
{node with value = patched} :: expand_eff ~forest rest
···
268
265
269
266
and expand_lambda ~forest loc (xs, body) =
270
267
let@ () = Sc.section [] in
271
-
let syms =
268
+
let xs =
272
269
let@ strategy, x = List.map @~ xs in
273
-
let sym = Symbol.named x in
274
-
let var = Range.locate_opt None @@ Syn.Var sym in
275
-
Sc.import_singleton x @@ (Term [var], loc);
276
-
strategy, sym
270
+
let var = Range.locate_opt None @@ Syn.Var x in
271
+
Sc.import_singleton [x] @@ (Term [var], loc);
272
+
strategy, x
277
273
in
278
-
Range.{value = Syn.Fun (syms, expand_eff ~forest body); loc}
274
+
Range.{value = Syn.Fun (xs, expand_eff ~forest body); loc}
279
275
280
276
let ignore_entered_range f x =
281
277
let open Effect.Deep in
+7
-6
lib/core/Code.ml
+7
-6
lib/core/Code.ml
···
9
9
open struct module T = Types end
10
10
11
11
type 'a _object = {
12
-
self: Trie.path option;
12
+
self: string option;
13
13
methods: (string * 'a) list
14
14
}
15
15
[@@deriving show, repr]
16
16
17
17
type 'a patch = {
18
18
obj: 'a;
19
-
self: Trie.path option;
19
+
self: string option;
20
+
super: string option;
20
21
methods: (string * 'a) list
21
22
}
22
23
[@@deriving show, repr]
···
30
31
| Hash_ident of string
31
32
| Xml_ident of string option * string
32
33
| Subtree of string option * t
33
-
| Let of Trie.path * Trie.path binding list * t
34
+
| Let of Trie.path * string binding list * t
34
35
| Open of Trie.path
35
36
| Scope of t
36
37
| Put of Trie.path * t
37
38
| Default of Trie.path * t
38
39
| Get of Trie.path
39
-
| Fun of Trie.path binding list * t
40
+
| Fun of string binding list * t
40
41
| Object of t _object
41
42
| Patch of t patch
42
43
| Call of t * string
43
44
| Import of visibility * string
44
-
| Def of Trie.path * Trie.path binding list * t
45
+
| Def of Trie.path * string binding list * t
45
46
| Decl_xmlns of string * string
46
47
| Alloc of Trie.path
47
48
| Namespace of Trie.path * t
···
94
95
| Fun (b, t) -> Fun (b, f t)
95
96
| Call (t, s) -> Call (f t, s)
96
97
| Object {self; methods} -> Object {self; methods = List.map (fun (s, t) -> (s, f t)) methods}
97
-
| Patch {obj; self; methods} -> Patch {obj = f obj; self; methods = List.map (fun (s, t) -> (s, f t)) methods}
98
+
| Patch {obj; self; super; methods} -> Patch {obj = f obj; self; super; methods = List.map (fun (s, t) -> (s, f t)) methods}
98
99
| Text _
99
100
| Verbatim _
100
101
| Ident _
+6
-5
lib/core/Code.mli
+6
-5
lib/core/Code.mli
···
19
19
| Subtree of string option * t
20
20
| Let of
21
21
Trie.path
22
-
* Trie.path binding list
22
+
* string binding list
23
23
* t
24
24
| Open of Trie.path
25
25
| Scope of t
26
26
| Put of Trie.path * t
27
27
| Default of Trie.path * t
28
28
| Get of Trie.path
29
-
| Fun of Trie.path binding list * t
29
+
| Fun of string binding list * t
30
30
| Object of t _object
31
31
| Patch of t patch
32
32
| Call of t * string
33
33
| Import of visibility * string
34
34
| Def of
35
35
Trie.path
36
-
* Trie.path binding list
36
+
* string binding list
37
37
* t
38
38
| Decl_xmlns of string * string
39
39
| Alloc of Trie.path
···
51
51
and t = node Range.located list
52
52
53
53
and 'a _object = {
54
-
self: Trie.path option;
54
+
self: string option;
55
55
methods: (string * 'a) list;
56
56
}
57
57
58
58
and 'a patch = {
59
59
obj: 'a;
60
-
self: Trie.path option;
60
+
self: string option;
61
+
super: string option;
61
62
methods: (string * 'a) list;
62
63
}
63
64
+2
-2
lib/core/Reporter.ml
+2
-2
lib/core/Reporter.ml
···
41
41
got: Value.t option;
42
42
expected: expected_value list
43
43
}
44
-
| Unbound_fluid_symbol of (Symbol.t * Value.t Value.Env.t)
45
-
| Unbound_lexical_symbol of (Symbol.t * Value.t Value.Env.t)
44
+
| Unbound_fluid_symbol of (Symbol.t * Value.t Value.Symbol_map.t)
45
+
| Unbound_lexical_symbol of (string * Value.t Value.Env.t)
46
46
| Unresolved_identifier of ((Sc.data, R.P.tag) Trie.t [@opaque]) * Trie.path
47
47
| Unresolved_xmlns of string
48
48
| Reference_error of URI.t
+2
-2
lib/core/Reporter.mli
+2
-2
lib/core/Reporter.mli
···
36
36
got: Value.t option;
37
37
expected: expected_value list
38
38
}
39
-
| Unbound_fluid_symbol of (Symbol.t * Value.t Value.Env.t)
40
-
| Unbound_lexical_symbol of (Symbol.t * Value.t Value.Env.t)
39
+
| Unbound_fluid_symbol of (Symbol.t * Value.t Value.Symbol_map.t)
40
+
| Unbound_lexical_symbol of (string * Value.t Value.Env.t)
41
41
| Unresolved_identifier of ((Resolver.Scope.data, Resolver.P.tag) Trie.t) * Trie.path
42
42
| Unresolved_xmlns of string
43
43
| Reference_error of URI.t
+4
-4
lib/core/Syn.ml
+4
-4
lib/core/Syn.ml
···
14
14
| Math of math_mode * t
15
15
| Link of {dest: t; title: t option}
16
16
| Subtree of string option * t
17
-
| Fun of Symbol.t binding list * t
18
-
| Var of Symbol.t
17
+
| Fun of string binding list * t
18
+
| Var of string
19
19
| Sym of Symbol.t
20
20
| Put of t * t * t
21
21
| Default of t * t * t
···
24
24
| TeX_cs of TeX_cs.t
25
25
| Unresolved_ident of ((resolver_data, Range.t option) Trie.t [@opaque]) * Trie.path
26
26
| Prim of Prim.t
27
-
| Object of {self: Symbol.t; methods: (string * t) list}
28
-
| Patch of {obj: t; self: Symbol.t; super: Symbol.t; methods: (string * t) list}
27
+
| Object of {self: string option; methods: (string * t) list}
28
+
| Patch of {obj: t; self: string option; super: string option; methods: (string * t) list}
29
29
| Call of t * string
30
30
| Results_of_query
31
31
| Transclude
+10
-6
lib/core/Value.ml
+10
-6
lib/core/Value.ml
···
9
9
10
10
open struct module T = Types end
11
11
12
-
module Env = struct
13
-
include Map.Make(Symbol)
12
+
module Make_env (S : sig include Map.OrderedType val pp : Format.formatter -> t -> unit end) = struct
13
+
include Map.Make(S)
14
14
let pp (pp_el : Format.formatter -> 'a -> unit) (fmt : Format.formatter) (map : 'a t) =
15
15
Format.fprintf fmt "@[<v1>{";
16
16
begin
17
17
let@ k, v = Seq.iter @~ to_seq map in
18
-
Format.fprintf fmt "@[%a ~> %a@]@;" Symbol.pp k pp_el v
18
+
Format.fprintf fmt "@[%a ~> %a@]@;" S.pp k pp_el v
19
19
end;
20
20
Format.fprintf fmt "}@]"
21
21
end
22
22
23
+
module Env = Make_env (struct include String let pp = Format.pp_print_string end)
24
+
module Symbol_map = Make_env (Symbol)
25
+
26
+
23
27
type t =
24
28
| Content of T.content
25
-
| Clo of t Env.t * Symbol.t binding list * Syn.t
29
+
| Clo of t Env.t * string option binding list * Syn.t
26
30
| Dx_prop of (string, T.content T.vertex) Datalog_expr.prop
27
31
| Dx_sequent of (string, T.content T.vertex) Datalog_expr.sequent
28
32
| Dx_query of (string, T.content T.vertex) Datalog_expr.query
···
34
38
35
39
type obj_method = {
36
40
body: Syn.t;
37
-
self: Symbol.t;
38
-
super: Symbol.t;
41
+
self: string option;
42
+
super: string option;
39
43
env: t Env.t
40
44
}
41
45
[@@deriving show]
+2
-2
lib/language_server/Analysis.ml
+2
-2
lib/language_server/Analysis.ml
···
30
30
List.concat_map Code.children tree
31
31
32
32
let paths_in_bindings =
33
-
List.map snd
33
+
List.map (fun (_, x) -> [x])
34
34
35
35
(* This function should not descend into the nodes!*)
36
36
let paths : Code.node Range.located -> _ = function
···
49
49
Some (path :: paths_in_bindings bindings, loc)
50
50
| Patch {self; _}
51
51
| Object {self; _;} ->
52
-
Option.map (fun path -> [path], loc) self
52
+
Option.map (fun x -> [[x]], loc) self
53
53
| Fun (bindings, _) -> Some (paths_in_bindings bindings, loc)
54
54
| Subtree _
55
55
| Group _
+1
-5
lib/language_server/Document_symbols.ml
+1
-5
lib/language_server/Document_symbols.ml
···
37
37
(* TODO: What should the symbol kind of a subtree be? *)
38
38
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Namespace ()
39
39
| Object {self; _} ->
40
-
let name =
41
-
match self with
42
-
| Some path -> Format.asprintf "%a" pp_path path
43
-
| None -> "anonymous"
44
-
in
40
+
let name = Option.value ~default: "anonymous" self in
45
41
Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Object ()
46
42
| Def (name, _, _) ->
47
43
let name = Format.asprintf "%a" pp_path name in
+9
-4
lib/parser/Grammar.mly
+9
-4
lib/parser/Grammar.mly
···
40
40
let parens(p) == delimited(LPAREN, p, RPAREN)
41
41
42
42
let bvar :=
43
-
| x = TEXT; { [x] }
43
+
| x = TEXT; { x }
44
44
45
45
let bvar_with_strictness :=
46
46
| x = TEXT; {
47
47
match String_util.explode x with
48
-
| '~' :: chars -> Lazy, [String_util.implode chars]
49
-
| _ -> Strict, [x]
48
+
| '~' :: chars -> Lazy, String_util.implode chars
49
+
| _ -> Strict, x
50
50
}
51
51
52
52
let binder == list(squares(bvar_with_strictness))
···
66
66
let code_expr == ws_list(locate(head_node1))
67
67
let textual_expr == list(locate(textual_node))
68
68
69
+
let patch_bindings :=
70
+
| self = squares(bvar); super = squares(bvar); { Some self, Some super }
71
+
| self = squares(bvar); { Some self, None }
72
+
| { None, None }
73
+
69
74
let head_node :=
70
75
| DEF; (~,~,~) = fun_spec; <Code.Def>
71
76
| ALLOC; ~ = ident; <Code.Alloc>
···
84
89
| (~,~) = XML_ELT_IDENT; <Code.Xml_ident>
85
90
| ~ = DECL_XMLNS; ~ = txt_arg; <Code.Decl_xmlns>
86
91
| OBJECT; self = option(squares(bvar)); methods = braces(ws_list(method_decl)); { Code.Object {self; methods } }
87
-
| PATCH; obj = braces(code_expr); self = option(squares(bvar)); methods = braces(ws_list(method_decl)); { Code.Patch {obj; self; methods} }
92
+
| PATCH; obj = braces(code_expr); (self, super) = patch_bindings; methods = braces(ws_list(method_decl)); { Code.Patch {obj; self; super; methods} }
88
93
| CALL; ~ = braces(code_expr); ~ = txt_arg; <Code.Call>
89
94
| DATALOG; LBRACE; list(WHITESPACE); ~ = dx_sequent_node; RBRACE; <>
90
95
| ~ = VERBATIM; <Code.Verbatim>