Something went wrong. Try again.
ocaml
Something went wrong. Try again.
5.0 kB · 167 lines
OCaml
at pp-ast
123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168(* * SPDX-FileCopyrightText: 2024 The Forester Project Contributors * SPDX-FileCopyrightText: 2026 The Forester Project Contributors * * SPDX-License-Identifier: GPL-3.0-or-later *)
open Forester_coreopen Forester_parser
open struct module L = Lsp.Typesend
type delim = Brace | Square | Paren | Math_inline | Math_display
type purpose = | Body | Subtree_address | Reference_address | Asset | Date | Math | Query[@@deriving show]
type frame = {delim: delim; purpose: purpose}type level = {frame: frame option; mutable last_closed: purpose option}type t = {enclosing: frame list}
let purpose (t : t) : purpose = match t.enclosing with f :: _ -> f.purpose | [] -> Body
let in_math (t : t) : bool = purpose t = Math
let token_head : Tokens.token -> string option = function | IDENT s -> Some s | SUBTREE -> Some "subtree" | SCOPE -> Some "scope" | PUT -> Some "put" | DEFAULT -> Some "put?" | GET -> Some "get" | IMPORT -> Some "import" | EXPORT -> Some "export" | NAMESPACE -> Some "namespace" | OPEN -> Some "open" | DEF -> Some "def" | ALLOC -> Some "alloc" | LET -> Some "let" | FUN -> Some "fun" | OBJECT -> Some "object" | PATCH -> Some "patch" | CALL -> Some "call" | DATALOG -> Some "datalog" | XML_ELT_IDENT (_, name) -> Some name | DECL_XMLNS name -> Some ("xmlns:" ^ name) | HASH_IDENT _ | TEXT _ | VERBATIM _ | COMMENT _ | WHITESPACE _ | SLASH | LBRACE | RBRACE | LSQUARE | RSQUARE | LPAREN | RPAREN | HASH_LBRACE | HASH_HASH_LBRACE | TICK | AT_SIGN | HASH | EOF | DX_ENTAILED | DX_VAR _ -> None
let purpose_for ~pending_head ~enclosing_purpose ~prev_sibling_purpose ~(delim : delim) : purpose = match delim with | Math_inline | Math_display -> Math | Brace -> begin match pending_head with | Some "transclude" -> Reference_address | Some "import" -> Reference_address | Some "route-asset" -> Asset | Some "date" -> Date | Some "query" -> Query | _ -> enclosing_purpose end | Square -> begin match pending_head with | Some "subtree" -> Subtree_address | Some "route-asset" -> Asset | Some "date" -> Date | None when enclosing_purpose = Body -> Reference_address | _ -> enclosing_purpose end | Paren -> begin match pending_head with | Some "route-asset" -> Asset | Some "date" -> Date | None when enclosing_purpose = Body && prev_sibling_purpose = Some Reference_address -> Reference_address | _ -> enclosing_purpose end
let dispatch stack lexbuf = match Stack.top stack with | Lexer.Main -> Lexer.token stack lexbuf | Ident_init -> Lexer.ident_init stack lexbuf | Ident_fragments -> Lexer.ident_fragments stack lexbuf | Verbatim (herald, buffer) -> Lexer.verbatim stack herald buffer lexbuf
let classify ~(document : Lsp.Text_document.t) ~(position : L.Position.t) : t = let text = Lsp.Text_document.text document in let source : Grace.Source.t = `String {name = None; content = text} in let cursor = (Analysis.byte_index_of_position ~source:(Range.total ~source) position :> int) in let levels = ref [{frame = None; last_closed = None}] in let pending_head = ref None in let current_purpose () = match !levels with | {frame = Some f; _} :: _ -> f.purpose | {frame = None; _} :: _ | [] -> Body in let prev_sibling_purpose () = match !levels with {last_closed; _} :: _ -> last_closed | [] -> None in let prev_was_lsquare = ref false in let push delim = let p = if delim = Square && !prev_was_lsquare then Reference_address else purpose_for ~pending_head:!pending_head ~enclosing_purpose:(current_purpose ()) ~prev_sibling_purpose:(prev_sibling_purpose ()) ~delim in levels := {frame = Some {delim; purpose = p}; last_closed = None} :: !levels; pending_head := None; prev_was_lsquare := delim = Square in let pop () = match !levels with | closed :: (parent :: _ as rest) -> Option.iter (fun f -> parent.last_closed <- Some f.purpose) closed.frame; levels := rest | _ -> () in let handle_token (tok : Tokens.token) = match tok with | LBRACE -> push Brace | LSQUARE -> push Square | LPAREN -> push Paren | HASH_LBRACE -> push Math_inline | HASH_HASH_LBRACE -> push Math_display | RBRACE | RSQUARE | RPAREN -> pop (); pending_head := None; prev_was_lsquare := false | tok -> pending_head := token_head tok; prev_was_lsquare := false in let stack = Lexer.create_mode_stack () in let lexbuf = Lexing.from_string text in begin try let continue_ = ref true in while !continue_ do let toks = dispatch stack lexbuf in if Lexing.lexeme_end lexbuf > cursor then continue_ := false else begin List.iter handle_token toks; if List.mem Tokens.EOF toks then continue_ := false end done with _ -> () end; {enclosing = List.filter_map (fun {frame; _} -> frame) !levels}