LSP server based on Asai LSP · anil.recoil.org/ocaml-forester@f5653b3

+1

bin/forester/dune

··· 13 13 forester.prelude 14 14 forester.core 15 15 forester.frontend 16 + forester.language_server 16 17 forester.compiler 17 18 cmdliner 18 19 dune-build-info

+25 -1

bin/forester/main.ml

··· 242 242 let info = Cmd.info "init" ~version ~doc ~man in 243 243 Cmd.v info Term.(const (init ~env) $ arg_dir) 244 244 245 + let lsp ~env config = 246 + let config = Config.parse_forest_config_file config in 247 + Forester_lsp.start 248 + ~env 249 + ~config 250 + ~source: None 251 + 252 + let lsp_cmd ~env = 253 + let man = 254 + [ 255 + `S Manpage.s_description; 256 + `P "The $(tname) command starts the forester language server."; 257 + ] 258 + in 259 + let doc = "Start the LSP" in 260 + let info = Cmd.info "lsp" ~version ~doc ~man in 261 + Cmd.v 262 + info 263 + Term.( 264 + const (lsp ~env) 265 + $ arg_config 266 + ) 267 + 245 268 let cmd ~env = 246 269 let doc = "a tool for tending mathematical forests" in 247 270 let man = ··· 260 283 new_tree_cmd ~env; 261 284 complete_cmd ~env; 262 285 init_cmd ~env; 263 - query_cmd ~env 286 + query_cmd ~env; 287 + lsp_cmd ~env; 264 288 ] 265 289 266 290 let () =

+67 -65

lib/compiler/Expand.ml

··· 200 200 { value = Syn.Dx_query (var, List.map expand positives, List.map expand negatives); loc } :: expand rest 201 201 | { value = Fun (xs, body); loc } :: rest -> 202 202 expand_lambda loc (xs, body) :: expand rest 203 - | { value = Object { self; methods }; loc } :: rest -> 203 + | { value = Object{ self; methods }; loc } :: rest -> 204 204 let self, methods = 205 205 let@ () = Sc.section [] in 206 206 let sym = Symbol.fresh () in ··· 212 212 sym, List.map expand_method methods 213 213 in 214 214 { value = Syn.Object { self; methods }; loc } :: expand rest 215 - | { value = Patch { obj; self; methods }; loc } :: rest -> 215 + | { value = Patch{ obj; self; methods }; loc } :: rest -> 216 216 let self, super, methods = 217 217 let@ () = Sc.section [] in 218 218 let self_sym = Symbol.fresh () in ··· 331 331 | Some (Term x, ()), _ -> 332 332 let relocate Range.{ value; _ } = Range.{ value; loc } in 333 333 List.map relocate x 334 - | Some (Xmlns { xmlns; prefix }, ()), _ -> 334 + | Some (Xmlns{ xmlns; prefix }, ()), _ -> 335 335 Reporter.emitf 336 336 ?loc 337 337 Resolution_error ··· 347 347 | None -> { xmlns = None; prefix = ""; uname } 348 348 | Some prefix -> 349 349 match Sc.resolve ["xmlns"; prefix] with 350 - | Some (Xmlns { xmlns; prefix }, ()) -> 350 + | Some (Xmlns{ xmlns; prefix }, ()) -> 351 351 { xmlns = Some xmlns; prefix = prefix; uname } 352 352 | _ -> 353 353 Reporter.emitf ··· 376 376 U.set units; 377 377 syn 378 378 379 + let builtins = 380 + [ 381 + ["p"], Syn.Prim `P; 382 + ["em"], Syn.Prim `Em; 383 + ["strong"], Syn.Prim `Strong; 384 + ["li"], Syn.Prim `Li; 385 + ["ol"], Syn.Prim `Ol; 386 + ["ul"], Syn.Prim `Ul; 387 + ["code"], Syn.Prim `Code; 388 + ["blockquote"], Syn.Prim `Blockquote; 389 + ["pre"], Syn.Prim `Pre; 390 + ["figure"], Syn.Prim `Figure; 391 + ["figcaption"], Syn.Prim `Figcaption; 392 + ["transclude"], Syn.Transclude; 393 + ["tex"], Syn.Embed_tex; 394 + ["ref"], Syn.Ref; 395 + ["title"], Syn.Title; 396 + ["taxon"], Syn.Taxon; 397 + ["date"], Syn.Date; 398 + ["meta"], Syn.Meta; 399 + ["author"], Syn.Attribution (Author, `Iri); 400 + ["author"; "literal"], Syn.Attribution (Author, `Content); 401 + ["contributor"], Syn.Attribution (Contributor, `Iri); 402 + ["contributor"; "literal"], Syn.Attribution (Contributor, `Content); 403 + ["parent"], Syn.Parent; 404 + ["number"], Syn.Number; 405 + ["tag"], Syn.Tag `Content; 406 + ["query"], Syn.Results_of_query; 407 + ["query"; "rel"], Syn.Query_rel `Iri; 408 + ["query"; "rel"; "literal"], Syn.Query_rel `Content; 409 + ["query"; "union"], Syn.Query_union; 410 + ["query"; "isect"], Syn.Query_isect; 411 + ["query"; "isect-fam"], Syn.Query_isect_fam; 412 + ["query"; "union-fam"], Syn.Query_union_fam; 413 + ["query"; "isect-fam-rel"], Syn.Query_isect_fam_rel; 414 + ["query"; "union-fam-rel"], Syn.Query_union_fam_rel; 415 + ["query"; "compl"], Syn.Query_compl; 416 + ["query"; "tag"], Syn.Query_builtin (`Tag, `Content); 417 + ["query"; "taxon"], Syn.Query_builtin (`Taxon, `Content); 418 + ["query"; "author"], Syn.Query_builtin (`Author, `Iri); 419 + ["query"; "author"; "literal"], Syn.Query_builtin (`Author, `Content); 420 + ["query"; "incoming"], Syn.Query_polarity Incoming; 421 + ["query"; "outgoing"], Syn.Query_polarity Outgoing; 422 + ["query"; "edges"], Syn.Query_mode Edges; 423 + ["query"; "paths"], Syn.Query_mode Paths; 424 + ["rel"; "has-tag"], Syn.Text Builtin_relation.has_tag; 425 + ["rel"; "has-taxon"], Syn.Text Builtin_relation.has_taxon; 426 + ["rel"; "has-author"], Syn.Text Builtin_relation.has_author; 427 + ["rel"; "has-direct-contributor"], Syn.Text Builtin_relation.has_direct_contributor; 428 + ["rel"; "transcludes"], Syn.Text Builtin_relation.transcludes; 429 + ["rel"; "transcludes"; "transitive-closure"], Syn.Text Builtin_relation.transcludes_tc; 430 + ["rel"; "transcludes"; "reflexive-transitive-closure"], Syn.Text Builtin_relation.transcludes_rtc; 431 + ["rel"; "links-to"], Syn.Text Builtin_relation.links_to; 432 + ["rel"; "is-reference"], Syn.Text Builtin_relation.is_reference; 433 + ["rel"; "is-person"], Syn.Text Builtin_relation.is_person; 434 + ["rel"; "is-node"], Syn.Text Builtin_relation.is_node; 435 + ["rel"; "in-bundle-closure"], Syn.Text Builtin_relation.in_bundle_closure; 436 + ["execute"], Syn.Dx_execute; 437 + ["route-asset"], Syn.Route_asset; 438 + ["publish-query"], Syn.Publish_results_of_query 439 + ] 440 + 379 441 let expand_tree (units : exports Unit_map.t) (tree : Code.tree) = 380 442 let@ () = U.run ~init: units in 381 443 let@ () = Sc.easy_run in 382 - Builtins.register_builtins 383 - [ 384 - ["p"], Syn.Prim `P; 385 - ["em"], Syn.Prim `Em; 386 - ["strong"], Syn.Prim `Strong; 387 - ["li"], Syn.Prim `Li; 388 - ["ol"], Syn.Prim `Ol; 389 - ["ul"], Syn.Prim `Ul; 390 - ["code"], Syn.Prim `Code; 391 - ["blockquote"], Syn.Prim `Blockquote; 392 - ["pre"], Syn.Prim `Pre; 393 - ["figure"], Syn.Prim `Figure; 394 - ["figcaption"], Syn.Prim `Figcaption; 395 - ["transclude"], Syn.Transclude; 396 - ["tex"], Syn.Embed_tex; 397 - ["ref"], Syn.Ref; 398 - ["title"], Syn.Title; 399 - ["taxon"], Syn.Taxon; 400 - ["date"], Syn.Date; 401 - ["meta"], Syn.Meta; 402 - ["author"], Syn.Attribution (Author, `Iri); 403 - ["author"; "literal"], Syn.Attribution (Author, `Content); 404 - ["contributor"], Syn.Attribution (Contributor, `Iri); 405 - ["contributor"; "literal"], Syn.Attribution (Contributor, `Content); 406 - ["parent"], Syn.Parent; 407 - ["number"], Syn.Number; 408 - ["tag"], Syn.Tag `Content; 409 - ["query"], Syn.Results_of_query; 410 - ["query"; "rel"], Syn.Query_rel `Iri; 411 - ["query"; "rel"; "literal"], Syn.Query_rel `Content; 412 - ["query"; "union"], Syn.Query_union; 413 - ["query"; "isect"], Syn.Query_isect; 414 - ["query"; "isect-fam"], Syn.Query_isect_fam; 415 - ["query"; "union-fam"], Syn.Query_union_fam; 416 - ["query"; "isect-fam-rel"], Syn.Query_isect_fam_rel; 417 - ["query"; "union-fam-rel"], Syn.Query_union_fam_rel; 418 - ["query"; "compl"], Syn.Query_compl; 419 - ["query"; "tag"], Syn.Query_builtin (`Tag, `Content); 420 - ["query"; "taxon"], Syn.Query_builtin (`Taxon, `Content); 421 - ["query"; "author"], Syn.Query_builtin (`Author, `Iri); 422 - ["query"; "author"; "literal"], Syn.Query_builtin (`Author, `Content); 423 - ["query"; "incoming"], Syn.Query_polarity Incoming; 424 - ["query"; "outgoing"], Syn.Query_polarity Outgoing; 425 - ["query"; "edges"], Syn.Query_mode Edges; 426 - ["query"; "paths"], Syn.Query_mode Paths; 427 - ["rel"; "has-tag"], Syn.Text Builtin_relation.has_tag; 428 - ["rel"; "has-taxon"], Syn.Text Builtin_relation.has_taxon; 429 - ["rel"; "has-author"], Syn.Text Builtin_relation.has_author; 430 - ["rel"; "has-direct-contributor"], Syn.Text Builtin_relation.has_direct_contributor; 431 - ["rel"; "transcludes"], Syn.Text Builtin_relation.transcludes; 432 - ["rel"; "transcludes"; "transitive-closure"], Syn.Text Builtin_relation.transcludes_tc; 433 - ["rel"; "transcludes"; "reflexive-transitive-closure"], Syn.Text Builtin_relation.transcludes_rtc; 434 - ["rel"; "links-to"], Syn.Text Builtin_relation.links_to; 435 - ["rel"; "is-reference"], Syn.Text Builtin_relation.is_reference; 436 - ["rel"; "is-person"], Syn.Text Builtin_relation.is_person; 437 - ["rel"; "is-node"], Syn.Text Builtin_relation.is_node; 438 - ["rel"; "in-bundle-closure"], Syn.Text Builtin_relation.in_bundle_closure; 439 - ["execute"], Syn.Dx_execute; 440 - ["route-asset"], Syn.Route_asset; 441 - ["publish-query"], Syn.Publish_results_of_query 442 - ]; 444 + Builtins.register_builtins builtins; 443 445 Builtins.Transclude.alloc_expanded (); 444 446 Builtins.Transclude.alloc_show_heading (); 445 447 Builtins.Transclude.alloc_toc ();

