diff --git a/CHANGELOG.md b/CHANGELOG.md index 09b3737db67..e29845689fd 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -38,6 +38,7 @@ - Build system: Add OpenTelemetry tracing support for cli commands. https://github.com/rescript-lang/rescript/pull/8370 - Use a single vendored @rescript/react package across the repo. https://github.com/rescript-lang/rescript/pull/7525 - Improve deprecated attribute extraction and support record form. https://github.com/rescript-lang/rescript/pull/8396 +- Refactor analysis to decouple I/O from core logic. https://github.com/rescript-lang/rescript/pull/8426 #### :house: Internal diff --git a/analysis/bin/main.ml b/analysis/bin/main.ml index e5075f102ed..0afe23855ab 100644 --- a/analysis/bin/main.ml +++ b/analysis/bin/main.ml @@ -134,22 +134,18 @@ let main () = | _ -> print_endline "\"ERR: Did not find root \"") | [_; "completion"; path; line; col; currentFile] -> printHeaderInfo path line col; - Commands.completion ~debug ~path + Cli.completion ~debug ~path ~pos:(int_of_string line, int_of_string col) ~currentFile | [_; "completionResolve"; path; modulePath] -> - Commands.completionResolve ~path ~modulePath + Cli.completionResolve ~path ~modulePath | [_; "definition"; path; line; col] -> - Commands.definition ~path - ~pos:(int_of_string line, int_of_string col) - ~debug + Cli.definition ~path ~pos:(int_of_string line, int_of_string col) ~debug | [_; "typeDefinition"; path; line; col] -> - Commands.typeDefinition ~path - ~pos:(int_of_string line, int_of_string col) - ~debug + Cli.typeDefinition ~path ~pos:(int_of_string line, int_of_string col) ~debug | [_; "documentSymbol"; path] -> DocumentSymbol.command ~path | [_; "hover"; path; line; col; currentFile; supportsMarkdownLinks] -> - Commands.hover ~path + Cli.hover ~path ~pos:(int_of_string line, int_of_string col) ~currentFile ~debug ~supportsMarkdownLinks: @@ -159,7 +155,7 @@ let main () = | [ _; "signatureHelp"; path; line; col; currentFile; allowForConstructorPayloads; ] -> - Commands.signatureHelp ~path + Cli.signatureHelp ~path ~pos:(int_of_string line, int_of_string col) ~currentFile ~debug ~allowForConstructorPayloads: @@ -167,13 +163,13 @@ let main () = | "true" -> true | _ -> false) | [_; "inlayHint"; path; line_start; line_end; maxLength] -> - Commands.inlayhint ~path + Cli.inlayhint ~path ~pos:(int_of_string line_start, int_of_string line_end) ~maxLength ~debug - | [_; "codeLens"; path] -> Commands.codeLens ~path ~debug + | [_; "codeLens"; path] -> Cli.codeLens ~path ~debug | [_; "codeAction"; path; startLine; startCol; endLine; endCol; currentFile] -> - Commands.codeAction ~path + Cli.codeAction ~path ~startPos:(int_of_string startLine, int_of_string startCol) ~endPos:(int_of_string endLine, int_of_string endCol) ~currentFile ~debug @@ -183,34 +179,29 @@ let main () = | "add-missing-cases" -> Codemod.AddMissingCases | _ -> raise (Failure "unsupported type") in + let source = Files.readFile path |> Option.value ~default:"" in let res = - Codemod.transform ~path + Codemod.transform ~source ~pos:(int_of_string line, int_of_string col) ~debug ~typ ~hint |> Json.escape in Printf.printf "\"%s\"" res - | [_; "diagnosticSyntax"; path] -> Commands.diagnosticSyntax ~path + | [_; "diagnosticSyntax"; path] -> Cli.diagnosticSyntax ~path | [_; "references"; path; line; col] -> - Commands.references ~path - ~pos:(int_of_string line, int_of_string col) - ~debug + Cli.references ~path ~pos:(int_of_string line, int_of_string col) ~debug | [_; "prepareRename"; path; line; col] -> - Commands.prepareRename ~path - ~pos:(int_of_string line, int_of_string col) - ~debug + Cli.prepareRename ~path ~pos:(int_of_string line, int_of_string col) ~debug | [_; "rename"; path; line; col; newName] -> - Commands.rename ~path + Cli.rename ~path ~pos:(int_of_string line, int_of_string col) ~newName ~debug - | [_; "semanticTokens"; currentFile] -> - SemanticTokens.semanticTokens ~currentFile + | [_; "semanticTokens"; currentFile] -> Cli.semanticTokens ~path:currentFile | [_; "createInterface"; path; cmiFile] -> Printf.printf "\"%s\"" (Json.escape (CreateInterface.command ~path ~cmiFile)) - | [_; "format"; path] -> - Printf.printf "\"%s\"" (Json.escape (Commands.format ~path)) - | [_; "test"; path] -> Commands.test ~path + | [_; "format"; path] -> Cli.format ~path + | [_; "test"; path] -> Cli.test ~path | [_; "cmt"; rescript_json; cmt_path] -> CmtViewer.dump rescript_json cmt_path | args when List.mem "-h" args || List.mem "--help" args -> prerr_endline help | _ -> diff --git a/analysis/src/Cli.ml b/analysis/src/Cli.ml new file mode 100644 index 00000000000..bd8ced94a14 --- /dev/null +++ b/analysis/src/Cli.ml @@ -0,0 +1,385 @@ +let completion ~debug ~path ~pos ~currentFile = + let full = Cmt.loadFullCmtFromPath ~path in + let kindFile = Files.classifySourceFile currentFile in + match Files.readFile currentFile with + | None | Some "" -> Protocol.null |> print_endline + | Some source -> + Commands.completion ~debug ~source ~kindFile ~pos ~full + |> List.map Protocol.stringifyCompletionItem + |> Protocol.array |> print_endline + +let completionResolve ~path ~modulePath = + let full = Cmt.loadFullCmtFromPath ~path in + let result = + match Commands.completionResolve ~full ~modulePath with + | None -> Protocol.null + | Some content -> Protocol.wrapInQuotes content + in + print_endline result + +let inlayhint ~path ~pos ~maxLength ~debug = + let full = Cmt.loadFullCmtFromPath ~path in + let kindFile = Files.classifySourceFile path in + match Files.readFile path with + | None -> Protocol.null |> print_endline + | Some source -> ( + match Hint.inlay ~source ~kindFile ~pos ~maxLength ~full ~debug with + | Some hints -> + hints + |> List.map Protocol.stringifyHint + |> Protocol.array |> print_endline + | None -> Protocol.null |> print_endline) + +let codeLens ~path ~debug = + let full = Cmt.loadFullCmtFromPath ~path in + let kindFile = Files.classifySourceFile path in + match Files.readFile path with + | None -> Protocol.null |> print_endline + | Some source -> ( + match Hint.codeLens ~source ~kindFile ~full ~debug with + | Some lens -> + lens + |> List.map Protocol.stringifyCodeLens + |> Protocol.array |> print_endline + | None -> Protocol.null |> print_endline) + +let hover ~path ~pos ~currentFile ~debug ~supportsMarkdownLinks = + let full = Cmt.loadFullCmtFromPath ~path in + let kindFile = Files.classifySourceFile currentFile in + match Files.readFile currentFile with + | None -> Protocol.null |> print_endline + | Some source -> + let result = + match + Commands.hover ~source ~kindFile ~pos ~debug ~supportsMarkdownLinks + ~full + with + | Some value -> Protocol.stringifyHover value + | None -> Protocol.null + in + print_endline result + +let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = + let full = Cmt.loadFullCmtFromPath ~path in + let kindFile = Files.classifySourceFile currentFile in + match Files.readFile currentFile with + | None -> Protocol.null |> print_endline + | Some source -> + Commands.signatureHelp ~source ~kindFile ~pos ~allowForConstructorPayloads + ~full ~debug + |> Protocol.stringifySignatureHelp |> print_endline + +let codeAction ~path ~startPos ~endPos ~currentFile ~debug = + let kindFile = Files.classifySourceFile currentFile in + match Files.readFile currentFile with + | None -> Protocol.null |> print_endline + | Some source -> + Xform.extractCodeActions ~path ~startPos ~endPos ~source ~kindFile ~debug + |> CodeActions.stringifyCodeActions |> print_endline + +let definition ~path ~pos ~debug = + let full = Cmt.loadFullCmtFromPath ~path in + print_endline + (match Commands.definition ~full ~pos ~debug with + | None -> Protocol.null + | Some location -> location |> Protocol.stringifyLocation) + +let typeDefinition ~path ~pos ~debug = + let full = Cmt.loadFullCmtFromPath ~path in + print_endline + (match Commands.typeDefinition ~full ~pos ~debug with + | None -> Protocol.null + | Some location -> location |> Protocol.stringifyLocation) + +let references ~path ~pos ~debug = + let full = Cmt.loadFullCmtFromPath ~path in + let allLocs = Commands.references ~full ~pos ~debug in + print_endline + (if allLocs = [] then Protocol.null + else + "[\n" + ^ (allLocs |> List.map Protocol.stringifyLocation |> String.concat ",\n") + ^ "\n]") + +let rename ~path ~pos ~newName ~debug = + let full = Cmt.loadFullCmtFromPath ~path in + let result = + match Commands.rename ~full ~pos ~newName ~debug with + | None -> Protocol.null + | Some (fileRenames, textDocumentEdits) -> + let fileRenamesString = + fileRenames |> List.map Protocol.stringifyRenameFile + in + let textDocumentEditsString = + textDocumentEdits |> List.map Protocol.stringifyTextDocumentEdit + in + "[\n" + ^ (fileRenamesString @ textDocumentEditsString |> String.concat ",\n") + ^ "\n]" + in + print_endline result + +let prepareRename ~path ~pos ~debug = + let full = Cmt.loadFullCmtFromPath ~path in + let result = + match Commands.prepareRename ~full ~pos ~debug with + | None -> Protocol.null + | Some (Range range) -> Protocol.stringifyRange range + | Some (Placeholder rangeph) -> + Protocol.stringifyRangeWithPlaceholder rangeph + in + print_endline result + +let format ~path = + match Files.readFile path with + | None -> Protocol.null |> print_endline + | Some source -> ( + let kindFile = Files.classifySourceFile path in + match Commands.format ~source ~kindFile with + | Ok textEdits -> ( + match textEdits with + | {newText} :: _ -> Printf.printf "\"%s\"" (Json.escape newText) + | _ -> Protocol.null |> print_endline) + | Error _ -> Protocol.null |> print_endline) + +let diagnosticSyntax ~path = + match Files.readFile path with + | None -> Protocol.array [""] |> print_endline + | Some source -> + let kindFile = Files.classifySourceFile path in + Diagnostics.document_syntax ~source ~kindFile + |> List.map Protocol.stringifyDiagnostic + |> Protocol.array |> print_endline + +let semanticTokens ~path = + match Files.readFile path with + | None -> Protocol.null |> print_endline + | Some source -> + let kindFile = Files.classifySourceFile path in + let tokens = SemanticTokens.semanticTokens ~source ~kindFile in + let data = SemanticTokens.Token.arrayToJsonString tokens.data in + Printf.printf "{\"data\":%s}" data + +let test ~path = + Uri.stripPath := true; + match Files.readFile path with + | None -> assert false + | Some text -> + let lines = text |> String.split_on_char '\n' in + let processLine i line = + let createCurrentFile () = + let currentFile, cout = + Filename.open_temp_file "def" ("txt." ^ Filename.extension path) + in + let removeLineComment l = + let len = String.length l in + let rec loop i = + if i + 2 <= len && l.[i] = '/' && l.[i + 1] = '/' then Some (i + 2) + else if i + 2 < len && l.[i] = ' ' then loop (i + 1) + else None + in + match loop 0 with + | None -> l + | Some indexAfterComment -> + String.make indexAfterComment ' ' + ^ String.sub l indexAfterComment (len - indexAfterComment) + in + lines + |> List.iteri (fun j l -> + let lineToOutput = + if j == i - 1 then removeLineComment l else l + in + Printf.fprintf cout "%s\n" lineToOutput); + close_out cout; + currentFile + in + if Str.string_match (Str.regexp "^ *//[ ]*\\^") line 0 then + let matched = Str.matched_string line in + let len = line |> String.length in + let mlen = String.length matched in + let rest = String.sub line mlen (len - mlen) in + let line = i - 1 in + let col = mlen - 1 in + if mlen >= 3 then ( + (match String.sub rest 0 3 with + | "db+" -> Log.verbose := true + | "db-" -> Log.verbose := false + | "dv+" -> Debug.debugLevel := Verbose + | "dv-" -> Debug.debugLevel := Off + | "in+" -> Cfg.inIncrementalTypecheckingMode := true + | "in-" -> Cfg.inIncrementalTypecheckingMode := false + | "ve+" -> ( + let version = String.sub rest 3 (String.length rest - 3) in + let version = String.trim version in + if Debug.verbose () then + Printf.printf "Setting version: %s\n" version; + match String.split_on_char '.' version with + | [majorRaw; minorRaw] -> + let version = (int_of_string majorRaw, int_of_string minorRaw) in + Packages.overrideRescriptVersion := Some version + | _ -> ()) + | "ve-" -> Packages.overrideRescriptVersion := None + | "def" -> + print_endline + ("Definition " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + definition ~path ~pos:(line, col) ~debug:true + | "com" -> + print_endline + ("Complete " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + let currentFile = createCurrentFile () in + completion ~debug:true ~path ~pos:(line, col) ~currentFile; + Sys.remove currentFile + | "cre" -> + let modulePath = String.sub rest 3 (String.length rest - 3) in + let modulePath = String.trim modulePath in + print_endline ("Completion resolve: " ^ modulePath); + completionResolve ~path ~modulePath + | "dce" -> + print_endline ("DCE " ^ path); + Reanalyze.RunConfig.runConfig.suppress <- ["src"]; + Reanalyze.RunConfig.runConfig.unsuppress <- + [Filename.concat "src" "dce"]; + DceCommand.command () + | "doc" -> + print_endline ("DocumentSymbol " ^ path); + DocumentSymbol.command ~path + | "hig" -> + print_endline ("Highlight " ^ path); + let source = Files.readFile path |> Option.get in + let kindFile = Files.classifySourceFile path in + + SemanticTokens.command ~debug:true + ~emitter:(SemanticTokens.Token.createEmitter ()) + ~source ~kindFile + | "hov" -> + print_endline + ("Hover " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + let currentFile = createCurrentFile () in + hover ~supportsMarkdownLinks:true ~path ~pos:(line, col) + ~currentFile ~debug:true; + Sys.remove currentFile + | "she" -> + print_endline + ("Signature help " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + let currentFile = createCurrentFile () in + signatureHelp ~path ~pos:(line, col) ~currentFile ~debug:true + ~allowForConstructorPayloads:true; + Sys.remove currentFile + | "int" -> + print_endline ("Create Interface " ^ path); + let cmiFile = + let open Filename in + let ( ++ ) = concat in + let name = chop_extension (basename path) ^ ".cmi" in + let dir = dirname path in + dir ++ parent_dir_name ++ "lib" ++ "bs" ++ "src" ++ name + in + Printf.printf "%s" (CreateInterface.command ~path ~cmiFile) + | "ref" -> + print_endline + ("References " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + references ~path ~pos:(line, col) ~debug:true + | "pre" -> + print_endline + ("PrepareRename " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + prepareRename ~path ~pos:(line, col) ~debug:true + | "ren" -> + let newName = String.sub rest 4 (len - mlen - 4) in + let () = + print_endline + ("Rename " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col ^ " " ^ newName) + in + rename ~path ~pos:(line, col) ~newName ~debug:true + | "typ" -> + print_endline + ("TypeDefinition " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + typeDefinition ~path ~pos:(line, col) ~debug:true + | "xfm" -> + let currentFile = createCurrentFile () in + (* +2 is to ensure that the character ^ points to is what's considered the end of the selection. *) + let endCol = col + try String.index rest '^' + 2 with _ -> 0 in + let endPos = (line, endCol) in + let startPos = (line, col) in + if startPos = endPos then + print_endline + ("Xform " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col) + else + print_endline + ("Xform " ^ path ^ " start: " ^ Pos.toString startPos + ^ ", end: " ^ Pos.toString endPos); + + let source = + Files.readFile currentFile |> Option.value ~default:"" + in + let kindFile = Files.classifySourceFile currentFile in + let codeActions = + Xform.extractCodeActions ~path ~startPos ~endPos ~source ~kindFile + ~debug:true + in + Sys.remove currentFile; + codeActions + |> List.iter (fun {Protocol.title; edit = {documentChanges}} -> + Printf.printf "Hit: %s\n" title; + documentChanges + |> List.iter (fun dc -> + match dc with + | Protocol.TextDocumentEdit tde -> + Printf.printf "\nTextDocumentEdit: %s\n" + tde.textDocument.uri; + + tde.edits + |> List.iter (fun {Protocol.range; newText} -> + let indent = + String.make range.start.character ' ' + in + Printf.printf + "%s\nnewText:\n%s<--here\n%s%s\n" + (Protocol.stringifyRange range) + indent indent newText) + | CreateFile cf -> + Printf.printf "\nCreateFile: %s\n" cf.uri)) + | "c-a" -> + let hint = String.sub rest 3 (String.length rest - 3) in + print_endline + ("Codemod AddMissingCases" ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + let source = Files.readFile path |> Option.value ~default:"" in + Codemod.transform ~source ~pos:(line, col) ~debug:true + ~typ:AddMissingCases ~hint + |> print_endline + | "dia" -> diagnosticSyntax ~path + | "hin" -> + (* Get all inlay Hint between line 1 and n. + Don't get the first line = 0. + *) + let line_start = 1 in + let line_end = 34 in + print_endline + ("Inlay Hint " ^ path ^ " " ^ string_of_int line_start ^ ":" + ^ string_of_int line_end); + inlayhint ~path ~pos:(line_start, line_end) ~maxLength:"25" + ~debug:false + | "cle" -> + print_endline ("Code Lens " ^ path); + codeLens ~path ~debug:false + | "ast" -> + print_endline + ("Dump AST " ^ path ^ " " ^ string_of_int line ^ ":" + ^ string_of_int col); + let currentFile = createCurrentFile () in + DumpAst.dump ~pos:(line, col) ~currentFile; + Sys.remove currentFile + | "sem" -> semanticTokens ~path + | _ -> ()); + print_newline ()) + in + lines |> List.iteri processLine diff --git a/analysis/src/Codemod.ml b/analysis/src/Codemod.ml index 5c273637def..970dfb79413 100644 --- a/analysis/src/Codemod.ml +++ b/analysis/src/Codemod.ml @@ -5,8 +5,8 @@ let rec collectPatterns p = | Ppat_or (p1, p2) -> collectPatterns p1 @ [p2] | _ -> [p] -let transform ~path ~pos ~debug ~typ ~hint = - let structure, printExpr, _, _ = Xform.parseImplementation ~filename:path in +let transform ~source ~pos ~debug ~typ ~hint = + let structure, printExpr, _, _ = Xform.parseImplementation ~source in match typ with | AddMissingCases -> ( let source = "let " ^ hint ^ " = ()" in diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 40799348ec5..0ce67fad485 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -1,17 +1,13 @@ -let completion ~debug ~path ~pos ~currentFile = - let completions = - match - Completions.getCompletions ~debug ~path ~pos ~currentFile ~forHover:false - with - | None -> [] - | Some (completions, full, _) -> - completions - |> List.map (CompletionBackEnd.completionToItem ~full) - |> List.map Protocol.stringifyCompletionItem - in - completions |> Protocol.array |> print_endline +let completion ~debug ~source ~kindFile ~pos ~full = + match + Completions.getCompletions ~debug ~source ~kindFile ~pos ~full + ~forHover:false + with + | None -> [] + | Some (completions, full, _) -> + completions |> List.map (CompletionBackEnd.completionToItem ~full) -let completionResolve ~path ~modulePath = +let completionResolve ~(full : SharedTypes.full option) ~modulePath = (* We ignore the internal module path as of now because there's currently no use case for it. But, if we wanted to move resolving documentation for regular modules and not just file modules to the completionResolve @@ -23,44 +19,26 @@ let completionResolve ~path ~modulePath = | [] -> raise (Failure "Invalid module path.") in let docstring = - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> if Debug.verbose () then Printf.printf "[completion_resolve] Could not load cmt\n"; - Protocol.null + None | Some full -> ( match ProcessCmt.fileForModule ~package:full.package moduleName with | None -> if Debug.verbose () then Printf.printf "[completion_resolve] Did not find file for module %s\n" moduleName; - Protocol.null - | Some file -> - file.structure.docstring |> String.concat "\n\n" - |> Protocol.wrapInQuotes) - in - print_endline docstring - -let inlayhint ~path ~pos ~maxLength ~debug = - let result = - match Hint.inlay ~path ~pos ~maxLength ~debug with - | Some hints -> hints |> Protocol.array - | None -> Protocol.null + None + | Some file -> Some (file.structure.docstring |> String.concat "\n\n")) in - print_endline result + docstring -let codeLens ~path ~debug = +let hover ~source ~kindFile ~pos ~supportsMarkdownLinks ~full ~debug = let result = - match Hint.codeLens ~path ~debug with - | Some lens -> lens |> Protocol.array - | None -> Protocol.null - in - print_endline result - -let hover ~path ~pos ~currentFile ~debug ~supportsMarkdownLinks = - let result = - match Cmt.loadFullCmtFromPath ~path with - | None -> Protocol.null + match full with + | None -> None | Some full -> ( match References.getLocItem ~full ~pos ~debug with | None -> ( @@ -68,12 +46,12 @@ let hover ~path ~pos ~currentFile ~debug ~supportsMarkdownLinks = Printf.printf "Nothing at that position. Now trying to use completion.\n"; match - Hover.getHoverViaCompletions ~debug ~path ~pos ~currentFile - ~forHover:true ~supportsMarkdownLinks + Hover.getHoverViaCompletions ~debug ~source ~kindFile ~pos + ~forHover:true ~supportsMarkdownLinks ~full:(Some full) with - | None -> Protocol.null - | Some hover -> hover) - | Some locItem -> ( + | None -> None + | Some hover -> Some hover) + | Some locItem -> let isModule = match locItem.locType with | LModule _ | TopLevelModule _ -> true @@ -91,34 +69,24 @@ let hover ~path ~pos ~currentFile ~debug ~supportsMarkdownLinks = (* Skip if range is all zero, unless it's a module *) (not isModule) && posIsZero loc.loc_start && posIsZero loc.loc_end in - if skipZero then Protocol.null - else - let hoverText = Hover.newHover ~supportsMarkdownLinks ~full locItem in - match hoverText with - | None -> Protocol.null - | Some s -> Protocol.stringifyHover s)) - in - print_endline result - -let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = - let result = - match - SignatureHelp.signatureHelp ~path ~pos ~currentFile ~debug - ~allowForConstructorPayloads - with - | None -> - {Protocol.signatures = []; activeSignature = None; activeParameter = None} - | Some res -> res + if skipZero then None + else Hover.newHover ~supportsMarkdownLinks ~full locItem) in - print_endline (Protocol.stringifySignatureHelp result) + result -let codeAction ~path ~startPos ~endPos ~currentFile ~debug = - Xform.extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug - |> CodeActions.stringifyCodeActions |> print_endline +let signatureHelp ~source ~kindFile ~pos ~allowForConstructorPayloads ~full + ~debug = + match + SignatureHelp.signatureHelp ~debug ~source ~kindFile ~pos + ~allowForConstructorPayloads ~full + with + | None -> + {Protocol.signatures = []; activeSignature = None; activeParameter = None} + | Some res -> res -let definition ~path ~pos ~debug = +let definition ~full ~pos ~debug = let locationOpt = - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> None | Some full -> ( match References.getLocItem ~full ~pos ~debug with @@ -150,14 +118,11 @@ let definition ~path ~pos ~debug = } | Some _ -> None)) in - print_endline - (match locationOpt with - | None -> Protocol.null - | Some location -> location |> Protocol.stringifyLocation) + locationOpt -let typeDefinition ~path ~pos ~debug = +let typeDefinition ~full ~pos ~debug = let maybeLocation = - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> None | Some full -> ( match References.getLocItem ~full ~pos ~debug with @@ -172,14 +137,11 @@ let typeDefinition ~path ~pos ~debug = range = Utils.cmtLocToRange loc; })) in - print_endline - (match maybeLocation with - | None -> Protocol.null - | Some location -> location |> Protocol.stringifyLocation) + maybeLocation -let references ~path ~pos ~debug = +let references ~full ~pos ~debug = let allLocs = - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> [] | Some full -> ( match References.getLocItem ~full ~pos ~debug with @@ -194,22 +156,23 @@ let references ~path ~pos ~debug = | Some loc -> loc | None -> Uri.toTopLevelLoc uri2 in - Protocol.stringifyLocation - {uri = Uri.toString uri2; range = Utils.cmtLocToRange loc} + + { + Protocol.uri = Uri.toString uri2; + range = Utils.cmtLocToRange loc; + } :: acc) []) in - print_endline - (if allLocs = [] then Protocol.null - else "[\n" ^ (allLocs |> String.concat ",\n") ^ "\n]") + allLocs -let rename ~path ~pos ~newName ~debug = +let rename ~full ~pos ~newName ~debug = let result = - match Cmt.loadFullCmtFromPath ~path with - | None -> Protocol.null + match full with + | None -> None | Some full -> ( match References.getLocItem ~full ~pos ~debug with - | None -> Protocol.null + | None -> None | Some locItem -> let allReferences = References.allReferencesForLocItem ~full locItem in let referencesToToplevelModules = @@ -263,24 +226,16 @@ let rename ~path ~pos ~newName ~debug = textDocumentEdit :: acc) textEditsByUri [] in - let fileRenamesString = - fileRenames |> List.map Protocol.stringifyRenameFile - in - let textDocumentEditsString = - textDocumentEdits |> List.map Protocol.stringifyTextDocumentEdit - in - "[\n" - ^ (fileRenamesString @ textDocumentEditsString |> String.concat ",\n") - ^ "\n]") + Some (fileRenames, textDocumentEdits)) in - print_endline result + result -let prepareRename ~path ~pos ~debug = - match Cmt.loadFullCmtFromPath ~path with - | None -> print_endline Protocol.null +let prepareRename ~full ~pos ~debug = + match full with + | None -> None | Some full -> ( match References.getLocItem ~full ~pos ~debug with - | None -> print_endline Protocol.null + | None -> None | Some locItem -> let range = Utils.cmtLocToRange locItem.loc in let placeholderOpt = @@ -290,245 +245,55 @@ let prepareRename ~path ~pos ~debug = Some name | _ -> None in - let fields = - [("range", Some (Protocol.stringifyRange range))] - @ - match placeholderOpt with - | None -> [] - | Some s -> [("placeholder", Some (Protocol.wrapInQuotes s))] - in - print_endline (Protocol.stringifyObject fields)) + Some + (match placeholderOpt with + | None -> Protocol.Range range + | Some placeholder -> Protocol.Placeholder {range; placeholder})) -let format ~path = - if Filename.check_suffix path ".res" then - let {Res_driver.parsetree = structure; comments; diagnostics} = - Res_driver.parsing_engine.parse_implementation ~for_printer:true - ~filename:path - in - if List.length diagnostics > 0 then "" - else Res_printer.print_implementation ~comments structure - else if Filename.check_suffix path ".resi" then - let {Res_driver.parsetree = signature; comments; diagnostics} = - Res_driver.parsing_engine.parse_interface ~for_printer:true ~filename:path +let format ~source ~kindFile = + let create_range text = + let lines = text |> String.split_on_char '\n' in + let lines_len = List.length lines in + let character = + match List.nth_opt lines lines_len with + | Some line -> String.length line + | None -> 0 in - if List.length diagnostics > 0 then "" - else Res_printer.print_interface ~comments signature - else "" - -let diagnosticSyntax ~path = - print_endline (Diagnostics.document_syntax ~path |> Protocol.array) + Protocol. + { + range = + { + start = {line = 0; character = 0}; + end_ = {line = lines_len - 1; character}; + }; + newText = text; + } + in -let test ~path = - Uri.stripPath := true; - match Files.readFile path with - | None -> assert false - | Some text -> - let lines = text |> String.split_on_char '\n' in - let processLine i line = - let createCurrentFile () = - let currentFile, cout = - Filename.open_temp_file "def" ("txt." ^ Filename.extension path) - in - let removeLineComment l = - let len = String.length l in - let rec loop i = - if i + 2 <= len && l.[i] = '/' && l.[i + 1] = '/' then Some (i + 2) - else if i + 2 < len && l.[i] = ' ' then loop (i + 1) - else None - in - match loop 0 with - | None -> l - | Some indexAfterComment -> - String.make indexAfterComment ' ' - ^ String.sub l indexAfterComment (len - indexAfterComment) - in - lines - |> List.iteri (fun j l -> - let lineToOutput = - if j == i - 1 then removeLineComment l else l - in - Printf.fprintf cout "%s\n" lineToOutput); - close_out cout; - currentFile + let result = + match kindFile with + | Files.Res -> ( + let {Res_driver.parsetree = structure; comments; diagnostics} = + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:true ~source in - if Str.string_match (Str.regexp "^ *//[ ]*\\^") line 0 then - let matched = Str.matched_string line in - let len = line |> String.length in - let mlen = String.length matched in - let rest = String.sub line mlen (len - mlen) in - let line = i - 1 in - let col = mlen - 1 in - if mlen >= 3 then ( - (match String.sub rest 0 3 with - | "db+" -> Log.verbose := true - | "db-" -> Log.verbose := false - | "dv+" -> Debug.debugLevel := Verbose - | "dv-" -> Debug.debugLevel := Off - | "in+" -> Cfg.inIncrementalTypecheckingMode := true - | "in-" -> Cfg.inIncrementalTypecheckingMode := false - | "ve+" -> ( - let version = String.sub rest 3 (String.length rest - 3) in - let version = String.trim version in - if Debug.verbose () then - Printf.printf "Setting version: %s\n" version; - match String.split_on_char '.' version with - | [majorRaw; minorRaw] -> - let version = (int_of_string majorRaw, int_of_string minorRaw) in - Packages.overrideRescriptVersion := Some version - | _ -> ()) - | "ve-" -> Packages.overrideRescriptVersion := None - | "def" -> - print_endline - ("Definition " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - definition ~path ~pos:(line, col) ~debug:true - | "com" -> - print_endline - ("Complete " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - let currentFile = createCurrentFile () in - completion ~debug:true ~path ~pos:(line, col) ~currentFile; - Sys.remove currentFile - | "cre" -> - let modulePath = String.sub rest 3 (String.length rest - 3) in - let modulePath = String.trim modulePath in - print_endline ("Completion resolve: " ^ modulePath); - completionResolve ~path ~modulePath - | "dce" -> - print_endline ("DCE " ^ path); - Reanalyze.RunConfig.runConfig.suppress <- ["src"]; - Reanalyze.RunConfig.runConfig.unsuppress <- - [Filename.concat "src" "dce"]; - DceCommand.command () - | "doc" -> - print_endline ("DocumentSymbol " ^ path); - DocumentSymbol.command ~path - | "hig" -> - print_endline ("Highlight " ^ path); - SemanticTokens.command ~debug:true - ~emitter:(SemanticTokens.Token.createEmitter ()) - ~path - | "hov" -> - print_endline - ("Hover " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - let currentFile = createCurrentFile () in - hover ~supportsMarkdownLinks:true ~path ~pos:(line, col) - ~currentFile ~debug:true; - Sys.remove currentFile - | "she" -> - print_endline - ("Signature help " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - let currentFile = createCurrentFile () in - signatureHelp ~path ~pos:(line, col) ~currentFile ~debug:true - ~allowForConstructorPayloads:true; - Sys.remove currentFile - | "int" -> - print_endline ("Create Interface " ^ path); - let cmiFile = - let open Filename in - let ( ++ ) = concat in - let name = chop_extension (basename path) ^ ".cmi" in - let dir = dirname path in - dir ++ parent_dir_name ++ "lib" ++ "bs" ++ "src" ++ name - in - Printf.printf "%s" (CreateInterface.command ~path ~cmiFile) - | "ref" -> - print_endline - ("References " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - references ~path ~pos:(line, col) ~debug:true - | "pre" -> - print_endline - ("PrepareRename " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - prepareRename ~path ~pos:(line, col) ~debug:true - | "ren" -> - let newName = String.sub rest 4 (len - mlen - 4) in - let () = - print_endline - ("Rename " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col ^ " " ^ newName) - in - rename ~path ~pos:(line, col) ~newName ~debug:true - | "typ" -> - print_endline - ("TypeDefinition " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - typeDefinition ~path ~pos:(line, col) ~debug:true - | "xfm" -> - let currentFile = createCurrentFile () in - (* +2 is to ensure that the character ^ points to is what's considered the end of the selection. *) - let endCol = col + try String.index rest '^' + 2 with _ -> 0 in - let endPos = (line, endCol) in - let startPos = (line, col) in - if startPos = endPos then - print_endline - ("Xform " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col) - else - print_endline - ("Xform " ^ path ^ " start: " ^ Pos.toString startPos - ^ ", end: " ^ Pos.toString endPos); - let codeActions = - Xform.extractCodeActions ~path ~startPos ~endPos ~currentFile - ~debug:true - in - Sys.remove currentFile; - codeActions - |> List.iter (fun {Protocol.title; edit = {documentChanges}} -> - Printf.printf "Hit: %s\n" title; - documentChanges - |> List.iter (fun dc -> - match dc with - | Protocol.TextDocumentEdit tde -> - Printf.printf "\nTextDocumentEdit: %s\n" - tde.textDocument.uri; + match List.length diagnostics > 0 with + | true -> Error "Document has syntax errors" + | false -> + Ok (Res_printer.print_implementation ~comments structure |> create_range) + ) + | Resi -> ( + let {Res_driver.parsetree = signature; comments; diagnostics} = + Res_driver.parsing_engine.parse_interface_from_source ~for_printer:true + ~source + in + match List.length diagnostics > 0 with + | true -> Error "Document has syntax errors" + | false -> + Ok (Res_printer.print_interface ~comments signature |> create_range)) + | Other -> Error "Failed to format, file not supported" + in - tde.edits - |> List.iter (fun {Protocol.range; newText} -> - let indent = - String.make range.start.character ' ' - in - Printf.printf - "%s\nnewText:\n%s<--here\n%s%s\n" - (Protocol.stringifyRange range) - indent indent newText) - | CreateFile cf -> - Printf.printf "\nCreateFile: %s\n" cf.uri)) - | "c-a" -> - let hint = String.sub rest 3 (String.length rest - 3) in - print_endline - ("Codemod AddMissingCases" ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - Codemod.transform ~path ~pos:(line, col) ~debug:true - ~typ:AddMissingCases ~hint - |> print_endline - | "dia" -> diagnosticSyntax ~path - | "hin" -> - (* Get all inlay Hint between line 1 and n. - Don't get the first line = 0. - *) - let line_start = 1 in - let line_end = 34 in - print_endline - ("Inlay Hint " ^ path ^ " " ^ string_of_int line_start ^ ":" - ^ string_of_int line_end); - inlayhint ~path ~pos:(line_start, line_end) ~maxLength:"25" - ~debug:false - | "cle" -> - print_endline ("Code Lens " ^ path); - codeLens ~path ~debug:false - | "ast" -> - print_endline - ("Dump AST " ^ path ^ " " ^ string_of_int line ^ ":" - ^ string_of_int col); - let currentFile = createCurrentFile () in - DumpAst.dump ~pos:(line, col) ~currentFile; - Sys.remove currentFile - | "sem" -> SemanticTokens.semanticTokens ~currentFile:path - | _ -> ()); - print_newline ()) - in - lines |> List.iteri processLine + match result with + | Ok textEdit -> Ok [textEdit] + | Error e -> Error e diff --git a/analysis/src/CompletionFrontEnd.ml b/analysis/src/CompletionFrontEnd.ml index a5c0f9ce377..cdb879290dc 100644 --- a/analysis/src/CompletionFrontEnd.ml +++ b/analysis/src/CompletionFrontEnd.ml @@ -352,8 +352,8 @@ let completePipeChain ~(inJsxContext : bool) (exp : Parsetree.expression) = |> Option.map (fun ctxPath -> (ctxPath, pexp_loc)) | _ -> None -let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor - ?findThisExprLoc text = +let completionWithParser1 ~debug ~offset ~posCursor ~kindFile ?findThisExprLoc + text = let offsetNoWhite = Utils.skipWhite text (offset - 1) in let posNoWhite = let line, col = posCursor in @@ -1783,11 +1783,12 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor } in - if Filename.check_suffix path ".res" then ( + if kindFile = Files.Res then ( let parser = - Res_driver.parsing_engine.parse_implementation ~for_printer:false + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:false in - let {Res_driver.parsetree = str} = parser ~filename:currentFile in + let {Res_driver.parsetree = str} = parser ~source:text in iterator.structure iterator str |> ignore; if blankAfterCursor = Some ' ' || blankAfterCursor = Some '\n' then ( scope := !lastScopeBeforeCursor; @@ -1796,9 +1797,11 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor (CPId {loc = Location.none; path = [""]; completionContext = Value}))); if !found = false then if debug then Printf.printf "XXX Not found!\n"; !result) - else if Filename.check_suffix path ".resi" then ( - let parser = Res_driver.parsing_engine.parse_interface ~for_printer:false in - let {Res_driver.parsetree = signature} = parser ~filename:currentFile in + else if kindFile = Resi then ( + let parser = + Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false + in + let {Res_driver.parsetree = signature} = parser ~source:text in iterator.signature iterator signature |> ignore; if blankAfterCursor = Some ' ' || blankAfterCursor = Some '\n' then ( scope := !lastScopeBeforeCursor; @@ -1809,19 +1812,18 @@ let completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor !result) else None -let completionWithParser ~debug ~path ~posCursor ~currentFile ~text = - match Pos.positionToOffset text posCursor with +let completionWithParser ~debug ~source ~kindFile ~posCursor = + match Pos.positionToOffset source posCursor with | Some offset -> - completionWithParser1 ~currentFile ~debug ~offset ~path ~posCursor text + completionWithParser1 ~debug ~offset ~posCursor ~kindFile source | None -> None -let findTypeOfExpressionAtLoc ~debug ~path ~posCursor ~currentFile loc = - let textOpt = Files.readFile currentFile in - match textOpt with - | None | Some "" -> None - | Some text -> ( - match Pos.positionToOffset text posCursor with +let findTypeOfExpressionAtLoc ~debug ~posCursor ~source ~kindFile loc = + match source with + | "" -> None + | source -> ( + match Pos.positionToOffset source posCursor with | Some offset -> - completionWithParser1 ~findThisExprLoc:loc ~currentFile ~debug ~offset - ~path ~posCursor text + completionWithParser1 ~findThisExprLoc:loc ~debug ~offset ~posCursor + ~kindFile source | None -> None) diff --git a/analysis/src/Completions.ml b/analysis/src/Completions.ml index c11d51673ee..ae35a5a0d34 100644 --- a/analysis/src/Completions.ml +++ b/analysis/src/Completions.ml @@ -1,11 +1,11 @@ -let getCompletions ~debug ~path ~pos ~currentFile ~forHover = - let textOpt = Files.readFile currentFile in - match textOpt with - | None | Some "" -> None - | Some text -> ( +let getCompletions ~debug ~source ~kindFile ~pos ~forHover + ~(full : SharedTypes.full option) = + match source with + | "" -> None + | source -> ( match - CompletionFrontEnd.completionWithParser ~debug ~path ~posCursor:pos - ~currentFile ~text + CompletionFrontEnd.completionWithParser ~debug ~source ~kindFile + ~posCursor:pos with | None -> None | Some (completable, scope) -> ( @@ -18,7 +18,7 @@ let getCompletions ~debug ~path ~pos ~currentFile ~forHover = scope; print_newline ()); (* Only perform expensive ast operations if there are completables *) - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> None | Some full -> let env = SharedTypes.QueryEnv.fromFile full.file in diff --git a/analysis/src/Diagnostics.ml b/analysis/src/Diagnostics.ml index 0b30d0e3321..970936c022b 100644 --- a/analysis/src/Diagnostics.ml +++ b/analysis/src/Diagnostics.ml @@ -1,4 +1,4 @@ -let document_syntax ~path = +let document_syntax ~source ~kindFile = let get_diagnostics diagnostics = diagnostics |> List.map (fun diagnostic -> @@ -8,7 +8,7 @@ let document_syntax ~path = let _, endline, endcol = Location.get_pos_info (Res_diagnostics.get_end_pos diagnostic) in - Protocol.stringifyDiagnostic + Protocol. { range = { @@ -19,16 +19,16 @@ let document_syntax ~path = severity = 1; }) in - if FindFiles.isImplementation path then + if kindFile = Files.Res then let parseImplementation = - Res_driver.parsing_engine.parse_implementation ~for_printer:false - ~filename:path + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:false ~source in get_diagnostics parseImplementation.diagnostics - else if FindFiles.isInterface path then + else if kindFile = Files.Resi then let parseInterface = - Res_driver.parsing_engine.parse_interface ~for_printer:false - ~filename:path + Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false + ~source in get_diagnostics parseInterface.diagnostics else [] diff --git a/analysis/src/Hint.ml b/analysis/src/Hint.ml index 71b1b7cfe3a..81881be3bc0 100644 --- a/analysis/src/Hint.ml +++ b/analysis/src/Hint.ml @@ -31,7 +31,7 @@ let locItemToTypeHint ~full:{file; package} locItem = | `Field -> fromType t)) | _ -> None -let inlay ~path ~pos ~maxLength ~debug = +let inlay ~source ~kindFile ~pos ~maxLength ~full ~debug = let maxlen = try Some (int_of_string maxLength) with Failure _ -> None in let hints = ref [] in let start_line, end_line = pos in @@ -71,13 +71,14 @@ let inlay ~path ~pos ~maxLength ~debug = Ast_iterator.default_iterator.value_binding iterator vb in let iterator = {Ast_iterator.default_iterator with value_binding} in - (if Files.classifySourceFile path = Res then + (if kindFile = Files.Res then let parser = - Res_driver.parsing_engine.parse_implementation ~for_printer:false + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:false in - let {Res_driver.parsetree = structure} = parser ~filename:path in + let {Res_driver.parsetree = structure} = parser ~source in iterator.structure iterator structure |> ignore); - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> None | Some full -> let result = @@ -96,7 +97,7 @@ let inlay ~path ~pos ~maxLength ~debug = match locItemToTypeHint locItem ~full with | Some label -> ( let result = - Protocol.stringifyHint + Protocol. { kind = inlayKindToNumber hintKind; position; @@ -113,7 +114,7 @@ let inlay ~path ~pos ~maxLength ~debug = in Some result -let codeLens ~path ~debug = +let codeLens ~source ~kindFile ~full ~debug = let lenses = ref [] in let push loc = let range = Utils.cmtLocToRange loc in @@ -135,13 +136,14 @@ let codeLens ~path ~debug = let iterator = {Ast_iterator.default_iterator with value_binding} in (* We only print code lenses in implementation files. This is because they'd be redundant in interface files, where the definition itself will be the same thing as what would've been printed in the code lens. *) - (if Files.classifySourceFile path = Res then + (if kindFile = Files.Res then let parser = - Res_driver.parsing_engine.parse_implementation ~for_printer:false + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:false in - let {Res_driver.parsetree = structure} = parser ~filename:path in + let {Res_driver.parsetree = structure} = parser ~source in iterator.structure iterator structure |> ignore); - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> None | Some full -> let result = @@ -154,21 +156,21 @@ let codeLens ~path ~debug = with | Some {locType = Typed (_, typeExpr, _)} -> Some - (Protocol.stringifyCodeLens - { - range; - command = - Some - { - (* Code lenses can run commands. An empty command string means we just want the editor + Protocol. + { + range; + command = + Some + { + (* Code lenses can run commands. An empty command string means we just want the editor to print the text, not link to running a command. *) - command = ""; - (* Print the type with a huge line width, because the code lens always prints on a + command = ""; + (* Print the type with a huge line width, because the code lens always prints on a single line in the editor. *) - title = - typeExpr |> Shared.typeToString ~lineWidth:400; - }; - }) + title = + typeExpr |> Shared.typeToString ~lineWidth:400; + }; + } | _ -> None) in Some result diff --git a/analysis/src/Hover.ml b/analysis/src/Hover.ml index 716f5e3c002..4f1a98da27f 100644 --- a/analysis/src/Hover.ml +++ b/analysis/src/Hover.ml @@ -180,9 +180,11 @@ let hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks ?docstring (* Leverages autocomplete functionality to produce a hover for a position. This makes it (most often) work with unsaved content. *) -let getHoverViaCompletions ~debug ~path ~pos ~currentFile ~forHover - ~supportsMarkdownLinks = - match Completions.getCompletions ~debug ~path ~pos ~currentFile ~forHover with +let getHoverViaCompletions ~debug ~source ~kindFile ~pos ~forHover + ~supportsMarkdownLinks ~full = + match + Completions.getCompletions ~debug ~source ~kindFile ~pos ~forHover ~full + with | None -> None | Some (completions, ({file; package} as full), scope) -> ( let rawOpens = Scope.getRawOpens scope in @@ -193,7 +195,7 @@ let getHoverViaCompletions ~debug ~path ~pos ~currentFile ~forHover @ if typString = "" then [] else [Markdown.codeBlock typString] in - Some (Protocol.stringifyHover (String.concat "\n\n" parts)) + Some (String.concat "\n\n" parts) | {kind = Field _; env; docstring} :: _ -> ( let opens = CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env in match @@ -205,7 +207,7 @@ let getHoverViaCompletions ~debug ~path ~pos ~currentFile ~forHover hoverWithExpandedTypes ~file ~package ~docstring ~supportsMarkdownLinks typ in - Some (Protocol.stringifyHover typeString) + Some typeString | None -> None) | {env} :: _ -> ( let opens = CompletionBackEnd.getOpens ~debug ~rawOpens ~package ~env in @@ -217,7 +219,7 @@ let getHoverViaCompletions ~debug ~path ~pos ~currentFile ~forHover let typeString = hoverWithExpandedTypes ~file ~package ~supportsMarkdownLinks typ in - Some (Protocol.stringifyHover typeString) + Some typeString | None -> None) | _ -> None) diff --git a/analysis/src/Protocol.ml b/analysis/src/Protocol.ml index e3e4208628e..447584b7e9b 100644 --- a/analysis/src/Protocol.ml +++ b/analysis/src/Protocol.ml @@ -63,6 +63,10 @@ type documentSymbolItem = { range: range; children: documentSymbolItem list; } +type prepareRenameWithPlaceholder = {range: range; placeholder: string} +type prepareRename = + | Range of range + | Placeholder of prepareRenameWithPlaceholder type renameFile = {oldUri: string; newUri: string} type diagnostic = {range: range; message: string; severity: int} @@ -92,6 +96,8 @@ type codeAction = { edit: codeActionEdit; } +type semanticTokens = {data: int array} + let wrapInQuotes s = "\"" ^ Json.escape s ^ "\"" let null = "null" @@ -105,6 +111,15 @@ let stringifyRange r = (stringifyPosition r.start) (stringifyPosition r.end_) +let stringifyRangeWithPlaceholder (r : prepareRenameWithPlaceholder) = + Printf.sprintf + {|{ + "range": %s, + "placeholder": %s + }|} + (stringifyRange r.range) + (wrapInQuotes r.placeholder) + let stringifyTextEdit (te : textEdit) = Printf.sprintf {|{ diff --git a/analysis/src/SemanticTokens.ml b/analysis/src/SemanticTokens.ml index ddccba9b2b1..86feab8ef8d 100644 --- a/analysis/src/SemanticTokens.ml +++ b/analysis/src/SemanticTokens.ml @@ -29,15 +29,15 @@ module Token = struct | Property (** {x:...} *) | JsxLowercase (** div in
*) - let tokenTypeToString = function - | Operator -> "0" - | Variable -> "1" - | Type -> "2" - | JsxTag -> "3" - | Namespace -> "4" - | EnumMember -> "5" - | Property -> "6" - | JsxLowercase -> "7" + let tokenTypeToInt = function + | Operator -> 0 + | Variable -> 1 + | Type -> 2 + | JsxTag -> 3 + | Namespace -> 4 + | EnumMember -> 5 + | Property -> 6 + | JsxLowercase -> 7 let tokenTypeDebug = function | Operator -> "Operator" @@ -49,7 +49,7 @@ module Token = struct | Property -> "Property" | JsxLowercase -> "JsxLowercase" - let tokenModifiersString = "0" (* None at the moment *) + let tokenModifiers = 0 (* None at the moment *) type token = int * int * int * tokenType @@ -64,25 +64,15 @@ module Token = struct let add ~line ~char ~length ~type_ e = e.tokens <- (line, char, length, type_) :: e.tokens - let emitToken buf (line, char, length, type_) e = + let emitToken (line, char, length, type_) e = let deltaLine = line - e.lastLine in let deltaChar = if deltaLine = 0 then char - e.lastChar else char in e.lastLine <- line; e.lastChar <- char; - if Buffer.length buf > 0 then Buffer.add_char buf ','; - if - deltaLine >= 0 && deltaChar >= 0 && length >= 0 - (* Defensive programming *) - then - Buffer.add_string buf - (string_of_int deltaLine ^ "," ^ string_of_int deltaChar ^ "," - ^ string_of_int length ^ "," ^ tokenTypeToString type_ ^ "," - ^ tokenModifiersString) - - let remove_trailing_comma buffer = - let len = Buffer.length buffer in - if len > 0 && Buffer.nth buffer (len - 1) = ',' then - Buffer.truncate buffer (len - 1) + if deltaLine >= 0 && deltaChar >= 0 && length >= 0 then + Some + [|deltaLine; deltaChar; length; tokenTypeToInt type_; tokenModifiers|] + else None let emit e = let sortedTokens = @@ -90,13 +80,12 @@ module Token = struct |> List.sort (fun (l1, c1, _, _) (l2, c2, _, _) -> if l1 = l2 then compare c1 c2 else compare l1 l2) in - let buf = Buffer.create 1 in - sortedTokens |> List.iter (fun t -> e |> emitToken buf t); + let arrays = sortedTokens |> List.filter_map (fun t -> e |> emitToken t) in + Array.concat arrays - (* Valid JSON arrays cannot have trailing commas *) - remove_trailing_comma buf; - - Buffer.contents buf + let arrayToJsonString arr = + let items = Array.map string_of_int arr |> Array.to_list in + "[" ^ String.concat "," items ^ "]" end let isLowercaseId id = @@ -203,7 +192,7 @@ let emitVariant ~(name : Longident.t Location.loc) ~debug emitter = |> emitLongident ~lastToken:(Some Token.EnumMember) ~pos:(Loc.start name.loc) ~lid:name.txt ~debug -let command ~debug ~emitter ~path = +let command ~debug ~emitter ~source ~kindFile = let processTypeArg (coreType : Parsetree.core_type) = if debug then Printf.printf "TypeArg: %s\n" (Loc.toString coreType.ptyp_loc) in @@ -480,28 +469,27 @@ let command ~debug ~emitter ~path = } in - if Files.classifySourceFile path = Res then ( + if kindFile = Files.Res then ( let parser = - Res_driver.parsing_engine.parse_implementation ~for_printer:false - in - let {Res_driver.parsetree = structure; diagnostics} = - parser ~filename:path + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:false in + let {Res_driver.parsetree = structure; diagnostics} = parser ~source in if debug then Printf.printf "structure items:%d diagnostics:%d \n" (List.length structure) (List.length diagnostics); iterator.structure iterator structure |> ignore) else - let parser = Res_driver.parsing_engine.parse_interface ~for_printer:false in - let {Res_driver.parsetree = signature; diagnostics} = - parser ~filename:path + let parser = + Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false in + let {Res_driver.parsetree = signature; diagnostics} = parser ~source in if debug then Printf.printf "signature items:%d diagnostics:%d \n" (List.length signature) (List.length diagnostics); iterator.signature iterator signature |> ignore -let semanticTokens ~currentFile = +let semanticTokens ~source ~kindFile = let emitter = Token.createEmitter () in - command ~emitter ~debug:false ~path:currentFile; - Printf.printf "{\"data\":[%s]}" (Token.emit emitter) + command ~emitter ~debug:false ~source ~kindFile; + Protocol.{data = Token.emit emitter} diff --git a/analysis/src/SignatureHelp.ml b/analysis/src/SignatureHelp.ml index e4c9cb11ae1..68cfc405906 100644 --- a/analysis/src/SignatureHelp.ml +++ b/analysis/src/SignatureHelp.ml @@ -33,9 +33,9 @@ let docsForLabel typeExpr ~file ~package ~supportsMarkdownLinks = in typeDefinitions |> String.concat "\n" -let findFunctionType ~currentFile ~debug ~path ~pos = +let findFunctionType ~debug ~source ~kindFile ~pos ~full = (* Start by looking at the typed info at the loc of the fn *) - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> None | Some full -> ( let {file; package} = full in @@ -72,16 +72,15 @@ let findFunctionType ~currentFile ~debug ~path ~pos = | None -> ( (* If nothing was found there, try using the unsaved completion engine *) let completables = - let textOpt = Files.readFile currentFile in - match textOpt with - | None | Some "" -> None - | Some text -> ( + match source with + | "" -> None + | source -> ( (* Leverage the completion functionality to pull out the type of the identifier doing the function application. This lets us leverage all of the smart work done in completions to find the correct type in many cases even for files not saved yet. *) match - CompletionFrontEnd.completionWithParser ~debug ~path ~posCursor:pos - ~currentFile ~text + CompletionFrontEnd.completionWithParser ~debug ~source ~kindFile + ~posCursor:pos with | None -> None | Some (completable, scope) -> @@ -238,11 +237,11 @@ let findConstructorArgs ~full ~env ~constructorName loc = | _ -> None) | _ -> None -let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = - let textOpt = Files.readFile currentFile in - match textOpt with - | None | Some "" -> None - | Some text -> ( +let signatureHelp ~debug ~source ~kindFile ~pos ~allowForConstructorPayloads + ~full = + match source with + | "" -> None + | text -> ( match Pos.positionToOffset text pos with | None -> None | Some offset -> ( @@ -416,16 +415,17 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = in let iterator = {Ast_iterator.default_iterator with expr; pat} in let parser = - Res_driver.parsing_engine.parse_implementation ~for_printer:false + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:false in - let {Res_driver.parsetree = structure} = parser ~filename:currentFile in + let {Res_driver.parsetree = structure} = parser ~source in iterator.structure iterator structure |> ignore; (* Handle function application, if found *) match !result with | Some (_, `FunctionCall (argAtCursor, exp, _extractedArgs)) -> ( (* Not looking for the cursor position after this, but rather the target function expression's loc. *) let pos = exp.pexp_loc |> Loc.end_ in - match findFunctionType ~currentFile ~debug ~path ~pos with + match findFunctionType ~source ~kindFile ~debug ~pos ~full with | Some (args, docstring, type_expr, package, _env, file) -> if debug then Printf.printf "argAtCursor: %s\n" @@ -525,7 +525,7 @@ let signatureHelp ~path ~pos ~currentFile ~debug ~allowForConstructorPayloads = -> ( if Debug.verbose () then Printf.printf "[signature_help] Found constructor!\n"; - match Cmt.loadFullCmtFromPath ~path with + match full with | None -> if Debug.verbose () then Printf.printf "[signature_help] Could not load cmt\n"; diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml index ddf783c5590..8d66d8c757d 100644 --- a/analysis/src/Xform.ml +++ b/analysis/src/Xform.ml @@ -2,10 +2,10 @@ let isBracedExpr = Res_parsetree_viewer.is_braced_expr -let extractTypeFromExpr expr ~debug ~path ~currentFile ~full ~pos = +let extractTypeFromExpr expr ~debug ~source ~kindFile ~full ~pos = match expr.Parsetree.pexp_loc - |> CompletionFrontEnd.findTypeOfExpressionAtLoc ~debug ~path ~currentFile + |> CompletionFrontEnd.findTypeOfExpressionAtLoc ~debug ~source ~kindFile ~posCursor:(Pos.ofLexing expr.Parsetree.pexp_loc.loc_start) with | Some (completable, scope) -> ( @@ -377,7 +377,7 @@ module ExpandCatchAllForVariants = struct in {Ast_iterator.default_iterator with expr} - let xform ~path ~pos ~full ~structure ~currentFile ~codeActions ~debug = + let xform ~source ~kindFile ~path ~pos ~full ~structure ~codeActions ~debug = let result = ref None in let iterator = mkIterator ~pos ~result in iterator.structure iterator structure; @@ -411,7 +411,7 @@ module ExpandCatchAllForVariants = struct let currentConstructorNames = getCurrentConstructorNames cases in match switchExpr - |> extractTypeFromExpr ~debug ~path ~currentFile ~full + |> extractTypeFromExpr ~debug ~source ~kindFile ~full ~pos:(Pos.ofLexing switchExpr.pexp_loc.loc_end) with | Some (Tvariant {constructors}) -> @@ -580,8 +580,8 @@ module ExhaustiveSwitch = struct in {Ast_iterator.default_iterator with expr} - let xform ~printExpr ~path ~currentFile ~pos ~full ~structure ~codeActions - ~debug = + let xform ~printExpr ~path ~source ~kindFile ~pos ~full ~structure + ~codeActions ~debug = (* TODO: Adapt to '(' as leading/trailing character (skip one col, it's not included in the AST) *) let result = ref None in let foundSelection = ref (None, None) in @@ -605,7 +605,7 @@ module ExhaustiveSwitch = struct | Some (Selection {expr}) -> ( match expr - |> extractTypeFromExpr ~debug ~path ~currentFile ~full + |> extractTypeFromExpr ~debug ~source ~kindFile ~full ~pos:(Pos.ofLexing expr.pexp_loc.loc_start) with | None -> () @@ -631,7 +631,7 @@ module ExhaustiveSwitch = struct | Some (Switch {switchExpr; completionExpr; pos}) -> ( match completionExpr - |> extractTypeFromExpr ~debug ~path ~currentFile ~full ~pos + |> extractTypeFromExpr ~debug ~source ~kindFile ~full ~pos with | None -> () | Some extractedType -> ( @@ -840,9 +840,10 @@ module AddDocTemplate = struct end end -let parseImplementation ~filename = +let parseImplementation ~source = let {Res_driver.parsetree = structure; comments} = - Res_driver.parsing_engine.parse_implementation ~for_printer:false ~filename + Res_driver.parsing_engine.parse_implementation_from_source + ~for_printer:false ~source in let filterComments ~loc comments = (* Relevant comments in the range of the expression *) @@ -873,9 +874,10 @@ let parseImplementation ~filename = in (structure, printExpr, printStructureItem, printStandaloneStructure) -let parseInterface ~filename = +let parseInterface ~source = let {Res_driver.parsetree = structure; comments} = - Res_driver.parsing_engine.parse_interface ~for_printer:false ~filename + Res_driver.parsing_engine.parse_interface_from_source ~for_printer:false + ~source in let filterComments ~loc comments = (* Relevant comments in the range of the expression *) @@ -894,13 +896,13 @@ let parseInterface ~filename = in (structure, printSignatureItem) -let extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug = +let extractCodeActions ~path ~startPos ~endPos ~source ~kindFile ~debug = let pos = startPos in let codeActions = ref [] in - match Files.classifySourceFile currentFile with - | Res -> + match kindFile with + | Files.Res -> let structure, printExpr, printStructureItem, printStandaloneStructure = - parseImplementation ~filename:currentFile + parseImplementation ~source in IfThenElse.xform ~pos ~codeActions ~printExpr ~path structure; ModuleToFile.xform ~pos ~codeActions ~path ~printStandaloneStructure @@ -914,19 +916,19 @@ let extractCodeActions ~path ~startPos ~endPos ~currentFile ~debug = match Cmt.loadFullCmtFromPath ~path with | Some full -> AddTypeAnnotation.xform ~path ~pos ~full ~structure ~codeActions ~debug; - ExpandCatchAllForVariants.xform ~path ~pos ~full ~structure ~codeActions - ~currentFile ~debug; - ExhaustiveSwitch.xform ~printExpr ~path + ExpandCatchAllForVariants.xform ~path ~source ~kindFile ~pos ~full + ~structure ~codeActions ~debug; + ExhaustiveSwitch.xform ~printExpr ~path ~source ~kindFile ~pos: (if startPos = endPos then Single startPos else Range (startPos, endPos)) - ~full ~structure ~codeActions ~debug ~currentFile + ~full ~structure ~codeActions ~debug | None -> () in !codeActions | Resi -> - let signature, printSignatureItem = parseInterface ~filename:currentFile in + let signature, printSignatureItem = parseInterface ~source in AddDocTemplate.Interface.xform ~pos ~codeActions ~path ~signature ~printSignatureItem; !codeActions diff --git a/compiler/syntax/src/res_ast_debugger.ml b/compiler/syntax/src/res_ast_debugger.ml index 5b3e5ecf01e..8f8ebdb0bb7 100644 --- a/compiler/syntax/src/res_ast_debugger.ml +++ b/compiler/syntax/src/res_ast_debugger.ml @@ -7,9 +7,15 @@ let print_engine = print_implementation = (fun ~width:_ ~filename:_ ~comments:_ structure -> Printast.implementation Format.std_formatter structure); + print_implementation_from_source = + (fun ~width:_ ~source:_ ~comments:_ structure -> + Printast.implementation Format.std_formatter structure); print_interface = (fun ~width:_ ~filename:_ ~comments:_ signature -> Printast.interface Format.std_formatter signature); + print_interface_from_source = + (fun ~width:_ ~source:_ ~comments:_ signature -> + Printast.interface Format.std_formatter signature); } module Sexp : sig @@ -962,9 +968,15 @@ module SexpAst = struct print_implementation = (fun ~width:_ ~filename:_ ~comments:_ parsetree -> parsetree |> structure |> Sexp.to_string |> print_string); + print_implementation_from_source = + (fun ~width:_ ~source:_ ~comments:_ parsetree -> + parsetree |> structure |> Sexp.to_string |> print_string); print_interface = (fun ~width:_ ~filename:_ ~comments:_ parsetree -> parsetree |> signature |> Sexp.to_string |> print_string); + print_interface_from_source = + (fun ~width:_ ~source:_ ~comments:_ parsetree -> + parsetree |> signature |> Sexp.to_string |> print_string); } end @@ -977,9 +989,19 @@ let comments_print_engine = let cmt_tbl = CommentTable.make () in CommentTable.walk_structure s cmt_tbl comments; CommentTable.log cmt_tbl); - print_interface = + Res_driver.print_implementation_from_source = + (fun ~width:_ ~source:_ ~comments s -> + let cmt_tbl = CommentTable.make () in + CommentTable.walk_structure s cmt_tbl comments; + CommentTable.log cmt_tbl); + Res_driver.print_interface = (fun ~width:_ ~filename:_ ~comments s -> let cmt_tbl = CommentTable.make () in CommentTable.walk_signature s cmt_tbl comments; CommentTable.log cmt_tbl); + Res_driver.print_interface_from_source = + (fun ~width:_ ~source:_ ~comments s -> + let cmt_tbl = CommentTable.make () in + CommentTable.walk_signature s cmt_tbl comments; + CommentTable.log cmt_tbl); } diff --git a/compiler/syntax/src/res_driver.ml b/compiler/syntax/src/res_driver.ml index 64039e76560..eddb55a1f27 100644 --- a/compiler/syntax/src/res_driver.ml +++ b/compiler/syntax/src/res_driver.ml @@ -14,10 +14,18 @@ type 'diagnostics parsing_engine = { for_printer:bool -> filename:string -> (Parsetree.structure, 'diagnostics) parse_result; + parse_implementation_from_source: + for_printer:bool -> + source:string -> + (Parsetree.structure, 'diagnostics) parse_result; parse_interface: for_printer:bool -> filename:string -> (Parsetree.signature, 'diagnostics) parse_result; + parse_interface_from_source: + for_printer:bool -> + source:string -> + (Parsetree.signature, 'diagnostics) parse_result; string_of_diagnostics: source:string -> filename:string -> 'diagnostics -> unit; } @@ -29,12 +37,24 @@ type print_engine = { comments:Res_comment.t list -> Parsetree.structure -> unit; + print_implementation_from_source: + width:int -> + source:string -> + comments:Res_comment.t list -> + Parsetree.structure -> + unit; print_interface: width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.signature -> unit; + print_interface_from_source: + width:int -> + source:string -> + comments:Res_comment.t list -> + Parsetree.signature -> + unit; } let setup ~filename ~for_printer () = @@ -65,6 +85,25 @@ let parsing_engine = invalid; comments = List.rev engine.comments; }); + parse_implementation_from_source = + (fun ~for_printer ~source -> + let engine = + setup_from_source ~source ~for_printer ~display_filename:"source" () + in + let structure = Res_core.parse_implementation engine in + let invalid, diagnostics = + match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in + { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = structure; + diagnostics; + invalid; + comments = List.rev engine.comments; + }); parse_interface = (fun ~for_printer ~filename -> let engine = setup ~filename ~for_printer () in @@ -82,6 +121,25 @@ let parsing_engine = invalid; comments = List.rev engine.comments; }); + parse_interface_from_source = + (fun ~for_printer ~source -> + let engine = + setup_from_source ~source ~display_filename:"" ~for_printer () + in + let signature = Res_core.parse_specification engine in + let invalid, diagnostics = + match engine.diagnostics with + | [] as diagnostics -> (false, diagnostics) + | _ as diagnostics -> (true, diagnostics) + in + { + filename = engine.scanner.filename; + source = engine.scanner.src; + parsetree = signature; + diagnostics; + invalid; + comments = List.rev engine.comments; + }); string_of_diagnostics = (fun ~source ~filename:_ diagnostics -> Res_diagnostics.print_report diagnostics source); @@ -127,9 +185,16 @@ let print_engine = (fun ~width ~filename:_ ~comments structure -> print_string (Res_printer.print_implementation ~width structure ~comments)); + print_implementation_from_source = + (fun ~width ~source:_ ~comments structure -> + print_string + (Res_printer.print_implementation ~width structure ~comments)); print_interface = (fun ~width ~filename:_ ~comments signature -> print_string (Res_printer.print_interface ~width signature ~comments)); + print_interface_from_source = + (fun ~width ~source:_ ~comments signature -> + print_string (Res_printer.print_interface ~width signature ~comments)); } let parse_implementation ?(ignore_parse_errors = false) sourcefile = diff --git a/compiler/syntax/src/res_driver.mli b/compiler/syntax/src/res_driver.mli index 2b717013ccb..4d6feb13de6 100644 --- a/compiler/syntax/src/res_driver.mli +++ b/compiler/syntax/src/res_driver.mli @@ -12,10 +12,18 @@ type 'diagnostics parsing_engine = { for_printer:bool -> filename:string -> (Parsetree.structure, 'diagnostics) parse_result; + parse_implementation_from_source: + for_printer:bool -> + source:string -> + (Parsetree.structure, 'diagnostics) parse_result; parse_interface: for_printer:bool -> filename:string -> (Parsetree.signature, 'diagnostics) parse_result; + parse_interface_from_source: + for_printer:bool -> + source:string -> + (Parsetree.signature, 'diagnostics) parse_result; string_of_diagnostics: source:string -> filename:string -> 'diagnostics -> unit; } @@ -41,12 +49,24 @@ type print_engine = { comments:Res_comment.t list -> Parsetree.structure -> unit; + print_implementation_from_source: + width:int -> + source:string -> + comments:Res_comment.t list -> + Parsetree.structure -> + unit; print_interface: width:int -> filename:string -> comments:Res_comment.t list -> Parsetree.signature -> unit; + print_interface_from_source: + width:int -> + source:string -> + comments:Res_comment.t list -> + Parsetree.signature -> + unit; } val parsing_engine : Res_diagnostics.t list parsing_engine diff --git a/compiler/syntax/src/res_driver_binary.ml b/compiler/syntax/src/res_driver_binary.ml index 71eb12bd483..b6c9318d5cc 100644 --- a/compiler/syntax/src/res_driver_binary.ml +++ b/compiler/syntax/src/res_driver_binary.ml @@ -6,9 +6,19 @@ let print_engine = output_string stdout Config.ast_impl_magic_number; output_value stdout filename; output_value stdout structure); + print_implementation_from_source = + (fun ~width:_ ~source:_ ~comments:_ structure -> + output_string stdout Config.ast_impl_magic_number; + output_value stdout "source"; + output_value stdout structure); print_interface = (fun ~width:_ ~filename ~comments:_ signature -> output_string stdout Config.ast_intf_magic_number; output_value stdout filename; output_value stdout signature); + print_interface_from_source = + (fun ~width:_ ~source:_ ~comments:_ signature -> + output_string stdout Config.ast_intf_magic_number; + output_value stdout "source"; + output_value stdout signature); } diff --git a/compiler/syntax/src/res_driver_ml_printer.ml b/compiler/syntax/src/res_driver_ml_printer.ml index 651ab058402..232e328bf15 100644 --- a/compiler/syntax/src/res_driver_ml_printer.ml +++ b/compiler/syntax/src/res_driver_ml_printer.ml @@ -4,7 +4,13 @@ let print_engine = print_implementation = (fun ~width:_ ~filename:_ ~comments:_ structure -> Pprintast.structure Format.std_formatter structure); + print_implementation_from_source = + (fun ~width:_ ~source:_ ~comments:_ structure -> + Pprintast.structure Format.std_formatter structure); print_interface = (fun ~width:_ ~filename:_ ~comments:_ signature -> Pprintast.signature Format.std_formatter signature); + print_interface_from_source = + (fun ~width:_ ~source:_ ~comments:_ signature -> + Pprintast.signature Format.std_formatter signature); } diff --git a/compiler/syntax/src/res_token_debugger.ml b/compiler/syntax/src/res_token_debugger.ml index e745308dd4f..ff164ff4ae2 100644 --- a/compiler/syntax/src/res_token_debugger.ml +++ b/compiler/syntax/src/res_token_debugger.ml @@ -1,16 +1,26 @@ -let dump_tokens filename = +type input = Filename of string | Source of string + +let dump_tokens input = let src = - try - let ic = open_in filename in - let content = really_input_string ic (in_channel_length ic) in - close_in ic; - content - with e -> - Printf.printf "Error reading file %s: %s\n" filename - (Printexc.to_string e); - exit 1 + match input with + | Filename filename -> ( + try + let ic = open_in filename in + let content = really_input_string ic (in_channel_length ic) in + close_in ic; + content + with e -> + Printf.printf "Error reading file %s: %s\n" filename + (Printexc.to_string e); + exit 1) + | Source code -> code in + let filename = + match input with + | Filename filename -> filename + | Source _ -> "" + in let scanner = Res_scanner.make ~filename src in let rec visit scanner = @@ -141,7 +151,11 @@ let dump_tokens filename = let token_print_engine = { Res_driver.print_implementation = - (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens filename); - print_interface = - (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens filename); + (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens (Filename filename)); + Res_driver.print_implementation_from_source = + (fun ~width:_ ~source ~comments:_ _ -> dump_tokens (Source source)); + Res_driver.print_interface = + (fun ~width:_ ~filename ~comments:_ _ -> dump_tokens (Filename filename)); + Res_driver.print_interface_from_source = + (fun ~width:_ ~source ~comments:_ _ -> dump_tokens (Source source)); }