diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index d7871446e..2ad4731f2 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -46,21 +46,12 @@ let hover ~path ~pos ~currentFile ~debug ~supportsMarkdownLinks = if debug then Printf.printf "Nothing at that position. Now trying to use completion.\n"; - let completions = - getCompletions ~debug ~path ~pos ~currentFile ~forHover:true - in - match completions with - | {kind = Label typString; docstring} :: _ -> - let parts = - (if typString = "" then [] else [Hover.codeBlock typString]) - @ docstring - in - Protocol.stringifyHover (String.concat "\n\n" parts) - | _ -> ( - match CompletionBackEnd.completionsGetTypeEnv completions with - | Some (typ, _env) -> - Protocol.stringifyHover (Hover.codeBlock (Shared.typeToString typ)) - | None -> Protocol.null)) + match + Hover.getHoverViaCompletions ~debug ~path ~pos ~currentFile + ~forHover:true ~supportsMarkdownLinks + with + | None -> Protocol.null + | Some hover -> hover) | Some locItem -> ( let isModule = match locItem.locType with diff --git a/analysis/src/Hover.ml b/analysis/src/Hover.ml index 2d0271dec..371418b8a 100644 --- a/analysis/src/Hover.ml +++ b/analysis/src/Hover.ml @@ -1,51 +1,5 @@ open SharedTypes -let codeBlock code = Printf.sprintf "```rescript\n%s\n```" code - -(* Light weight, hopefully-enough-for-the-purpose fn to encode URI components. - Built to handle the reserved characters listed in - https://en.wikipedia.org/wiki/Percent-encoding. Note that this function is not - general purpose, rather it's currently only for URL encoding the argument list - passed to command links in markdown. *) -let encodeURIComponent text = - let ln = String.length text in - let buf = Buffer.create ln in - let rec loop i = - if i < ln then ( - (match text.[i] with - | '"' -> Buffer.add_string buf "%22" - | '\'' -> Buffer.add_string buf "%22" - | ':' -> Buffer.add_string buf "%3A" - | ';' -> Buffer.add_string buf "%3B" - | '/' -> Buffer.add_string buf "%2F" - | '\\' -> Buffer.add_string buf "%5C" - | ',' -> Buffer.add_string buf "%2C" - | '&' -> Buffer.add_string buf "%26" - | '[' -> Buffer.add_string buf "%5B" - | ']' -> Buffer.add_string buf "%5D" - | '#' -> Buffer.add_string buf "%23" - | '$' -> Buffer.add_string buf "%24" - | '+' -> Buffer.add_string buf "%2B" - | '=' -> Buffer.add_string buf "%3D" - | '?' -> Buffer.add_string buf "%3F" - | '@' -> Buffer.add_string buf "%40" - | '%' -> Buffer.add_string buf "%25" - | c -> Buffer.add_char buf c); - loop (i + 1)) - in - loop 0; - Buffer.contents buf - -type link = {startPos: Protocol.position; file: string; label: string} - -let linkToCommandArgs link = - Printf.sprintf "[\"%s\",%i,%i]" link.file link.startPos.line - link.startPos.character - -let makeGotoCommand link = - Printf.sprintf "[%s](command:rescript-vscode.go_to_location?%s)" link.label - (encodeURIComponent (linkToCommandArgs link)) - let showModuleTopLevel ~docstring ~name (topLevel : Module.item list) = let contents = topLevel @@ -60,7 +14,9 @@ let showModuleTopLevel ~docstring ~name (topLevel : Module.item list) = (* TODO indent *) |> String.concat "\n" in - let full = codeBlock ("module " ^ name ^ " = {" ^ "\n" ^ contents ^ "\n}") in + let full = + Markdown.codeBlock ("module " ^ name ^ " = {" ^ "\n" ^ contents ^ "\n}") + in let doc = match docstring with | [] -> "" @@ -80,11 +36,128 @@ let rec showModule ~docstring ~(file : File.t) ~name | Some {item = Ident path} -> Some ("Unable to resolve module reference " ^ Path.name path) +type extractedType = { + name: string; + path: Path.t; + decl: Types.type_declaration; + env: SharedTypes.QueryEnv.t; + loc: Warnings.loc; +} + +let findRelevantTypesFromType ~file ~package typ = + (* Expand definitions of types mentioned in typ. + If typ itself is a record or variant, search its body *) + let env = QueryEnv.fromFile file in + let envToSearch, typesToSearch = + match typ |> Shared.digConstructor with + | Some path -> ( + let labelDeclarationsTypes lds = + lds |> List.map (fun (ld : Types.label_declaration) -> ld.ld_type) + in + match References.digConstructor ~env ~package path with + | None -> (env, [typ]) + | Some (env1, {item = {decl}}) -> ( + match decl.type_kind with + | Type_record (lds, _) -> (env1, typ :: (lds |> labelDeclarationsTypes)) + | Type_variant cds -> + ( env1, + cds + |> List.map (fun (cd : Types.constructor_declaration) -> + let fromArgs = + match cd.cd_args with + | Cstr_tuple ts -> ts + | Cstr_record lds -> lds |> labelDeclarationsTypes + in + typ + :: + (match cd.cd_res with + | None -> fromArgs + | Some t -> t :: fromArgs)) + |> List.flatten ) + | _ -> (env, [typ]))) + | None -> (env, [typ]) + in + let fromConstructorPath ~env path = + match References.digConstructor ~env ~package path with + | None -> None + | Some (env, {name = {txt}; extentLoc; item = {decl}}) -> + if Utils.isUncurriedInternal path then None + else Some {name = txt; env; loc = extentLoc; decl; path} + in + let constructors = Shared.findTypeConstructors typesToSearch in + constructors |> List.filter_map (fromConstructorPath ~env:envToSearch) + +(* Produces a hover with relevant types expanded in the main type being hovered. *) +let hoverWithExpandedTypes ~docstring ~file ~package ~supportsMarkdownLinks typ + = + let typeString = Markdown.codeBlock (typ |> Shared.typeToString) in + let types = findRelevantTypesFromType typ ~file ~package in + let typeDefinitions = + types + |> List.map (fun {decl; env; loc; path} -> + let linkToTypeDefinitionStr = + if supportsMarkdownLinks then + Markdown.goToDefinitionText ~env ~pos:loc.Warnings.loc_start + else "" + in + "\n" ^ Markdown.spacing + ^ Markdown.codeBlock + (decl + |> Shared.declToString ~printNameAsIs:true + (SharedTypes.pathIdentToString path)) + ^ linkToTypeDefinitionStr ^ "\n" ^ Markdown.divider) + in + (typeString :: typeDefinitions |> String.concat "\n", 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 = + let textOpt = Files.readFile currentFile in + match textOpt with + | None | Some "" -> None + | Some text -> ( + match + CompletionFrontEnd.completionWithParser ~debug ~path ~posCursor:pos + ~currentFile ~text + with + | None -> None + | Some (completable, scope) -> ( + if debug then + Printf.printf "Completable: %s\n" + (SharedTypes.Completable.toString completable); + (* Only perform expensive ast operations if there are completables *) + match Cmt.fullFromPath ~path with + | None -> None + | Some {file; package} -> ( + let env = SharedTypes.QueryEnv.fromFile file in + let completions = + completable + |> CompletionBackEnd.processCompletable ~debug ~package ~pos ~scope + ~env ~forHover + in + match completions with + | {kind = Label typString; docstring} :: _ -> + let parts = + (if typString = "" then [] else [Markdown.codeBlock typString]) + @ docstring + in + Some (Protocol.stringifyHover (String.concat "\n\n" parts)) + | _ -> ( + match CompletionBackEnd.completionsGetTypeEnv completions with + | Some (typ, _env) -> + let typeString, _docstring = + hoverWithExpandedTypes ~docstring:"" ~file ~package + ~supportsMarkdownLinks typ + in + Some (Protocol.stringifyHover typeString) + | None -> None)))) + let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = match locItem.locType with | TypeDefinition (name, decl, _stamp) -> let typeDef = Shared.declToString name decl in - Some (codeBlock typeDef) + Some (Markdown.codeBlock typeDef) | LModule (Definition (stamp, _tip)) | LModule (LocalReference (stamp, _tip)) -> ( match Stamps.findModule file.stamps stamp with @@ -132,7 +205,7 @@ let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = | Typed (_, _, Definition (_, (Field _ | Constructor _))) -> None | Constant t -> Some - (codeBlock + (Markdown.codeBlock (match t with | Const_int _ -> "int" | Const_char _ -> "char" @@ -142,81 +215,9 @@ let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = | Const_int64 _ -> "int64" | Const_nativeint _ -> "int")) | Typed (_, t, locKind) -> - let fromConstructorPath ~env path = - match References.digConstructor ~env ~package path with - | None -> None - | Some (env, {extentLoc; item = {decl}}) -> - if Utils.isUncurriedInternal path then None - else - Some - ( decl - |> Shared.declToString ~printNameAsIs:true - (SharedTypes.pathIdentToString path), - extentLoc, - env ) - in let fromType ~docstring typ = - let typeString = codeBlock (typ |> Shared.typeToString) in - let typeDefinitions = - (* Expand definitions of types mentioned in typ. - If typ itself is a record or variant, search its body *) - let env = QueryEnv.fromFile file in - let envToSearch, typesToSearch = - match typ |> Shared.digConstructor with - | Some path -> ( - let labelDeclarationsTypes lds = - lds |> List.map (fun (ld : Types.label_declaration) -> ld.ld_type) - in - match References.digConstructor ~env ~package path with - | None -> (env, [typ]) - | Some (env1, {item = {decl}}) -> ( - match decl.type_kind with - | Type_record (lds, _) -> - (env1, typ :: (lds |> labelDeclarationsTypes)) - | Type_variant cds -> - ( env1, - cds - |> List.map (fun (cd : Types.constructor_declaration) -> - let fromArgs = - match cd.cd_args with - | Cstr_tuple ts -> ts - | Cstr_record lds -> lds |> labelDeclarationsTypes - in - typ - :: - (match cd.cd_res with - | None -> fromArgs - | Some t -> t :: fromArgs)) - |> List.flatten ) - | _ -> (env, [typ]))) - | None -> (env, [typ]) - in - let constructors = Shared.findTypeConstructors typesToSearch in - constructors - |> List.filter_map (fun constructorPath -> - match - constructorPath |> fromConstructorPath ~env:envToSearch - with - | None -> None - | Some (typString, extentLoc, env) -> - let startLine, startCol = Pos.ofLexing extentLoc.loc_start in - let linkToTypeDefinitionStr = - if supportsMarkdownLinks then - "\nGo to: " - ^ makeGotoCommand - { - label = "Type definition"; - file = Uri.toString env.file.uri; - startPos = {line = startLine; character = startCol}; - } - else "" - in - Some - (Shared.markdownSpacing ^ codeBlock typString - ^ linkToTypeDefinitionStr ^ "\n\n---\n")) - in - let typeString = typeString :: typeDefinitions |> String.concat "\n\n" in - (typeString, docstring) + hoverWithExpandedTypes ~docstring ~file ~package ~supportsMarkdownLinks + typ in let parts = match References.definedForLoc ~file ~package locKind with @@ -238,9 +239,9 @@ let newHover ~full:{file; package} ~supportsMarkdownLinks locItem = |> List.map (fun (t, _) -> Shared.typeToString t) |> String.concat ", " |> Printf.sprintf "(%s)" in - typeString :: codeBlock (txt ^ argsString) :: docstring + typeString :: Markdown.codeBlock (txt ^ argsString) :: docstring | `Field -> let typeString, docstring = t |> fromType ~docstring in typeString :: docstring) in - Some (String.concat "\n\n" parts) + Some (String.concat "\n\n" parts) \ No newline at end of file diff --git a/analysis/src/Markdown.ml b/analysis/src/Markdown.ml new file mode 100644 index 000000000..54b95872f --- /dev/null +++ b/analysis/src/Markdown.ml @@ -0,0 +1,23 @@ +let spacing = "\n```\n \n```\n" +let codeBlock code = Printf.sprintf "```rescript\n%s\n```" code +let divider = "\n---\n" + +type link = {startPos: Protocol.position; file: string; label: string} + +let linkToCommandArgs link = + Printf.sprintf "[\"%s\",%i,%i]" link.file link.startPos.line + link.startPos.character + +let makeGotoCommand link = + Printf.sprintf "[%s](command:rescript-vscode.go_to_location?%s)" link.label + (Uri.encodeURIComponent (linkToCommandArgs link)) + +let goToDefinitionText ~env ~pos = + let startLine, startCol = Pos.ofLexing pos in + "\nGo to: " + ^ makeGotoCommand + { + label = "Type definition"; + file = Uri.toString env.SharedTypes.QueryEnv.file.uri; + startPos = {line = startLine; character = startCol}; + } \ No newline at end of file diff --git a/analysis/src/Shared.ml b/analysis/src/Shared.ml index af5f3748e..18aac6043 100644 --- a/analysis/src/Shared.ml +++ b/analysis/src/Shared.ml @@ -78,5 +78,3 @@ let typeToString ?lineWidth (t : Types.type_expr) = Hashtbl.replace typeTbl (t.id, t) s; s | Some s -> s - -let markdownSpacing = "\n```\n \n```\n" diff --git a/analysis/src/Uri.ml b/analysis/src/Uri.ml index cbe139d5c..8fbd935c5 100644 --- a/analysis/src/Uri.ml +++ b/analysis/src/Uri.ml @@ -22,3 +22,38 @@ let toTopLevelLoc {path} = {Location.loc_start = topPos; Location.loc_end = topPos; loc_ghost = false} let toString {uri} = if !stripPath then Filename.basename uri else uri + + +(* Light weight, hopefully-enough-for-the-purpose fn to encode URI components. + Built to handle the reserved characters listed in + https://en.wikipedia.org/wiki/Percent-encoding. Note that this function is not + general purpose, rather it's currently only for URL encoding the argument list + passed to command links in markdown. *) +let encodeURIComponent text = + let ln = String.length text in + let buf = Buffer.create ln in + let rec loop i = + if i < ln then ( + (match text.[i] with + | '"' -> Buffer.add_string buf "%22" + | '\'' -> Buffer.add_string buf "%22" + | ':' -> Buffer.add_string buf "%3A" + | ';' -> Buffer.add_string buf "%3B" + | '/' -> Buffer.add_string buf "%2F" + | '\\' -> Buffer.add_string buf "%5C" + | ',' -> Buffer.add_string buf "%2C" + | '&' -> Buffer.add_string buf "%26" + | '[' -> Buffer.add_string buf "%5B" + | ']' -> Buffer.add_string buf "%5D" + | '#' -> Buffer.add_string buf "%23" + | '$' -> Buffer.add_string buf "%24" + | '+' -> Buffer.add_string buf "%2B" + | '=' -> Buffer.add_string buf "%3D" + | '?' -> Buffer.add_string buf "%3F" + | '@' -> Buffer.add_string buf "%40" + | '%' -> Buffer.add_string buf "%25" + | c -> Buffer.add_char buf c); + loop (i + 1)) + in + loop 0; + Buffer.contents buf diff --git a/analysis/src/Uri.mli b/analysis/src/Uri.mli index 5e8013c06..b6e94692b 100644 --- a/analysis/src/Uri.mli +++ b/analysis/src/Uri.mli @@ -6,3 +6,4 @@ val stripPath : bool ref val toPath : t -> string val toString : t -> string val toTopLevelLoc : t -> Location.t +val encodeURIComponent : string -> string diff --git a/analysis/tests/src/Hover.res b/analysis/tests/src/Hover.res index 6748ab900..685eb1d35 100644 --- a/analysis/tests/src/Hover.res +++ b/analysis/tests/src/Hover.res @@ -202,3 +202,11 @@ type useR = {x: int, y: list>>} let testUseR = (v: useR) => v // ^hov + +let usr: useR = { + x: 123, + y: list{}, +} + +// let f = usr +// ^hov diff --git a/analysis/tests/src/expected/Hover.res.txt b/analysis/tests/src/expected/Hover.res.txt index 2596ca073..6b820516a 100644 --- a/analysis/tests/src/expected/Hover.res.txt +++ b/analysis/tests/src/expected/Hover.res.txt @@ -164,3 +164,10 @@ Hover src/Hover.res 197:4 Hover src/Hover.res 202:16 {"contents": "```rescript\nuseR\n```\n\n\n```\n \n```\n```rescript\ntype useR = {x: int, y: list>>}\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22Hover.res%22%2C200%2C0%5D)\n\n---\n\n\n\n```\n \n```\n```rescript\ntype r<'a> = {i: 'a, f: float}\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22Hover.res%22%2C101%2C0%5D)\n\n---\n"} +Hover src/Hover.res 210:13 +Nothing at that position. Now trying to use completion. +posCursor:[210:13] posNoWhite:[210:12] Found expr:[210:11->210:14] +Pexp_ident usr:[210:11->210:14] +Completable: Cpath Value[usr] +{"contents": "```rescript\nuseR\n```\n\n\n```\n \n```\n```rescript\ntype useR = {x: int, y: list>>}\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22Hover.res%22%2C200%2C0%5D)\n\n---\n\n\n\n```\n \n```\n```rescript\ntype r<'a> = {i: 'a, f: float}\n```\nGo to: [Type definition](command:rescript-vscode.go_to_location?%5B%22Hover.res%22%2C101%2C0%5D)\n\n---\n"} +