+1

lib/compiler/Expand.mli

··· 15 15 val empty : t 16 16 end 17 17 18 + val builtins : (string list * Syn.node) list 18 19 val expand_tree : Env.t -> Code.tree -> Env.t * Syn.tree 19 20 20 21 module Builtins:

+1 -1

lib/compiler/Grammar.messages

··· 4 4 main: TICK 5 5 main: OBJECT LBRACE LSQUARE TEXT RSQUARE WHITESPACE TICK 6 6 main: SUBTREE LBRACE TICK 7 + main: IDENT TICK 7 8 8 9 Unexpected symbol: ' 9 10 10 - main: IDENT TICK 11 11 main: ALLOC XML_ELT_IDENT 12 12 main: CALL LBRACE RBRACE LBRACE XML_ELT_IDENT 13 13 main: CALL LBRACE RBRACE XML_ELT_IDENT

+1

lib/forest/Forester_forest.ml

··· 4 4 * SPDX-License-Identifier: GPL-3.0-or-later 5 5 *) 6 6 7 + module Forest_graph = Forest_graph 7 8 module Forest_graphs = Forest_graphs 8 9 module Forest = Forest 9 10 module Forest_util = Forest_util

+1 -1

lib/frontend/Forest_reader.ml

··· 32 32 let eval { env; host } job = 33 33 let@ () = Reporter.easy_run in 34 34 match job with 35 - | Job.LaTeX_to_svg { hash; source; content } -> 35 + | Job.LaTeX_to_svg{ hash; source; content } -> 36 36 let svg = Build_latex.latex_to_svg ~env source in 37 37 let frontmatter = T.default_frontmatter ~iri: (Iri_scheme.hash_iri ~host hash) () in 38 38 let mainmatter = content ~svg in

+1 -1

lib/frontend/Import_graph.ml

··· 37 37 analyse_tree roots addr code 38 38 | Scope code | Namespace (_, code) | Group (_, code) | Math (_, code) | Let (_, _, code) | Fun (_, code) | Def (_, _, code) -> 39 39 analyse_code roots code 40 - | Object { methods; _ } | Patch { methods; _ } -> 40 + | Object{ methods; _ } | Patch{ methods; _ } -> 41 41 let@ _, code = List.iter @~ methods in 42 42 analyse_code roots code 43 43 | Dx_prop (rel, args) ->

+216

lib/language_server/Analysis.ml

