Something went wrong. Try again.
ocaml
Something went wrong. Try again.
6.1 kB · 192 lines
OCaml
at pp-ast
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193(* * SPDX-FileCopyrightText: 2024 The Forester Project Contributors * SPDX-FileCopyrightText: 2026 The Forester Project Contributors * * SPDX-License-Identifier: GPL-3.0-or-later *)
open Forester_compileropen Forester_core
(* I think this module is mostly junk? *)
module Item = struct type t = Path of Trie.path | Addr of string
let addr str = Addr str let path p = Path pend
open struct module R = Resolver module Sc = R.Scope module L = Lsp.Types
module S = Algaeff.Sequencer.Make (struct type t = Item.t Range.located end)end
let flatten (tree : Code.t) : Code.t = List.concat_map Code.children treelet paths_in_bindings = List.map (fun (_, x) -> [x])
(* This function should not descend into the nodes!*)let paths : Code.node Range.located -> _ = function | {value; range} -> ( match value with | Ident path | Open path | Put ({value = path; _}, _) | Default ({value = path; _}, _) | Get {value = path; _} | Alloc path | Namespace (path, _) -> Some ([path], range) | Def (path, bindings, _) | Let (path, bindings, _) -> Some (path :: paths_in_bindings bindings, range) | Patch {self; _} | Object {self; _} -> Option.map (fun x -> ([[x]], range)) self | Fun (bindings, _) -> Some (paths_in_bindings bindings, range) | Subtree _ | Group _ | Scope _ | Math _ | Dx_sequent _ | Dx_const_uri _ | Dx_const_content _ | Dx_query _ | Dx_prop _ | Text _ | Verbatim _ | Hash_ident _ | Xml_ident _ | Call _ | Import _ | Decl_xmlns _ | Dx_var _ | Comment _ | Error _ -> None)
let extract_addr ({value; range} : Code.node Range.located) = match value with | Group (Braces, [{value = Text addr; _}]) | Group (Parens, [{value = Text addr; _}]) | Text addr (* SEEEMS DODGY!! *) -> Some Range.{value = addr; range} | Import (_, {value = addr; _}) -> Some Range.{value = addr; range} | Subtree (addr, _) -> addr | _ -> None
let rec analyse (node : Code.node Range.located) = begin let@ {value; range} = Option.iter @~ extract_addr node in S.yield {value = Item.addr value; range} end; begin let@ paths, range = Option.iter @~ paths node in let@ path = List.iter @~ paths in S.yield {value = Item.path path; range} end; let children = Code.children node in List.iter analyse children
let analyse_syntax nodes = let@ () = S.run in List.iter analyse nodes
let byte_index_of_position ~(source : Range.t) (position : L.Position.t) : Grace.Byte_index.t = let open Grace_source_reader in let open Grace in let compute () = let sd = open_source (Range.source source) in let line = Line.of_line_index sd (Line_index.of_int position.line) in let line_text = slicei sd (Line.start line) (Line.stop line) in let byte_offset = String_util.byte_offset_of_utf16_offset line_text position.character in Byte_index.add (Line.start line) byte_offset in try compute () with Error `Not_initialized -> with_reader compute
let contains ~(position : L.Position.t) (loc : Range.t) = Range.contains loc (byte_index_of_position ~source:loc position)
let rec node_at : type a. position:L.Position.t -> children:(a Range.located -> a Range.located list) -> a Range.located list -> a Range.located option = fun ~position ~children code -> let@ n = Option.map @~ List.find_opt (fun Range.{range; _} -> contains ~position range) code in match node_at ~position ~children @@ children n with | Some inner -> inner | None -> n
let node_at_code ~position = node_at ~position ~children:Code.childrenlet node_at_syn ~position = node_at ~position ~children:Syn.children
let get_visible ?(init_visible = Expand.initial_visible_trie) ~forest ~position code : (Syn.resolver_data, R.P.tag) Trie.t = let exception Got_visible_in_range of (Syn.resolver_data, R.P.tag) Trie.t in let module Monitor : Expand.Range_monitor = struct let entered_range range = if contains ~position range then raise @@ Got_visible_in_range (Sc.get_visible ()) else () end in let module MonitoredExpander = Expand.Monitored_expander (Monitor) in let result = ref init_visible in let errors = let@ () = Error.collect in try Sc.run ~init_visible @@ fun () -> ignore @@ MonitoredExpander.expand ~forest code; result := Sc.get_visible () with Got_visible_in_range visible -> result := visible in (* Need to drain the seq *) Seq.iter ignore errors; !result
let addr_at ~(position : Lsp.Types.Position.t) (code : _ list) : _ Range.located option = Option.bind (node_at ~position ~children:Code.children code) extract_addr
let matching_builtins selected = List.of_seq @@ let@ path, (data, _) = Seq.filter_map @~ Expand.prose_builtins in match data with | Syn.Term (Range.{value; _} :: _) when selected value -> Some path | _ -> None
let address_builtins = matching_builtins @@ function | Syn.Transclude | Syn.Ref | Syn.Parent | Syn.Route_asset -> true | Syn.Attribution (_, `Uri) -> true | Syn.Sym _ -> true | _ -> false
let transclusion_builtins = matching_builtins @@ function Syn.Transclude -> true | _ -> false
let takes_address path = List.mem path address_builtinslet is_transclusion path = List.mem path transclusion_builtins
let address_argument_range = function | Range. {value = Code.Group (Braces, [Range.{value = Code.Text text; range}]); _} :: _ -> Some (text, range) | _ -> None
let word_at ~position (doc : Lsp.Text_document.t) = let exception Found of string in let L.Position.{line; character} = position in let line_opt = List.nth_opt (String.split_on_char '\n' (Lsp.Text_document.text doc)) line in let@ line = Option.bind @@ line_opt in let words = String.split_on_char ' ' line in begin try let acc = ref 0 in begin let@ word = List.iter @~ words in let length = String.length word in if !acc + length + 1 > character then raise (Found word) else acc := !acc + length + 1 end; None with Found str -> Some str end