From a09f3fa237290d65c2718843afa1d62f49aaa1d2 Mon Sep 17 00:00:00 2001 From: Jon Sterling Date: Fri, 30 May 2025 17:51:33 +0100 Subject: [PATCH] Restrict use of Symbol.t to dynamically bound things --- lib/compiler/Eval.ml | 47 ++++++++++++++----------- lib/compiler/Expand.ml | 38 +++++++++----------- lib/core/Code.ml | 13 +++---- lib/core/Code.mli | 11 +++--- lib/core/Reporter.ml | 4 +-- lib/core/Reporter.mli | 4 +-- lib/core/Syn.ml | 8 ++--- lib/core/Value.ml | 16 +++++---- lib/language_server/Analysis.ml | 4 +-- lib/language_server/Document_symbols.ml | 6 +--- lib/parser/Grammar.mly | 13 ++++--- lib/parser/test/Test_parser.ml | 2 +- 12 files changed, 88 insertions(+), 78 deletions(-) diff --git a/lib/compiler/Eval.ml b/lib/compiler/Eval.ml index 0d19a36..d0fe0f8 100644 --- a/lib/compiler/Eval.ml +++ b/lib/compiler/Eval.ml @@ -10,6 +10,7 @@ open Forester_core open struct module T = Types module Env = Value.Env + module Symbol_map = Value.Symbol_map type located = Value.t Range.located end @@ -73,9 +74,9 @@ type result = {articles: T.content T.article list; jobs: Job.job Range.located l module Tape = Tape_effect.Make () module Lex_env = Algaeff.Reader.Make(struct type t = Value.t Env.t end) -module Dyn_env = Algaeff.Reader.Make(struct type t = Value.t Env.t end) +module Dyn_env = Algaeff.Reader.Make(struct type t = Value.t Symbol_map.t end) module Config_env = Algaeff.Reader.Make(struct type t = Config.t end) -module Heap = Algaeff.State.Make(struct type t = Value.obj Env.t end) +module Heap = Algaeff.State.Make(struct type t = Value.obj Symbol_map.t end) module Emitted_trees = Algaeff.State.Make(struct type t = T.content T.article list end) module Jobs = Algaeff.State.Make(struct type t = Job.job Range.located list end) module Frontmatter = Algaeff.State.Make(struct type t = T.content T.frontmatter end) @@ -89,7 +90,7 @@ let get_current_uri ~loc = let get_transclusion_flags ~loc = let dynenv = Dyn_env.read () in let get_bool key = - let@ value = Option.map @~ Env.find_opt key dynenv in + let@ value = Option.map @~ Symbol_map.find_opt key dynenv in extract_bool @@ Range.locate_opt loc value in let module S = Expand.Builtins.Transclude in @@ -185,7 +186,7 @@ and eval_node node : Value.t = emit_content_node ~loc @@ T.prim p @@ T.Content content | Fun (xs, body) -> let env = Lex_env.read () in - focus_clo ?loc env xs body + focus_clo ?loc env (List.map (fun (info, x) -> info, Some x) xs) body | Ref -> begin match eval_pop_arg ~loc |> extract_uri with @@ -360,12 +361,12 @@ and eval_node node : Value.t = let env = Lex_env.read () in let add (name, body) = let super = Symbol.fresh () in - Value.Method_table.add name Value.{body; self; super; env} + Value.Method_table.add name Value.{body; self; super = None; env} in List.fold_right add methods Value.Method_table.empty in let sym = Symbol.named ["obj"] in - Heap.modify @@ Env.add sym Value.{prototype = None; methods = table}; + Heap.modify @@ Symbol_map.add sym Value.{prototype = None; methods = table}; focus ?loc: node.loc @@ Value.Obj sym | Patch {obj; self; super; methods} -> let obj_ptr = {node with value = obj} |> Range.map eval_tape |> extract_obj_ptr in @@ -379,7 +380,7 @@ and eval_node node : Value.t = List.fold_right add methods Value.Method_table.empty in let sym = Symbol.named ["obj"] in - Heap.modify @@ Env.add sym Value.{prototype = Some obj_ptr; methods = table}; + Heap.modify @@ Symbol_map.add sym Value.{prototype = Some obj_ptr; methods = table}; focus ?loc: node.loc @@ Value.Obj sym | Group (d, body) -> let l, r = delim_to_strings d in @@ -395,36 +396,42 @@ and eval_node node : Value.t = match Value.Method_table.find_opt method_name obj.methods with | Some mthd -> let env = - let env = Env.add mthd.self (Value.Obj sym) mthd.env in + let env = + match mthd.self with + | None -> mthd.env + | Some self -> Env.add self (Value.Obj sym) mthd.env + in match proto_val with | None -> env | Some proto_val -> - Env.add mthd.super proto_val env + match mthd.super with + | None -> env + | Some super -> Env.add super proto_val env in let@ () = Lex_env.run ~env in eval_tape mthd.body | None -> match obj.prototype with | Some proto -> - call_method @@ Env.find proto @@ Heap.get () + call_method @@ Symbol_map.find proto @@ Heap.get () | None -> Reporter.fatal ?loc: node.loc (Unbound_method (method_name, obj)) in - let result = call_method @@ Env.find sym @@ Heap.get () in + let result = call_method @@ Symbol_map.find sym @@ Heap.get () in focus ?loc: node.loc result | Put (k, v, body) -> let k = {node with value = k} |> Range.map eval_tape |> extract_sym in let body = - let@ () = Dyn_env.scope (Env.add k (eval_tape v)) in + let@ () = Dyn_env.scope (Symbol_map.add k (eval_tape v)) in eval_tape body in focus ?loc: node.loc body | Default (k, v, body) -> let k = {node with value = k} |> Range.map eval_tape |> extract_sym in let body = - let upd flenv = if Env.mem k flenv then flenv else Env.add k (eval_tape v) flenv in + let upd flenv = if Symbol_map.mem k flenv then flenv else Symbol_map.add k (eval_tape v) flenv in let@ () = Dyn_env.scope upd in eval_tape body in @@ -433,7 +440,7 @@ and eval_node node : Value.t = let k = {node with value = k} |> Range.map eval_tape |> extract_sym in let env = Dyn_env.read () in begin - match Env.find_opt k env with + match Symbol_map.find_opt k env with | None -> Reporter.fatal ?loc: node.loc @@ -558,7 +565,7 @@ and eval_node node : Value.t = | Current_tree -> emit_content_node ~loc: node.loc @@ T.Uri (get_current_uri ~loc: node.loc) -and eval_var ~loc x = +and eval_var ~loc (x : string) = let env = Lex_env.read () in match Env.find_opt x env with | Some v -> focus ?loc v @@ -587,7 +594,7 @@ and focus ?loc = function ~extra_remarks: [Asai.Diagnostic.loctextf "Expected solitary node but got %a / %a" Value.pp v Value.pp v'] end -and focus_clo ?loc rho xs body = +and focus_clo ?loc rho (xs : string option binding list) body = match xs with | [] -> focus ?loc @@ @@ -599,9 +606,9 @@ and focus_clo ?loc rho xs body = let yval = match info with | Strict -> eval_tape arg.value - | Lazy -> Clo (Lex_env.read (), [(Strict, Symbol.fresh ())], arg.value) + | Lazy -> Clo (Lex_env.read (), [(Strict, None)], arg.value) in - let rhoy = Env.add y yval rho in + let rhoy = match y with Some y -> Env.add y yval rho | None -> rho in focus_clo ?loc rhoy ys body | None -> begin @@ -662,9 +669,9 @@ let eval_tree let@ () = Frontmatter.run ~init: fm in let@ () = Emitted_trees.run ~init: [] in let@ () = Jobs.run ~init: [] in - let@ () = Heap.run ~init: Env.empty in + let@ () = Heap.run ~init: Symbol_map.empty in let@ () = Lex_env.run ~env: Env.empty in - let@ () = Dyn_env.run ~env: Env.empty in + let@ () = Dyn_env.run ~env: Symbol_map.empty in let@ () = Config_env.run ~env: config in let main = eval_tree_inner ~uri tree in let side = Emitted_trees.get () in diff --git a/lib/compiler/Expand.ml b/lib/compiler/Expand.ml index 9cc2d8b..34f9405 100644 --- a/lib/compiler/Expand.ml +++ b/lib/compiler/Expand.ml @@ -158,32 +158,29 @@ let rec expand_eff ~(forest : State.t) : Code.t -> Syn.t = function Sc.include_singleton path @@ (Xmlns {prefix; xmlns}, node.loc); expand_eff ~forest rest | Object {self; methods} -> - let self, methods = + let methods = let@ () = Sc.section [] in - let sym = Symbol.fresh () in - let var = Range.{value = Syn.Var sym; loc = node.loc} in (* TODO: correct the location *) begin let@ self = Option.iter @~ self in - Sc.import_singleton self @@ (Term [var], node.loc) (* TODO: correct the location*) + let var = Range.{value = Syn.Var self; loc = node.loc} in (* TODO: correct the location *) + Sc.import_singleton [self] @@ (Term [var], node.loc) (* TODO: correct the location*) end; - sym, List.map (expand_method ~forest) methods + List.map (expand_method ~forest) methods in {node with value = Object {self; methods}} :: expand_eff ~forest rest - | Patch {obj; self; methods} -> + | Patch {obj; self; super; methods} -> let obj = expand_eff ~forest obj in - let self, super, methods = + let methods = let@ () = Sc.section [] in - let self_sym = Symbol.fresh () in - let super_sym = Symbol.fresh () in - let self_var = Range.locate_opt None @@ Syn.Var self_sym in - let super_var = Range.locate_opt None @@ Syn.Var super_sym in begin let@ self = Option.iter @~ self in - Sc.import_singleton self @@ (Term [self_var], node.loc); - (* TODO: correct location*) - Sc.import_singleton (self @ ["super"]) @@ (Term [super_var], node.loc) + let self_var = Range.locate_opt None @@ Syn.Var self in + Sc.import_singleton [self] @@ (Term [self_var], node.loc); + let@ super = Option.iter @~ super in + let super_var = Range.locate_opt None @@ Syn.Var super in + Sc.import_singleton [super] @@ (Term [super_var], node.loc) end; - self_sym, super_sym, List.map (expand_method ~forest) methods + List.map (expand_method ~forest) methods in let patched = Syn.Patch {obj; self; super; methods} in {node with value = patched} :: expand_eff ~forest rest @@ -268,14 +265,13 @@ and expand_method ~forest (key, body) = and expand_lambda ~forest loc (xs, body) = let@ () = Sc.section [] in - let syms = + let xs = let@ strategy, x = List.map @~ xs in - let sym = Symbol.named x in - let var = Range.locate_opt None @@ Syn.Var sym in - Sc.import_singleton x @@ (Term [var], loc); - strategy, sym + let var = Range.locate_opt None @@ Syn.Var x in + Sc.import_singleton [x] @@ (Term [var], loc); + strategy, x in - Range.{value = Syn.Fun (syms, expand_eff ~forest body); loc} + Range.{value = Syn.Fun (xs, expand_eff ~forest body); loc} let ignore_entered_range f x = let open Effect.Deep in diff --git a/lib/core/Code.ml b/lib/core/Code.ml index 859d970..9c1a974 100644 --- a/lib/core/Code.ml +++ b/lib/core/Code.ml @@ -9,14 +9,15 @@ open Base open struct module T = Types end type 'a _object = { - self: Trie.path option; + self: string option; methods: (string * 'a) list } [@@deriving show, repr] type 'a patch = { obj: 'a; - self: Trie.path option; + self: string option; + super: string option; methods: (string * 'a) list } [@@deriving show, repr] @@ -30,18 +31,18 @@ type node = | Hash_ident of string | Xml_ident of string option * string | Subtree of string option * t - | Let of Trie.path * Trie.path binding list * t + | Let of Trie.path * string binding list * t | Open of Trie.path | Scope of t | Put of Trie.path * t | Default of Trie.path * t | Get of Trie.path - | Fun of Trie.path binding list * t + | Fun of string binding list * t | Object of t _object | Patch of t patch | Call of t * string | Import of visibility * string - | Def of Trie.path * Trie.path binding list * t + | Def of Trie.path * string binding list * t | Decl_xmlns of string * string | Alloc of Trie.path | Namespace of Trie.path * t @@ -94,7 +95,7 @@ let map f node = | Fun (b, t) -> Fun (b, f t) | Call (t, s) -> Call (f t, s) | Object {self; methods} -> Object {self; methods = List.map (fun (s, t) -> (s, f t)) methods} - | Patch {obj; self; methods} -> Patch {obj = f obj; self; methods = List.map (fun (s, t) -> (s, f t)) methods} + | Patch {obj; self; super; methods} -> Patch {obj = f obj; self; super; methods = List.map (fun (s, t) -> (s, f t)) methods} | Text _ | Verbatim _ | Ident _ diff --git a/lib/core/Code.mli b/lib/core/Code.mli index 3da7cb0..7c9d7f5 100644 --- a/lib/core/Code.mli +++ b/lib/core/Code.mli @@ -19,21 +19,21 @@ type node = | Subtree of string option * t | Let of Trie.path - * Trie.path binding list + * string binding list * t | Open of Trie.path | Scope of t | Put of Trie.path * t | Default of Trie.path * t | Get of Trie.path - | Fun of Trie.path binding list * t + | Fun of string binding list * t | Object of t _object | Patch of t patch | Call of t * string | Import of visibility * string | Def of Trie.path - * Trie.path binding list + * string binding list * t | Decl_xmlns of string * string | Alloc of Trie.path @@ -51,13 +51,14 @@ type node = and t = node Range.located list and 'a _object = { - self: Trie.path option; + self: string option; methods: (string * 'a) list; } and 'a patch = { obj: 'a; - self: Trie.path option; + self: string option; + super: string option; methods: (string * 'a) list; } diff --git a/lib/core/Reporter.ml b/lib/core/Reporter.ml index ab91351..64dbf82 100644 --- a/lib/core/Reporter.ml +++ b/lib/core/Reporter.ml @@ -41,8 +41,8 @@ module Message = struct got: Value.t option; expected: expected_value list } - | Unbound_fluid_symbol of (Symbol.t * Value.t Value.Env.t) - | Unbound_lexical_symbol of (Symbol.t * Value.t Value.Env.t) + | Unbound_fluid_symbol of (Symbol.t * Value.t Value.Symbol_map.t) + | Unbound_lexical_symbol of (string * Value.t Value.Env.t) | Unresolved_identifier of ((Sc.data, R.P.tag) Trie.t [@opaque]) * Trie.path | Unresolved_xmlns of string | Reference_error of URI.t diff --git a/lib/core/Reporter.mli b/lib/core/Reporter.mli index 85dfc26..efd8559 100644 --- a/lib/core/Reporter.mli +++ b/lib/core/Reporter.mli @@ -36,8 +36,8 @@ sig got: Value.t option; expected: expected_value list } - | Unbound_fluid_symbol of (Symbol.t * Value.t Value.Env.t) - | Unbound_lexical_symbol of (Symbol.t * Value.t Value.Env.t) + | Unbound_fluid_symbol of (Symbol.t * Value.t Value.Symbol_map.t) + | Unbound_lexical_symbol of (string * Value.t Value.Env.t) | Unresolved_identifier of ((Resolver.Scope.data, Resolver.P.tag) Trie.t) * Trie.path | Unresolved_xmlns of string | Reference_error of URI.t diff --git a/lib/core/Syn.ml b/lib/core/Syn.ml index d13ff2b..7bbfda2 100644 --- a/lib/core/Syn.ml +++ b/lib/core/Syn.ml @@ -14,8 +14,8 @@ type node = | Math of math_mode * t | Link of {dest: t; title: t option} | Subtree of string option * t - | Fun of Symbol.t binding list * t - | Var of Symbol.t + | Fun of string binding list * t + | Var of string | Sym of Symbol.t | Put of t * t * t | Default of t * t * t @@ -24,8 +24,8 @@ type node = | TeX_cs of TeX_cs.t | Unresolved_ident of ((resolver_data, Range.t option) Trie.t [@opaque]) * Trie.path | Prim of Prim.t - | Object of {self: Symbol.t; methods: (string * t) list} - | Patch of {obj: t; self: Symbol.t; super: Symbol.t; methods: (string * t) list} + | Object of {self: string option; methods: (string * t) list} + | Patch of {obj: t; self: string option; super: string option; methods: (string * t) list} | Call of t * string | Results_of_query | Transclude diff --git a/lib/core/Value.ml b/lib/core/Value.ml index b193a76..79bbdaf 100644 --- a/lib/core/Value.ml +++ b/lib/core/Value.ml @@ -9,20 +9,24 @@ open Base open struct module T = Types end -module Env = struct - include Map.Make(Symbol) +module Make_env (S : sig include Map.OrderedType val pp : Format.formatter -> t -> unit end) = struct + include Map.Make(S) let pp (pp_el : Format.formatter -> 'a -> unit) (fmt : Format.formatter) (map : 'a t) = Format.fprintf fmt "@[{"; begin let@ k, v = Seq.iter @~ to_seq map in - Format.fprintf fmt "@[%a ~> %a@]@;" Symbol.pp k pp_el v + Format.fprintf fmt "@[%a ~> %a@]@;" S.pp k pp_el v end; Format.fprintf fmt "}@]" end +module Env = Make_env (struct include String let pp = Format.pp_print_string end) +module Symbol_map = Make_env (Symbol) + + type t = | Content of T.content - | Clo of t Env.t * Symbol.t binding list * Syn.t + | Clo of t Env.t * string option binding list * Syn.t | Dx_prop of (string, T.content T.vertex) Datalog_expr.prop | Dx_sequent of (string, T.content T.vertex) Datalog_expr.sequent | Dx_query of (string, T.content T.vertex) Datalog_expr.query @@ -34,8 +38,8 @@ type t = type obj_method = { body: Syn.t; - self: Symbol.t; - super: Symbol.t; + self: string option; + super: string option; env: t Env.t } [@@deriving show] diff --git a/lib/language_server/Analysis.ml b/lib/language_server/Analysis.ml index 3da333a..974b7b2 100644 --- a/lib/language_server/Analysis.ml +++ b/lib/language_server/Analysis.ml @@ -30,7 +30,7 @@ let flatten (tree : Code.t) : Code.t = List.concat_map Code.children tree let paths_in_bindings = - List.map snd + List.map (fun (_, x) -> [x]) (* This function should not descend into the nodes!*) let paths : Code.node Range.located -> _ = function @@ -49,7 +49,7 @@ let paths : Code.node Range.located -> _ = function Some (path :: paths_in_bindings bindings, loc) | Patch {self; _} | Object {self; _;} -> - Option.map (fun path -> [path], loc) self + Option.map (fun x -> [[x]], loc) self | Fun (bindings, _) -> Some (paths_in_bindings bindings, loc) | Subtree _ | Group _ diff --git a/lib/language_server/Document_symbols.ml b/lib/language_server/Document_symbols.ml index ff130e6..3176e22 100644 --- a/lib/language_server/Document_symbols.ml +++ b/lib/language_server/Document_symbols.ml @@ -37,11 +37,7 @@ let compute (params : L.DocumentSymbolParams.t) = (* TODO: What should the symbol kind of a subtree be? *) Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Namespace () | Object {self; _} -> - let name = - match self with - | Some path -> Format.asprintf "%a" pp_path path - | None -> "anonymous" - in + let name = Option.value ~default: "anonymous" self in Option.some @@ L.DocumentSymbol.create ~name ~range ~selectionRange ~kind: Object () | Def (name, _, _) -> let name = Format.asprintf "%a" pp_path name in diff --git a/lib/parser/Grammar.mly b/lib/parser/Grammar.mly index b994f84..ba4455f 100644 --- a/lib/parser/Grammar.mly +++ b/lib/parser/Grammar.mly @@ -40,13 +40,13 @@ let squares(p) == delimited(LSQUARE, p, RSQUARE) let parens(p) == delimited(LPAREN, p, RPAREN) let bvar := -| x = TEXT; { [x] } +| x = TEXT; { x } let bvar_with_strictness := | x = TEXT; { match String_util.explode x with - | '~' :: chars -> Lazy, [String_util.implode chars] - | _ -> Strict, [x] + | '~' :: chars -> Lazy, String_util.implode chars + | _ -> Strict, x } let binder == list(squares(bvar_with_strictness)) @@ -66,6 +66,11 @@ let textual_node := let code_expr == ws_list(locate(head_node1)) let textual_expr == list(locate(textual_node)) +let patch_bindings := +| self = squares(bvar); super = squares(bvar); { Some self, Some super } +| self = squares(bvar); { Some self, None } +| { None, None } + let head_node := | DEF; (~,~,~) = fun_spec; | ALLOC; ~ = ident; @@ -84,7 +89,7 @@ let head_node := | (~,~) = XML_ELT_IDENT; | ~ = DECL_XMLNS; ~ = txt_arg; | OBJECT; self = option(squares(bvar)); methods = braces(ws_list(method_decl)); { Code.Object {self; methods } } -| PATCH; obj = braces(code_expr); self = option(squares(bvar)); methods = braces(ws_list(method_decl)); { Code.Patch {obj; self; methods} } +| PATCH; obj = braces(code_expr); (self, super) = patch_bindings; methods = braces(ws_list(method_decl)); { Code.Patch {obj; self; super; methods} } | CALL; ~ = braces(code_expr); ~ = txt_arg; | DATALOG; LBRACE; list(WHITESPACE); ~ = dx_sequent_node; RBRACE; <> | ~ = VERBATIM; diff --git a/lib/parser/test/Test_parser.ml b/lib/parser/test/Test_parser.ml index 13b4aee..ec85a76 100644 --- a/lib/parser/test/Test_parser.ml +++ b/lib/parser/test/Test_parser.ml @@ -116,7 +116,7 @@ let test_object () = [ object_ { - self = (Some ["self"]); + self = (Some "self"); methods = [ ( "foo", -- 2.51.2