··· 1 + (* 2 + * SPDX-FileCopyrightText: 2024 The Forester Project Contributors AND The RedPRL Development Team 3 + * 4 + * SPDX-License-Identifier: GPL-3.0-or-later OR Apache-2.0 WITH LLVM-exception 5 + * 6 + *) 7 + 8 + open Forester_prelude 9 + open Forester_core 10 + open Forester_compiler 11 + open Forester_frontend 12 + 13 + module L = Lsp.Types 14 + module T = Types 15 + module EP = Eio.Path 16 + module G = Forester_forest.Forest_graphs.Make () 17 + module F = Forester_forest.Forest.Make(G) 18 + module FU = Forester_forest.Forest_util.Make(F) 19 + 20 + module Code_set = Set.Make(struct 21 + type t = Code.tree 22 + (* TODO: no polymorphic compare*) 23 + let compare = compare 24 + end) 25 + 26 + let path_of_dir ~env dir = 27 + EP.(Eio.Stdenv.fs env / dir) 28 + 29 + let paths_of_dirs ~env = 30 + List.map (path_of_dir ~env) 31 + 32 + let build_once ~env (state : Base.server) () = 33 + let tree_dirs = (paths_of_dirs ~env state.config.trees) in 34 + Eio.traceln "Planting forest"; 35 + let parsed_trees = 36 + Forester_frontend.Forester.parse_trees_in_dirs 37 + ~dev: true 38 + tree_dirs 39 + in 40 + parsed_trees 41 + |> List.iter 42 + ( 43 + fun 44 + (Code.{ source_path; addr; _ } as code) 45 + -> 46 + match source_path with 47 + | Some p -> 48 + let uri = Lsp.Uri.of_path p in 49 + Hashtbl.add state.codes L.TextDocumentIdentifier.{ uri } code; 50 + begin 51 + match addr with 52 + | Some a -> 53 + Hashtbl.add 54 + state.resolver 55 + (Iri_scheme.user_iri ~host: state.config.host a) 56 + L.TextDocumentIdentifier.{ uri } 57 + | None -> () 58 + end 59 + | None -> 60 + () 61 + ); 62 + try 63 + let articles, _ = 64 + Forester_frontend.Forest_reader.read_trees 65 + ~env 66 + ~host: state.config.host 67 + parsed_trees 68 + in 69 + let@ article = List.iter @~ articles in 70 + F.plant_resource @@ T.Article article 71 + with 72 + | _ -> () 73 + 74 + let parse_path path = Parse.parse_string @@ EP.load path 75 + 76 + let parse_from = function 77 + | `String s -> Parse.parse_string s 78 + | `Eio_path p -> parse_path p 79 + | `Uri(uri, cache: L.TextDocumentIdentifier.t * _) -> 80 + begin 81 + match Hashtbl.find_opt cache uri with 82 + | Some doc -> Parse.parse_string (Lsp.Text_document.text doc) 83 + | None -> 84 + Error (Reporter.fatalf Internal_error "Could not find %s in the internal document store. This is a bug!" (Lsp.Uri.to_path uri.uri)) 85 + end 86 + | `Iri (env, iri) -> 87 + match F.get_article iri with 88 + | Some{ frontmatter = { source_path = Some str; _ }; _ } -> 89 + let p = EP.(env#fs / str) in 90 + parse_path p 91 + | _ -> 92 + Result.error @@ 93 + Reporter.diagnosticf 94 + (Tree_not_found iri) 95 + "could not find tree %a " 96 + pp_iri 97 + iri 98 + 99 + let dependencies (code : Code.t) host : iri Range.located list = 100 + let rec analyse_deps (node : Code.node Range.located) = 101 + match Range.(node.value) with 102 + | Import (_, dep) -> 103 + [Range.{ loc = node.loc; value = (Iri_scheme.user_iri ~host dep) }] 104 + | Subtree (_, code) 105 + | Scope code 106 + | Namespace (_, code) 107 + | Group (_, code) 108 + | Math (_, code) 109 + | Let (_, _, code) 110 + | Fun (_, code) 111 + | Def (_, _, code) -> 112 + List.concat_map analyse_deps code 113 + | Object{ methods; _ } | Patch{ methods; _ } -> 114 + let@ code = List.concat_map @~ methods in 115 + List.concat_map analyse_deps (snd code) 116 + | _ -> 117 + [] 118 + in 119 + List.concat_map 120 + analyse_deps 121 + code 122 + 123 + (* Does no IO*) 124 + let get_dependencies (server : Base.server) code = 125 + let rec go c acc = 126 + let immediate_deps = dependencies c server.config.host in 127 + List.fold_left 128 + ( 129 + fun acc' d -> 130 + match Hashtbl.find_opt server.resolver Range.(d.value) with 131 + | None -> 132 + Reporter.emitf ?loc: d.loc Resource_not_found "Could not find tree %a" pp_iri d.value; 133 + acc' 134 + | Some uri -> 135 + begin 136 + match Hashtbl.find_opt server.codes uri with 137 + | None -> 138 + Reporter.emitf ?loc: d.loc Resource_not_found "Could not find tree %s" @@ Lsp.Uri.to_path uri.uri; 139 + acc' 140 + | Some tree -> go tree.code (Code_set.add tree acc') 141 + end 142 + ) 143 + acc 144 + immediate_deps 145 + in 146 + go code Code_set.empty 147 + 148 + let check (server : Base.server) uri = 149 + let res = parse_from (`Uri (L.TextDocumentIdentifier.{ uri = uri }, server.documents)) in 150 + match res with 151 + | Ok code -> 152 + let tree = Code.{ source_path = None; addr = None; code } in 153 + let trans_deps = get_dependencies server code in 154 + let trees = trans_deps |> Code_set.to_list in 155 + let _units, _expanded_trees = 156 + Forest_reader.expand 157 + ~host: server.config.host 158 + (tree :: trees) 159 + in 160 + () 161 + | Error diagnostic -> 162 + Reporter.emit_diagnostic diagnostic 163 + 164 + let extract_addr (node : Code.node Range.located) : string option = 165 + match node.value with 166 + | Group (Braces, [{ value = Text addr; _ }]) 167 + | Group (Parens, [{ value = Text addr; _ }]) 168 + | Group (Squares, [{ value = Group (Squares, [{ value = Text addr; _ }]); _ }]) 169 + | Import (_, addr) -> 170 + Some addr 171 + | Text _ | Verbatim _ | Math (_, _) | Ident _ | Hash_ident _ | Xml_ident _ | Subtree (_, _) | Let (_, _, _) | Open _ | Scope _ | Put (_, _) | Default (_, _) | Get _ | Fun (_, _) | Object _ | Patch _ | Call (_, _) | Def (_, _, _) | Decl_xmlns (_, _) | Alloc _ | Namespace (_, _) | _ -> None 172 + 173 + let _ = 174 + assert ( 175 + extract_addr @@ 176 + Range.{ 177 + loc = None; 178 + value = Group (Parens, [{ value = Text "foo"; loc = None }]) 179 + } 180 + = Some "foo" 181 + ) 182 + 183 + let rec flatten (tree : Code.t) : Code.t = 184 + tree 185 + |> List.concat_map @@ 186 + fun (node : 'a Range.located) -> 187 + match node.value with 188 + | Code.Subtree (_, tree) -> flatten tree 189 + | Code.Scope tree -> flatten tree 190 + | _ -> [node] 191 + 192 + let within ~range: (a, b) x = a <= x && x <= b 193 + 194 + let is_at = fun 195 + ~(position : Lsp.Types.Position.t) 196 + (located : _ Range.located) 197 + -> 198 + match located.loc with 199 + | Some loc -> 200 + begin 201 + match Range.view loc with 202 + | `Range (start, end_) -> 203 + within ~range: (start.line_num, end_.line_num) (position.line + 1) 204 + && within 205 + ~range: ((start.offset - start.start_of_line), (end_.offset - end_.start_of_line - 1)) 206 + position.character 207 + | _ -> false 208 + end 209 + | None -> false 210 + 211 + let node_at ~(position : Lsp.Types.Position.t) (code : _) : _ option = 212 + let flattened = flatten code in 213 + List.find_opt (is_at ~position) flattened 214 + 215 + let addr_at ~(position : Lsp.Types.Position.t) (code : _) : _ option = 216 + Option.bind (node_at ~position code) extract_addr

+20

lib/language_server/Analysis.mli

··· 1 + module G : Forester_forest.Forest_graphs.S 2 + module F : Forester_forest.Forest.S 3 + module L = Lsp.Types 4 + 5 + val check : Base.server -> L.DocumentUri.t -> unit 6 + 7 + 8 + val build_once : 9 + env:Forester_frontend.Forest_reader.env -> 10 + Base.server -> unit -> unit 11 + 12 + val extract_addr : 13 + Forester_compiler.Code.node Forester_core.Range.located -> 14 + string option 15 + 16 + val addr_at : 17 + position:Lsp.Types.Position.t -> 18 + Forester_compiler.Code.t -> 19 + string option 20 +

+20

lib/language_server/Base.ml

··· 1 + open Forester_core 2 + open Forester_frontend 3 + open Forester_compiler 4 + 5 + module L = Lsp.Types 6 + 7 + type server = { 8 + env: Forest_reader.env; 9 + units: Expand.Env.t; 10 + config: Forester_frontend.Config.Forest_config.t; 11 + lsp_io: LspEio.io; 12 + should_shutdown: bool; 13 + source: string option; 14 + (* One hashtbl per phase? Annoying...*) 15 + resolver: (iri, L.TextDocumentIdentifier.t) Hashtbl.t; 16 + documents: (L.TextDocumentIdentifier.t, Lsp.Text_document.t) Hashtbl.t; 17 + codes: (L.TextDocumentIdentifier.t, Code.tree) Hashtbl.t; 18 + } 19 + 20 + module State = Algaeff.State.Make(struct type t = server end)

+80

lib/language_server/Completion.ml

+202

lib/language_server/Forester_lsp.ml

··· 1 + (* 2 + * SPDX-FileCopyrightText: 2024 The Forester Project Contributors AND The RedPRL Development Team 3 + * 4 + * SPDX-License-Identifier: GPL-3.0-or-later OR Apache-2.0 WITH LLVM-exception 5 + * 6 + *) 7 + 8 + open Forester_compiler 9 + 10 + module Analysis = Analysis 11 + module Semantic_tokens = Semantic_tokens 12 + module L = Lsp.Types 13 + module RPC = Jsonrpc 14 + module Base = Base 15 + module Server = LspServer 16 + 17 + open Server 18 + 19 + let unwrap opt err = 20 + match opt with 21 + | Some opt -> opt 22 + | None -> raise @@ LspError err 23 + 24 + let print_exn exn = 25 + let msg = Printexc.to_string exn 26 + and stack = Printexc.get_backtrace () 27 + in 28 + Eio.traceln "%s\n%s" msg stack 29 + 30 + (* [TODO: Reed M, 09/06/2022] Commands??? *) 31 + let supported_code_actions = [] 32 + let supported_commands = [] 33 + 34 + let server_capabilities = 35 + let textDocumentSync = 36 + let opts = 37 + L.TextDocumentSyncOptions.create 38 + ~change: L.TextDocumentSyncKind.Full 39 + ~openClose: true 40 + ~save: (`SaveOptions (L.SaveOptions.create ~includeText: false ())) 41 + () 42 + in 43 + `TextDocumentSyncOptions opts 44 + in 45 + let hoverProvider = 46 + let opts = L.HoverOptions.create () in 47 + `HoverOptions opts 48 + in 49 + let codeActionProvider = 50 + let opts = L.CodeActionOptions.create ~codeActionKinds: supported_code_actions () in 51 + `CodeActionOptions opts 52 + in 53 + let executeCommandProvider = 54 + L.ExecuteCommandOptions.create ~commands: supported_commands () 55 + in 56 + let inlayHintProvider = 57 + let opts = L.InlayHintOptions.create () in 58 + `InlayHintOptions opts 59 + in 60 + let definitionProvider = `DefinitionOptions (L.DefinitionOptions.create ()) in 61 + let completionProvider = 62 + L.CompletionOptions.create 63 + ~triggerCharacters: ["\\"; "{"; "("; ] 64 + ~allCommitCharacters: ["}"; ")"; ] 65 + () 66 + in 67 + let semanticTokensProvider = 68 + let full = `Full (L.SemanticTokensOptions.create_full ~delta: false ()) in 69 + `SemanticTokensOptions 70 + (L.SemanticTokensOptions.create ~legend: Semantic_tokens.legend ~full ()) 71 + in 72 + (* [NOTE: Position Encodings] 73 + For various historical reasons, the spec states that we are _required_ to support UTF-16. 74 + This causes more trouble than it's worth, so we always select UTF-8 as our encoding, even 75 + if the client doesn't support it. *) 76 + let positionEncoding 77 + = 78 + L.PositionEncodingKind.UTF8 79 + in 80 + (* [FIME: Reed M, 09/06/2022] The current verison of the LSP library doesn't support 'positionEncoding' *) 81 + L.ServerCapabilities.create 82 + ~textDocumentSync 83 + ~hoverProvider 84 + ~codeActionProvider 85 + ~executeCommandProvider 86 + ~inlayHintProvider 87 + ~positionEncoding 88 + ~completionProvider 89 + ~definitionProvider 90 + ~semanticTokensProvider 91 + () 92 + 93 + let supports_utf8_encoding (init_params : L.InitializeParams.t) = 94 + let position_encodings = 95 + Option.value ~default: [] @@ 96 + Option.bind init_params.capabilities.general @@ 97 + fun gcap -> gcap.positionEncodings 98 + in 99 + List.mem L.PositionEncodingKind.UTF8 position_encodings 100 + 101 + let get_root (init_params : L.InitializeParams.t) = 102 + match init_params.rootUri with 103 + | Some uri -> Some (L.DocumentUri.to_path uri) 104 + | None -> Option.join init_params.rootPath 105 + 106 + module R = Lsp.Client_request 107 + 108 + (** Perform the LSP initialization handshake. 109 + https://microsoft.github.io/language-server-protocol/specifications/specification-current/#initialize *) 110 + let initialize () = 111 + let (id, req) = 112 + unwrap (Request.recv ()) @@ 113 + HandshakeError "Initialization must begin with a request." 114 + in 115 + match req with 116 + | E (Initialize init_params as init_req) -> 117 + begin 118 + (* [HACK: Position Encodings] 119 + If the client doesn't support UTF-8, we shouldn't give up, as it might be using UTF-8 anyways... 120 + Therefore, we just produce a warning, and try to use UTF-8 regardless. *) 121 + if not (supports_utf8_encoding init_params) then 122 + Eio.traceln "Warning: client does not support UTF-8 encoding, which may lead to inconsistent positions."; 123 + let resp = L.InitializeResult.create ~capabilities: server_capabilities () in 124 + Request.respond id init_req resp; 125 + let notif = 126 + unwrap (Notification.recv ()) @@ 127 + HandshakeError "Initialization must complete with an initialized notification." 128 + in 129 + match notif with 130 + | Initialized -> 131 + (* let root = get_root init_params in *) 132 + (* Eio.traceln "Root: %s" (Option.value root ~default: "<no-root>"); *) 133 + (* set_root root; *) 134 + (); 135 + Eio.traceln "Initialized!" 136 + | _ -> 137 + raise @@ LspError (HandshakeError "Initialization must complete with an initialized notification.") 138 + end 139 + | (E _) -> 140 + raise @@ LspError (HandshakeError "Initialization must begin with an initialize request.") 141 + 142 + (** Perform the LSP shutdown sequence. 143 + See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#exit *) 144 + let shutdown () = 145 + let notif = 146 + unwrap (Notification.recv ()) @@ 147 + ShutdownError "No requests can be recieved after a shutdown request." 148 + in 149 + match notif with 150 + | Exit -> 151 + () 152 + | _ -> 153 + raise @@ LspError (ShutdownError "The only notification that can be recieved after a shutdown request is exit.") 154 + 155 + (** {1 Main Event Loop} *) 156 + 157 + let rec event_loop () = 158 + match recv () with 159 + | Some packet -> 160 + let _ = 161 + match packet with 162 + | RPC.Packet.Request req -> 163 + let resp = Request.handle req in 164 + send (RPC.Packet.Response resp) 165 + | RPC.Packet.Notification notif -> 166 + Notification.handle notif 167 + | _ -> 168 + Eio.traceln "Recieved unexpected packet type." 169 + | exception exn -> 170 + print_exn exn 171 + in 172 + if should_shutdown () then 173 + shutdown () 174 + else 175 + event_loop () 176 + | None -> 177 + Eio.traceln "Recieved an invalid message. Shutting down...@." 178 + 179 + let start ~env ~source ~config = 180 + let lsp_io = LspEio.init env in 181 + let codes = Hashtbl.create 1000 in 182 + let resolver = Hashtbl.create 1000 in 183 + let init = 184 + Base.{ 185 + env; 186 + lsp_io; 187 + config; 188 + source; 189 + codes; 190 + resolver; 191 + units = Expand.Env.empty; 192 + documents = Hashtbl.create 10; 193 + should_shutdown = false; 194 + } 195 + in 196 + Analysis.build_once ~env init (); 197 + Server.run ~init @@ 198 + fun () -> 199 + begin 200 + initialize (); 201 + event_loop () 202 + end

+133

lib/language_server/LspEio.ml

··· 1 + (* 2 + * SPDX-FileCopyrightText: 2024 The Forester Project Contributors AND The RedPRL Development Team 3 + * 4 + * SPDX-License-Identifier: GPL-3.0-or-later OR Apache-2.0 WITH LLVM-exception 5 + * 6 + *) 7 + 8 + open Eio 9 + open Lsp.Import 10 + 11 + module RPC = Jsonrpc 12 + 13 + type io = { 14 + input: Buf_read.t; 15 + output: Eio_unix.sink_ty Eio.Resource.t; 16 + } 17 + 18 + (** See https://microsoft.github.io/language-server-protocol/specifications/specification-current/#headerPart *) 19 + module Header = struct 20 + type t = { 21 + content_length: int; 22 + content_type: string 23 + } 24 + 25 + let empty = 26 + { 27 + content_length = -1; 28 + content_type = "application/vscode-jsonrpc; charset=utf-8" 29 + } 30 + 31 + let create ~(content_length : int) : t = 32 + { empty with content_length } 33 + 34 + let is_content_length key = 35 + String.equal (String.lowercase_ascii @@ String.trim key) "content-length" 36 + 37 + let is_content_type key = 38 + String.equal (String.lowercase_ascii @@ String.trim key) "content-type" 39 + 40 + (* NOTE: We should never really recieve an invalid header, as 41 + that would indicate a broken client implementation. Therefore, 42 + we just bail out when we see an invalid header, as there's 43 + no way we can really recover anyways. *) 44 + type header_error = 45 + | InvalidHeader of string 46 + | InvalidContentLength of string 47 + 48 + exception HeaderError of header_error 49 + 50 + (* If we do see any random header messages, we want to at least print out a decent error message. *) 51 + let () = 52 + Printexc.register_printer @@ 53 + function 54 + | HeaderError (InvalidHeader err) -> Some (Format.asprintf "HeaderError: Invalid Header %s" err) 55 + | HeaderError (InvalidContentLength n) -> Some (Format.asprintf "HeaderError: Invalid Content Length '%s'" n) 56 + | _ -> None 57 + 58 + (* [TODO: Reed M, 09/06/2022] I could use some of the Buf_read parser module here, but this code works. *) 59 + let parse_header line headers = 60 + match String.split_on_char ~sep: ':' @@ String.trim line with 61 + | [key; value] when is_content_length key -> 62 + let content_length = 63 + match int_of_string_opt (String.trim value) with 64 + | Some n -> n 65 + | None -> raise (HeaderError (InvalidContentLength value)) 66 + in 67 + { headers with content_length } 68 + | [key; value] when is_content_type key -> 69 + let content_type = String.trim value in 70 + { headers with content_type } 71 + | [_; _] -> 72 + (* We skip any unknown headers. *) 73 + headers 74 + | _ -> 75 + raise (HeaderError (InvalidHeader line)) 76 + 77 + (** Read the header section of an LSP message. *) 78 + let read io = 79 + let rec loop headers = 80 + match Buf_read.line io.input with 81 + | "" -> headers 82 + | line -> loop (parse_header line headers) 83 + in 84 + let headers = loop empty in 85 + if headers.content_length < 0 then 86 + raise (HeaderError (InvalidContentLength (string_of_int headers.content_length))) 87 + else 88 + headers 89 + 90 + (** Write out the header section of an LSP message. *) 91 + let write io headers = 92 + let header_str = 93 + Format.asprintf 94 + "Content-Type: %s\r\nContent-Length: %d\r\n\r\n" 95 + headers.content_type 96 + headers.content_length 97 + in 98 + Flow.copy_string header_str io.output 99 + end 100 + 101 + module Message = struct 102 + let read io = 103 + try 104 + let header = Header.read io in 105 + let len = header.content_length in 106 + let json = Json.of_string @@ Buf_read.take len io.input in 107 + Some (RPC.Packet.t_of_yojson json) 108 + with 109 + | Sys_error _ 110 + | End_of_file -> 111 + None 112 + 113 + let write io packet = 114 + let json = RPC.Packet.yojson_of_t packet in 115 + let data = Json.to_string json in 116 + let content_length = String.length data in 117 + let header = Header.create ~content_length in 118 + Header.write io header; 119 + Flow.copy_string data io.output 120 + end 121 + 122 + let init (env : Eio_unix.Stdenv.base) = 123 + { 124 + (* [TODO: Reed M, 09/06/2022] I should think about this buffer size... *) 125 + input = Buf_read.of_flow ~max_size: 1_000_000 @@ Eio.Stdenv.stdin env; 126 + output = Eio.Stdenv.stdout env 127 + } 128 + 129 + let recv io = 130 + Message.read io 131 + 132 + let send io packet = 133 + Message.write io packet

+398

lib/language_server/LspServer.ml

··· 1 + (* 2 + * SPDX-FileCopyrightText: 2024 The Forester Project Contributors AND The RedPRL Development Team 3 + * 4 + * SPDX-License-Identifier: GPL-3.0-or-later OR Apache-2.0 WITH LLVM-exception 5 + * 6 + *) 7 + 8 + open Forester_prelude 9 + open Forester_frontend 10 + open Forester_compiler 11 + open Forester_core 12 + 13 + module T = Forester_core.Types 14 + module EP = Eio.Path 15 + module L = Lsp.Types 16 + module RPC = Jsonrpc 17 + module Broadcast = Lsp.Server_notification 18 + module Lsp_Diagnostic = Lsp.Types.Diagnostic 19 + module Lsp_Request = Lsp.Client_request 20 + module Lsp_Notification = Lsp.Client_notification 21 + 22 + module F = Analysis.F 23 + module State = Base.State 24 + 25 + let (let*) = Option.bind 26 + 27 + module PT = Forester_forest.Plain_text_client.Make(F)(struct let route _ = "todo" end) 28 + 29 + type eio_path = Eio.Fs.dir_ty EP.t 30 + 31 + type diagnostic = Reporter.Message.t Asai.Diagnostic.t 32 + 33 + type lsp_error = 34 + | DecodeError of string 35 + | HandshakeError of string 36 + | ShutdownError of string 37 + | UnknownRequest of string 38 + | UnknownNotification of string 39 + 40 + exception LspError of lsp_error 41 + 42 + let () = 43 + Printexc.register_printer @@ 44 + function 45 + | LspError (DecodeError err) -> 46 + Some (Format.asprintf "Lsp Error: Couldn't decode %s" err) 47 + | LspError (HandshakeError err) -> 48 + Some (Format.asprintf "Lsp Error: Invalid initialization handshake %s" err) 49 + | LspError (ShutdownError err) -> 50 + Some (Format.asprintf "Lsp Error: Invalid shutdown sequence %s" err) 51 + | LspError (UnknownRequest err) -> 52 + Some (Format.asprintf "Lsp Error: Unknown request %s" err) 53 + | LspError (UnknownNotification err) -> 54 + Some (Format.asprintf "Lsp Error: Unknown notification %s" err) 55 + | _ -> None 56 + 57 + let recv () = 58 + let server = State.get () in 59 + LspEio.recv server.lsp_io 60 + 61 + let send packet = 62 + let server = State.get () in 63 + LspEio.send server.lsp_io packet 64 + 65 + let broadcast notif = 66 + let msg = Broadcast.to_jsonrpc notif in 67 + send (RPC.Packet.Notification msg) 68 + 69 + let render_lsp_related_info (uri : L.DocumentUri.t) (message : Asai.Diagnostic.loctext) : L.DiagnosticRelatedInformation.t = 70 + let range = LspShims.Loc.lsp_range_of_range message.loc in 71 + let location = L.Location.create ~uri ~range in 72 + let message = Asai.Diagnostic.string_of_text message.value in 73 + L.DiagnosticRelatedInformation.create ~location ~message 74 + 75 + let render_lsp_diagnostic (uri : L.DocumentUri.t) (diag : diagnostic) : Lsp_Diagnostic.t = 76 + let range = LspShims.Loc.lsp_range_of_range diag.explanation.loc in 77 + let severity = LspShims.Diagnostic.lsp_severity_of_severity @@ diag.severity in 78 + let code = `String (Reporter.Message.short_code diag.message) in 79 + let source = (State.get ()).source in 80 + let message = Asai.Diagnostic.string_of_text diag.explanation.value in 81 + let relatedInformation = Bwd.to_list @@ Bwd.map (render_lsp_related_info uri) diag.extra_remarks in 82 + Lsp_Diagnostic.create 83 + ~range 84 + ~severity 85 + ~code 86 + ?source 87 + ~message: (`String message) 88 + ~relatedInformation 89 + () 90 + 91 + let publish_diagnostics (uri : Lsp.Uri.t) (diagnostics : diagnostic list) = 92 + let diagnostics = List.map (render_lsp_diagnostic uri) diagnostics in 93 + let params = L.PublishDiagnosticsParams.create ~uri ~diagnostics () in 94 + broadcast (PublishDiagnostics params) 95 + 96 + let should_shutdown () = 97 + let server = State.get () in 98 + server.should_shutdown 99 + 100 + let initiate_shutdown () = 101 + State.modify @@ fun st -> { st with should_shutdown = true } 102 + 103 + (* [TODO: Reed M, 12/12/2022] No code actions for now. *) 104 + let code_action (_params : L.CodeActionParams.t) : L.CodeActionResult.t = 105 + None 106 + 107 + let completion 108 + (params : L.CompletionParams.t) 109 + = 110 + match params with 111 + | { 112 + context; 113 + _; 114 + } -> 115 + let triggerCharacter = 116 + match context with 117 + | Some{ triggerCharacter; _ } -> 118 + triggerCharacter 119 + | None -> None 120 + in 121 + let server = State.get () in 122 + let addr_items () = 123 + server.codes 124 + |> Hashtbl.to_seq_values 125 + |> List.of_seq 126 + |> List.filter_map 127 + ( 128 + fun (tree : Code.tree) -> 129 + let* addr = tree.addr in 130 + let* { frontmatter; mainmatter; _ } = 131 + (F.get_article @@ Iri_scheme.user_iri ~host: server.config.host addr) 132 + in 133 + let documentation = 134 + try 135 + let render = PT.string_of_content in 136 + let title = frontmatter.title in 137 + let taxon = frontmatter.taxon in 138 + let content = 139 + Format.asprintf 140 + {|%s 141 + %s 142 + %s 143 + |} 144 + (Option.fold ~none: "" ~some: (fun s -> Format.asprintf "# %s" (render s)) title) 145 + (Option.fold ~none: "" ~some: (fun s -> Format.asprintf "taxon: %s" (render s)) taxon) 146 + (render mainmatter) 147 + in 148 + Some (`String content) 149 + with 150 + | _ -> 151 + Some (`String "computation of my value crashed") 152 + in 153 + let insertText = 154 + match triggerCharacter with 155 + | Some "{" -> addr ^ "}" 156 + | Some "(" -> addr ^ ")" 157 + | Some "[" -> addr ^ "]" 158 + | _ -> addr 159 + in 160 + Some (L.CompletionItem.create ?documentation ~label: addr ~insertText ()) 161 + ) 162 + in 163 + let trees = server.codes |> Hashtbl.to_seq_values |> List.of_seq in 164 + let scope_items () = 165 + let units, _expanded = Forest_reader.expand ~host: server.config.host trees in 166 + units 167 + |> Expand.Unit_map.to_list 168 + |> List.map snd 169 + |> List.concat_map 170 + ( 171 + fun trie -> 172 + let open Yuujinchou in 173 + trie 174 + |> Trie.to_seq 175 + |> List.of_seq 176 + |> List.filter_map Completion.make 177 + ) 178 + |> List.append 179 + ( 180 + Expand.builtins 181 + |> List.map (fun (a, b) -> (a, (Resolver.P.Term [Range.locate_opt None b], ()))) 182 + |> List.filter_map Completion.make 183 + ) 184 + in 185 + let items = 186 + match triggerCharacter with 187 + | Some "(" -> addr_items () 188 + | Some "{" -> addr_items () 189 + | Some "\\" -> scope_items () 190 + | _ -> [] 191 + in 192 + Some 193 + ( 194 + `CompletionList 195 + (L.CompletionList.create ~isIncomplete: false ~items ()) 196 + ) 197 + 198 + let hover 199 + ({ 200 + position; 201 + textDocument; 202 + _ 203 + }: L.HoverParams.t) 204 + : L.Hover.t option 205 + = 206 + let server = State.get () in 207 + let host = server.config.host in 208 + let* tree = Hashtbl.find_opt server.codes { uri = textDocument.uri } in 209 + let* addr_at_cursor = Analysis.addr_at ~position tree.code in 210 + let iri_under_cursor = Iri_scheme.user_iri ~host addr_at_cursor in 211 + let content = 212 + match F.get_article iri_under_cursor with 213 + | None -> Format.asprintf "extracted iri %a" pp_iri iri_under_cursor 214 + | Some{ mainmatter; _ } -> 215 + PT.string_of_content mainmatter 216 + in 217 + Some 218 + ( 219 + L.Hover.create 220 + ~contents: ( 221 + `MarkupContent 222 + { 223 + kind = L.MarkupKind.Markdown; 224 + value = content 225 + } 226 + ) 227 + () 228 + ) 229 + 230 + let definitions 231 + (params : L.DefinitionParams.t) 232 + : L.Locations.t option 233 + = 234 + match params with 235 + | { 236 + position; 237 + textDocument; 238 + _; 239 + } -> 240 + let server = State.get () in 241 + let codes = server.codes in 242 + let* { code; _ } = Hashtbl.find_opt codes { uri = textDocument.uri } in 243 + let* addr = Analysis.addr_at ~position code in 244 + let iri = Iri_scheme.user_iri ~host: server.config.host addr in 245 + let* uri = Hashtbl.find_opt server.resolver iri in 246 + let range = L.Range.create ~start: { character = 1; line = 0 } ~end_: { character = 1; line = 0 } in 247 + Some 248 + (`Location [L.Location.{ uri = uri.uri; range }]) 249 + 250 + let inlay_hint (params : L.InlayHintParams.t) : L.InlayHint.t list option = 251 + match params with 252 + | { 253 + textDocument; 254 + _; 255 + } -> 256 + let server = State.get () in 257 + match Hashtbl.find_opt server.codes { uri = textDocument.uri } with 258 + | None -> None 259 + | Some{ code; _ } -> 260 + List.filter_map 261 + ( 262 + fun 263 + (Range.{ loc; _ } as node) 264 + -> 265 + match Option.map Range.view loc with 266 + | Some (`Range (_, pos)) -> 267 + let* str = Analysis.extract_addr node in 268 + let iri = Iri_scheme.user_iri ~host: server.config.host str in 269 + let* { frontmatter; _ } = F.get_article iri in 270 + let* title = frontmatter.title in 271 + let content = " " ^ PT.string_of_content title in 272 + Some 273 + ( 274 + L.InlayHint.create 275 + ~position: (LspShims.Loc.lsp_pos_of_pos pos) 276 + ~label: (`String content) 277 + () 278 + ) 279 + | _ -> None 280 + ) 281 + code 282 + |> Option.some 283 + 284 + module Request = struct 285 + type 'resp t = 'resp Lsp.Client_request.t 286 + type packed = Lsp_Request.packed 287 + 288 + let dispatch : type resp. string -> resp t -> resp = fun mthd -> 289 + function 290 + | Initialize _ -> 291 + let err = "Server can only recieve a single initialization request." in 292 + raise @@ LspError (HandshakeError err) 293 + | Shutdown -> 294 + initiate_shutdown () 295 + | CodeAction params -> 296 + code_action params 297 + | TextDocumentHover params -> 298 + hover params 299 + | TextDocumentCompletion params -> 300 + completion params 301 + | InlayHint params -> 302 + inlay_hint params 303 + | TextDocumentDefinition params -> 304 + definitions params 305 + | SemanticTokensDelta params -> 306 + Semantic_tokens.on_delta_request params 307 + | SemanticTokensFull params -> 308 + Semantic_tokens.on_full_request params 309 + | _ -> 310 + raise @@ LspError (UnknownRequest mthd) 311 + 312 + let handle (msg : RPC.Request.t) = 313 + Eio.traceln "Request: %s@." msg.method_; 314 + match Lsp_Request.of_jsonrpc msg with 315 + | Ok (E r) -> 316 + let resp = dispatch msg.method_ r in 317 + let json = Lsp_Request.yojson_of_result r resp in 318 + RPC.Response.ok msg.id json 319 + | Error err -> 320 + raise (LspError (DecodeError err)) 321 + 322 + let recv () = 323 + Option.bind (recv ()) @@ 324 + function 325 + | RPC.Packet.Request req -> 326 + begin 327 + match Lsp_Request.of_jsonrpc req with 328 + | Ok packed -> Some (req.id, packed) 329 + | Error err -> raise @@ LspError (DecodeError err) 330 + end 331 + | _ -> None 332 + 333 + let respond id req resp = 334 + let json = Lsp_Request.yojson_of_result req resp in 335 + send (RPC.Packet.Response (RPC.Response.ok id json)) 336 + end 337 + 338 + module Notification = struct 339 + type t = Lsp.Client_notification.t 340 + 341 + let dispatch : string -> t -> unit = fun mthd -> 342 + let server = State.get () in 343 + function 344 + | TextDocumentDidOpen ({ textDocument = { uri; _ } } as params) -> 345 + let text_document = Lsp.Text_document.make ~position_encoding: `UTF16 params in 346 + Hashtbl.replace server.documents { uri } text_document; 347 + Reporter.lsp_run publish_diagnostics uri @@ 348 + fun () -> 349 + Analysis.check server uri 350 + | DidSaveTextDocument{ textDocument; _; } -> 351 + begin 352 + match Hashtbl.find_opt server.documents textDocument with 353 + (* ocaml-lsp does *this* here: https://github.com/ocaml/ocaml-lsp/blob/8b47925eb44f907b8ec41a44c1b2a55447f1b439/ocaml-lsp-server/src/ocaml_lsp_server.ml#L757 *) 354 + | _ -> () 355 + end 356 + | TextDocumentDidChange{ textDocument = { uri; _ }; contentChanges } -> 357 + begin 358 + match Hashtbl.find_opt server.documents { uri } with 359 + | Some doc -> 360 + let new_doc = 361 + Lsp.Text_document.apply_content_changes 362 + doc 363 + contentChanges 364 + in 365 + Hashtbl.replace server.documents { uri } new_doc; 366 + Reporter.lsp_run publish_diagnostics uri @@ 367 + fun () -> 368 + Analysis.check server uri 369 + | None -> 370 + Reporter.lsp_run publish_diagnostics uri @@ 371 + fun () -> 372 + Reporter.fatalf Internal_error "%s" "could not find document at %s" (uri |> Lsp.Uri.to_path) 373 + end 374 + | _ -> 375 + raise @@ LspError (UnknownNotification mthd) 376 + 377 + let handle (msg : RPC.Notification.t) = 378 + Eio.traceln "Request: %s@." msg.method_; 379 + match Lsp_Notification.of_jsonrpc msg with 380 + | Ok notif -> 381 + dispatch msg.method_ notif 382 + | Error err -> 383 + raise @@ LspError (DecodeError err) 384 + 385 + let recv () = 386 + Option.bind (recv ()) @@ 387 + function 388 + | RPC.Packet.Notification msg -> 389 + begin 390 + match Lsp_Notification.of_jsonrpc msg with 391 + | Ok notif -> Some notif 392 + | Error err -> raise @@ LspError (DecodeError err) 393 + end 394 + | _ -> None 395 + end 396 + 397 + let run ~init k = 398 + State.run ~init k

+42

lib/language_server/LspShims.ml

··· 1 + (* 2 + * SPDX-FileCopyrightText: 2024 The Forester Project Contributors AND The RedPRL Development Team 3 + * 4 + * SPDX-License-Identifier: GPL-3.0-or-later OR Apache-2.0 WITH LLVM-exception 5 + * 6 + *) 7 + 8 + module L = Lsp.Types 9 + 10 + module Loc = struct 11 + let lsp_pos_of_pos (pos : Asai.Range.position) = 12 + L.Position.create 13 + ~line: (pos.line_num - 1) 14 + ~character: (pos.offset - pos.start_of_line) 15 + 16 + let lsp_range_of_range (r : Asai.Range.t option) = 17 + match r with 18 + | Some r -> 19 + let (start, stop) = 20 + match Asai.Range.view r with 21 + | `Range (start, stop) -> start, stop 22 + | `End_of_file pos -> pos, pos 23 + in 24 + L.Range.create 25 + ~start: (lsp_pos_of_pos start) 26 + ~end_: (lsp_pos_of_pos stop) 27 + | None -> 28 + (* When we have a message without a location, 29 + we set it's location to the start of the file, 30 + as we don't have any better choices. *) 31 + let start_of_file = L.Position.create ~line: 0 ~character: 0 in 32 + L.Range.create ~start: start_of_file ~end_: start_of_file 33 + end 34 + 35 + module Diagnostic = struct 36 + let lsp_severity_of_severity : Asai.Diagnostic.severity -> L.DiagnosticSeverity.t = function 37 + | Hint -> Hint 38 + | Info -> Information 39 + | Warning -> Warning 40 + | Error -> Error 41 + | Bug -> Error 42 + end

+261

lib/language_server/Semantic_tokens.ml

··· 1 + open Forester_core 2 + open Forester_compiler 3 + 4 + module L = Lsp.Types 5 + 6 + module State = Base.State 7 + 8 + module Token_type = struct 9 + 10 + type t = L.SemanticTokenTypes.t 11 + let legend : L.SemanticTokenTypes.t list = 12 + [ 13 + Namespace; 14 + Type; 15 + Class; 16 + Enum; 17 + Interface; 18 + Struct; 19 + TypeParameter; 20 + Parameter; 21 + Variable; 22 + Property; 23 + EnumMember; 24 + Event; 25 + Function; 26 + Method; 27 + Macro; 28 + Keyword; 29 + Modifier; 30 + Comment; 31 + String; 32 + Number; 33 + Regexp; 34 + Operator; 35 + Decorator 36 + ] 37 + let of_builtin t = t 38 + 39 + let token_types = 40 + List.map 41 + ( 42 + fun s -> 43 + match L.SemanticTokenTypes.yojson_of_t s with 44 + | `String s -> s 45 + | _ -> assert false 46 + ) 47 + legend 48 + 49 + let to_int = 50 + let module Table = MoreLabels.Hashtbl in 51 + let table = 52 + lazy( 53 + let t = Table.create (List.length legend) in 54 + List.iteri (fun data key -> Table.add t ~key ~data) legend; 55 + t 56 + ) 57 + in 58 + fun t -> Table.find (Lazy.force table) t 59 + 60 + let to_legend t = 61 + match L.SemanticTokenTypes.yojson_of_t t with 62 + | `String s -> s 63 + | _ -> assert false 64 + end 65 + 66 + module Token_modifiers_set = struct 67 + let list = 68 + [ 69 + "declaration"; 70 + "definition"; 71 + "readonly"; 72 + "static"; 73 + "deprecated"; 74 + "abstract"; 75 + "async"; 76 + "modification"; 77 + "documentation"; 78 + "defaultLibrary" 79 + ];; 80 + end 81 + 82 + let legend = 83 + L.SemanticTokensLegend.create 84 + ~tokenTypes: Token_type.token_types 85 + ~tokenModifiers: Token_modifiers_set.list 86 + 87 + type token = { 88 + line: int; 89 + start_char: int; 90 + length: int; 91 + token_type: int; 92 + token_modifiers: int; 93 + } 94 + [@@deriving show] 95 + 96 + type delta_token = { 97 + delta_line: int; 98 + delta_start_char: int; 99 + length: int; 100 + token_type: int; 101 + token_modifiers: int; 102 + } 103 + [@@deriving show] 104 + 105 + let encode_deltas : delta_token -> int list = fun 106 + { delta_line; delta_start_char; length; token_type; token_modifiers } 107 + -> 108 + [delta_line; delta_start_char; length; token_type; token_modifiers] 109 + 110 + let group f l = 111 + let rec grouping acc = function 112 + | [] -> acc 113 + | hd :: tl -> 114 + let l1, l2 = List.partition (f hd) tl in 115 + grouping ((hd :: l1) :: acc) l2 116 + in 117 + grouping [] l 118 + 119 + let tokens = 120 + List.filter_map 121 + ( 122 + fun 123 + Range.{ loc; value } 124 + -> 125 + let (L.Range.{ start; end_ }) = LspShims.Loc.lsp_range_of_range loc in 126 + (* Multiline tokens not supported*) 127 + if start.line <> end_.line then 128 + None 129 + else 130 + let line = start.line in 131 + let start_char = start.character in 132 + let length = end_.character - start.character in 133 + let token_type = 134 + match value with 135 + | Code.Text _ 136 + | Code.Math (_, _) 137 + | Code.Ident _ 138 + | Code.Verbatim _ 139 + | Code.Import (_, _) 140 + | Code.Let (_, _, _) 141 + | Code.Def (_, _, _) 142 + | Code.Group (_, _) 143 + | Code.Hash_ident _ 144 + | Code.Xml_ident (_, _) 145 + | Code.Subtree (_, _) 146 + | Code.Open _ 147 + | Code.Scope _ 148 + | Code.Put (_, _) 149 + | Code.Default (_, _) 150 + | Code.Get _ 151 + | Code.Fun (_, _) 152 + | Code.Object _ 153 + | Code.Patch _ 154 + | Code.Call (_, _) 155 + | Code.Decl_xmlns (_, _) 156 + | Code.Alloc _ 157 + | Code.Dx_sequent (_, _) 158 + | Code.Dx_query (_, _, _) 159 + | Code.Dx_prop (_, _) 160 + | Code.Dx_var _ 161 + | Code.Dx_const_content _ 162 + | Code.Dx_const_iri _ 163 + | Code.Error _ 164 + | Code.Comment _ 165 + | Code.Namespace (_, _) -> 166 + 1 167 + in 168 + Some { line; start_char; length; token_type; token_modifiers = 0 } 169 + ) 170 + 171 + let process_line 172 + : int option -> token list -> int * delta_token list 173 + = fun 174 + index_of_last_line 175 + tokens 176 + -> 177 + let line = (List.hd tokens).line in 178 + let deltas = 179 + List.fold_left 180 + ( 181 + fun 182 + (last_token, acc) 183 + ({ start_char; length; token_type; token_modifiers; line } as current_token) 184 + -> 185 + match last_token with 186 + | None -> 187 + let delta_line = match index_of_last_line with Some i -> i - line | None -> line in 188 + let delta_start_char = start_char in 189 + let t = { delta_line; delta_start_char; length; token_type; token_modifiers } in 190 + (Some current_token, t :: acc) 191 + | Some last_token -> 192 + (*If there is a previous token, we know we are still on the same line*) 193 + let delta_line = current_token.line - last_token.line in 194 + let delta_start_char = if delta_line > 0 then current_token.start_char else current_token.start_char - last_token.start_char in 195 + let delta = { delta_line; delta_start_char; length = current_token.length; token_type = current_token.token_type; token_modifiers; } in 196 + (Some current_token, delta :: acc) 197 + ) 198 + (None, []) 199 + tokens 200 + in 201 + (line, (snd deltas |> List.rev)) 202 + 203 + let delta_tokens tokens = 204 + tokens 205 + |> List.fold_left 206 + ( 207 + fun (last_line, acc) tokens_on_line -> 208 + let line, delta_tokens = process_line last_line tokens_on_line in 209 + Some line, delta_tokens :: acc 210 + ) 211 + (None, []) 212 + |> snd 213 + |> List.rev 214 + |> List.concat 215 + |> List.concat_map encode_deltas 216 + |> List.rev 217 + |> Array.of_list 218 + 219 + let semantic_tokens code = 220 + Some 221 + { 222 + L.SemanticTokens.resultId = None; 223 + data = ( 224 + code 225 + |> tokens 226 + |> group (fun s t -> t.line = s.line) 227 + |> delta_tokens 228 + ); 229 + } 230 + 231 + let get_doc_and_tokenize (textDocument : L.TextDocumentIdentifier.t) = 232 + let server = State.get () in 233 + let doc = Hashtbl.find_opt server.codes { uri = textDocument.uri } in 234 + match doc with 235 + | None -> None 236 + | Some tree -> 237 + let res = semantic_tokens tree.code in 238 + Eio.traceln ""; 239 + res 240 + 241 + let on_full_request 242 + : L.SemanticTokensParams.t -> 243 + L.SemanticTokens.t option 244 + = fun 245 + { textDocument; _ } 246 + -> 247 + (get_doc_and_tokenize textDocument) 248 + 249 + let on_delta_request 250 + : L.SemanticTokensDeltaParams.t -> 251 + [`SemanticTokens of L.SemanticTokens.t 252 + | `SemanticTokensDelta of L.SemanticTokensDelta.t] option 253 + = fun 254 + { 255 + textDocument; 256 + _; 257 + } 258 + -> 259 + Option.map 260 + (fun tokens -> (`SemanticTokens tokens)) 261 + (get_doc_and_tokenize textDocument)

+35

lib/language_server/dune

··· 1 + ;;; SPDX-FileCopyrightText: 2024 The Forester Project Contributors 2 + ;;; 3 + ;;; SPDX-License-Identifier: GPL-3.0-or-later OR Apache-2.0 WITH LLVM-exception 4 + 5 + (library 6 + (name Forester_lsp) 7 + (libraries 8 + algaeff 9 + repr 10 + unix 11 + forester.prelude 12 + forester.core 13 + forester.compiler 14 + forester.frontend 15 + forester.forest 16 + lsp 17 + asai 18 + eio 19 + eio_main 20 + eio.unix 21 + jsonrpc 22 + yojson 23 + bwd 24 + iri 25 + yuujinchou 26 + fmt 27 + ) 28 + (preprocess 29 + (pps ppx_deriving.show ppx_repr ppx_yojson_conv)) 30 + (public_name forester.language_server)) 31 + 32 + ;(env 33 + ; (dev 34 + ; (flags 35 + ; (:standard -w -66-32-33-27-26))))

Configure Feed

Configure Feed