diff --git a/analysis/.depend b/analysis/.depend index 844274f35..6324d6d6a 100644 --- a/analysis/.depend +++ b/analysis/.depend @@ -1,22 +1,21 @@ src/BuildSystem.cmx : src/ModuleResolution.cmx src/Log.cmx src/Infix.cmx \ src/Files.cmx src/Cli.cmx : src/Commands.cmx -src/Commands.cmx : src/Utils.cmx src/Uri2.cmx src/TopTypes.cmx src/State.cmx \ - src/SharedTypes.cmx src/Shared.cmx src/References.cmx src/Protocol.cmx \ +src/Commands.cmx : src/Utils.cmx src/Uri2.cmx src/SharedTypes.cmx \ + src/Shared.cmx src/References.cmx src/Protocol.cmx src/ProcessCmt.cmx \ src/NewCompletions.cmx src/Hover.cmx src/Files.cmx src/Files.cmx : src/FindFiles.cmx : src/Utils.cmx src/SharedTypes.cmx \ src/ModuleResolution.cmx src/Log.cmx src/vendor/Json.cmx src/Infix.cmx \ src/Files.cmx src/BuildSystem.cmx src/Hover.cmx : src/Utils.cmx src/SharedTypes.cmx src/Shared.cmx \ - src/References.cmx src/Query.cmx + src/References.cmx src/ProcessCmt.cmx src/Infix.cmx : src/Log.cmx src/Files.cmx src/Log.cmx : src/ModuleResolution.cmx : src/Infix.cmx src/Files.cmx src/NewCompletions.cmx : src/Utils.cmx src/Uri2.cmx src/TopTypes.cmx \ - src/State.cmx src/SharedTypes.cmx src/Shared.cmx src/Query.cmx \ - src/Protocol.cmx src/PartialParser.cmx src/Log.cmx src/Infix.cmx \ - src/Hover.cmx + src/SharedTypes.cmx src/Shared.cmx src/Protocol.cmx src/ProcessCmt.cmx \ + src/PartialParser.cmx src/Log.cmx src/Infix.cmx src/Hover.cmx src/Packages.cmx : src/Uri2.cmx src/TopTypes.cmx src/SharedTypes.cmx \ src/Log.cmx src/vendor/Json.cmx src/Infix.cmx src/FindFiles.cmx \ src/Files.cmx src/BuildSystem.cmx @@ -25,26 +24,18 @@ src/PrepareUtils.cmx : src/PrintType.cmx : src/vendor/res_outcome_printer/res_outcome_printer.cmx \ src/vendor/res_outcome_printer/res_doc.cmx src/ProcessAttributes.cmx : src/SharedTypes.cmx src/PrepareUtils.cmx -src/ProcessCmt.cmx : src/Utils.cmx src/SharedTypes.cmx \ - src/ProcessAttributes.cmx src/Infix.cmx -src/ProcessExtra.cmx : src/Utils.cmx src/SharedTypes.cmx src/Shared.cmx \ - src/Query.cmx src/ProcessCmt.cmx src/ProcessAttributes.cmx src/Log.cmx -src/Process_406.cmx : src/SharedTypes.cmx src/Shared.cmx \ - src/ProcessExtra.cmx src/ProcessCmt.cmx src/PrintType.cmx \ - src/Process_406.cmi -src/Process_406.cmi : src/Uri2.cmx src/SharedTypes.cmx +src/ProcessCmt.cmx : src/Utils.cmx src/Uri2.cmx src/TopTypes.cmx \ + src/SharedTypes.cmx src/Shared.cmx src/ProcessAttributes.cmx \ + src/Packages.cmx src/Log.cmx src/Infix.cmx src/FindFiles.cmx \ + src/Files.cmx src/BuildSystem.cmx src/Protocol.cmx : src/vendor/Json.cmx -src/Query.cmx : src/SharedTypes.cmx src/Log.cmx src/Infix.cmx -src/References.cmx : src/Utils.cmx src/Uri2.cmx src/SharedTypes.cmx \ - src/Query.cmx src/Log.cmx src/Infix.cmx +src/References.cmx : src/Utils.cmx src/Uri2.cmx src/TopTypes.cmx \ + src/SharedTypes.cmx src/ProcessCmt.cmx src/Log.cmx src/Infix.cmx src/Shared.cmx : src/PrintType.cmx src/Files.cmx src/SharedTypes.cmx : src/Utils.cmx src/Uri2.cmx src/Shared.cmx \ src/Infix.cmx -src/State.cmx : src/Utils.cmx src/Uri2.cmx src/TopTypes.cmx \ - src/SharedTypes.cmx src/Process_406.cmx src/Packages.cmx src/Log.cmx \ - src/Infix.cmx src/FindFiles.cmx src/Files.cmx src/BuildSystem.cmx src/TopTypes.cmx : src/Uri2.cmx src/SharedTypes.cmx -src/Uri2.cmx : +src/Uri2.cmx : src/Files.cmx src/Utils.cmx : src/Protocol.cmx src/vendor/Json.cmx : src/vendor/res_outcome_printer/res_comment.cmx : \ diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index cfae5fb99..df796254a 100644 --- a/analysis/src/Commands.ml +++ b/analysis/src/Commands.ml @@ -1,24 +1,15 @@ -let dumpLocations state ~package ~file ~extra = +let dumpLocations ~package ~file ~extra = let locations = extra.SharedTypes.locations |> List.filter (fun (l, _) -> not l.Location.loc_ghost) in locations |> List.map (fun ((location : Location.t), loc) -> - let hoverText = - Hover.newHover ~file - ~getModule:(State.fileForModule state ~package) - loc - in + let hoverText = Hover.newHover ~package ~file loc in let hover = match hoverText with None -> "" | Some s -> String.escaped s in - let uriLocOpt = - References.definitionForLoc ~pathsForModule:package.pathsForModule - ~file ~getUri:(State.fileForUri state) - ~getModule:(State.fileForModule state ~package) - loc - in + let uriLocOpt = References.definitionForLoc ~package ~file loc in let def = match uriLocOpt with | None -> Protocol.null @@ -32,41 +23,35 @@ let dumpLocations state ~package ~file ~extra = let dump files = Shared.cacheTypeToString := true; - let state = TopTypes.empty () in files |> List.iter (fun path -> - let filePath = Files.maybeConcat (Unix.getcwd ()) path in - let uri = Uri2.fromPath filePath in + let uri = Uri2.fromLocalPath path in let result = - match State.getFullFromCmt ~state ~uri with + match ProcessCmt.getFullFromCmt ~uri with | Error message -> prerr_endline message; "[]" - | Ok (package, {file; extra}) -> - dumpLocations state ~package ~file ~extra + | Ok (package, {file; extra}) -> dumpLocations ~package ~file ~extra in print_endline result) let complete ~path ~line ~col ~currentFile = - let state = TopTypes.empty () in - let filePath = Files.maybeConcat (Unix.getcwd ()) path in - let uri = Uri2.fromPath filePath in + let uri = Uri2.fromLocalPath path in let result = - match State.getFullFromCmt ~state ~uri with + match ProcessCmt.getFullFromCmt ~uri with | Error message -> prerr_endline message; "[]" | Ok (package, full) -> let maybeText = Files.readFile currentFile in NewCompletions.computeCompletions ~full ~maybeText ~package - ~pos:(line, col) ~state + ~pos:(line, col) |> List.map Protocol.stringifyCompletionItem |> Protocol.array in print_endline result -let hover state ~file ~line ~col ~extra ~package = - let open TopTypes in +let hover ~file ~line ~col ~extra ~package = let locations = extra.SharedTypes.locations |> List.filter (fun (l, _) -> not l.Location.loc_ghost) @@ -80,12 +65,7 @@ let hover state ~file ~line ~col ~extra ~package = | SharedTypes.LModule _ | TopLevelModule _ -> true | TypeDefinition _ | Typed _ | Constant _ | Explanation _ -> false in - let uriLocOpt = - References.definitionForLoc ~pathsForModule:package.pathsForModule ~file - ~getUri:(State.fileForUri state) - ~getModule:(State.fileForModule state ~package) - loc - in + let uriLocOpt = References.definitionForLoc ~package ~file loc in let skipZero = match uriLocOpt with | None -> false @@ -98,27 +78,21 @@ let hover state ~file ~line ~col ~extra ~package = in if skipZero then Protocol.null else - let hoverText = - Hover.newHover ~file ~getModule:(State.fileForModule state ~package) loc - in + let hoverText = Hover.newHover ~file ~package loc in match hoverText with | None -> Protocol.null | Some s -> Protocol.stringifyHover {contents = s}) let hover ~path ~line ~col = - let state = TopTypes.empty () in - let filePath = Files.maybeConcat (Unix.getcwd ()) path in - let uri = Uri2.fromPath filePath in + let uri = Uri2.fromLocalPath path in let result = - match State.getFullFromCmt ~state ~uri with + match ProcessCmt.getFullFromCmt ~uri with | Error message -> Protocol.stringifyHover {contents = message} - | Ok (package, {file; extra}) -> - hover state ~file ~line ~col ~extra ~package + | Ok (package, {file; extra}) -> hover ~file ~line ~col ~extra ~package in print_endline result -let definition state ~file ~line ~col ~extra ~package = - let open TopTypes in +let definition ~file ~line ~col ~extra ~package = let locations = extra.SharedTypes.locations |> List.filter (fun (l, _) -> not l.Location.loc_ghost) @@ -133,12 +107,7 @@ let definition state ~file ~line ~col ~extra ~package = | SharedTypes.LModule _ | TopLevelModule _ -> true | TypeDefinition _ | Typed _ | Constant _ | Explanation _ -> false in - let uriLocOpt = - References.definitionForLoc ~pathsForModule:package.pathsForModule ~file - ~getUri:(State.fileForUri state) - ~getModule:(State.fileForModule state ~package) - loc - in + let uriLocOpt = References.definitionForLoc ~package ~file loc in match uriLocOpt with | None -> Protocol.null | Some (uri2, loc) -> @@ -155,19 +124,15 @@ let definition state ~file ~line ~col ~extra ~package = {uri = Uri2.toString uri2; range = Utils.cmtLocToRange loc}) let definition ~path ~line ~col = - let state = TopTypes.empty () in - let filePath = Files.maybeConcat (Unix.getcwd ()) path in - let uri = Uri2.fromPath filePath in + let uri = Uri2.fromLocalPath path in let result = - match State.getFullFromCmt ~state ~uri with + match ProcessCmt.getFullFromCmt ~uri with | Error _message -> Protocol.null - | Ok (package, {file; extra}) -> - definition state ~file ~line ~col ~extra ~package + | Ok (package, {file; extra}) -> definition ~file ~line ~col ~extra ~package in print_endline result -let references state ~file ~line ~col ~extra ~package = - let open TopTypes in +let references ~file ~line ~col ~extra ~package = let locations = extra.SharedTypes.locations |> List.filter (fun (l, _) -> not l.Location.loc_ghost) @@ -178,12 +143,7 @@ let references state ~file ~line ~col ~extra ~package = | None -> Protocol.null | Some (_, loc) -> let allReferences = - References.allReferencesForLoc ~pathsForModule:package.pathsForModule - ~file ~extra ~allModules:package.localModules - ~getUri:(State.fileForUri state) - ~getModule:(State.fileForModule state ~package) - ~getExtra:(State.extraForModule state ~package) - loc + References.allReferencesForLoc ~package ~file ~extra loc in let allLocs = allReferences @@ -202,14 +162,11 @@ let references state ~file ~line ~col ~extra ~package = "[\n" ^ (allLocs |> String.concat ",\n") ^ "\n]" let references ~path ~line ~col = - let state = TopTypes.empty () in - let filePath = Files.maybeConcat (Unix.getcwd ()) path in - let uri = Uri2.fromPath filePath in + let uri = Uri2.fromLocalPath path in let result = - match State.getFullFromCmt ~state ~uri with + match ProcessCmt.getFullFromCmt ~uri with | Error _message -> Protocol.null - | Ok (package, {file; extra}) -> - references state ~file ~line ~col ~extra ~package + | Ok (package, {file; extra}) -> references ~file ~line ~col ~extra ~package in print_endline result diff --git a/analysis/src/Hover.ml b/analysis/src/Hover.ml index 01bc7a076..541dff229 100644 --- a/analysis/src/Hover.ml +++ b/analysis/src/Hover.ml @@ -1,15 +1,15 @@ -let digConstructor ~env ~getModule path = - match Query.resolveFromCompilerPath ~env ~getModule path with +let digConstructor ~env ~package path = + match ProcessCmt.resolveFromCompilerPath ~env ~package path with | `Not_found -> None | `Stamp stamp -> ( - match Hashtbl.find_opt env.file.stamps.types stamp with + match Hashtbl.find_opt env.qFile.stamps.types stamp with | None -> None | Some t -> Some (env, t)) | `Exported (env, name) -> ( - match Hashtbl.find_opt env.exported.types name with + match Hashtbl.find_opt env.qExported.types name with | None -> None | Some stamp -> ( - match Hashtbl.find_opt env.file.stamps.types stamp with + match Hashtbl.find_opt env.qFile.stamps.types stamp with | None -> None | Some t -> Some (env, t))) | _ -> None @@ -47,7 +47,7 @@ let showModule ~docstring ~(file : SharedTypes.file) ~name showModuleTopLevel ~docstring ~name topLevel | Some {item = Ident _} -> Some "Unable to resolve module reference" -let newHover ~(file : SharedTypes.file) ~getModule loc = +let newHover ~(file : SharedTypes.file) ~package loc = match loc with | SharedTypes.Explanation text -> Some text | TypeDefinition (name, decl, _stamp) -> @@ -58,7 +58,7 @@ let newHover ~(file : SharedTypes.file) ~getModule loc = match Hashtbl.find_opt file.stamps.modules stamp with | None -> None | Some md -> ( - match References.resolveModuleReference ~file ~getModule md with + match References.resolveModuleReference ~file ~package md with | None -> None | Some (file, declared) -> let name, docstring = @@ -68,20 +68,20 @@ let newHover ~(file : SharedTypes.file) ~getModule loc = in showModule ~docstring ~name ~file declared)) | LModule (GlobalReference (moduleName, path, tip)) -> ( - match getModule moduleName with + match ProcessCmt.fileForModule ~package moduleName with | None -> None | Some file -> ( - let env = Query.fileEnv file in - match Query.resolvePath ~env ~path ~getModule with + let env = ProcessCmt.fileEnv file in + match ProcessCmt.resolvePath ~env ~path ~package with | None -> None | Some (env, name) -> ( - match Query.exportedForTip ~env name tip with + match ProcessCmt.exportedForTip ~env name tip with | None -> None | Some stamp -> ( match Hashtbl.find_opt file.stamps.modules stamp with | None -> None | Some md -> ( - match References.resolveModuleReference ~file ~getModule md with + match References.resolveModuleReference ~file ~package md with | None -> None | Some (file, declared) -> let name, docstring = @@ -92,7 +92,7 @@ let newHover ~(file : SharedTypes.file) ~getModule loc = showModule ~docstring ~name ~file declared))))) | LModule NotFound -> None | TopLevelModule name -> ( - match getModule name with + match ProcessCmt.fileForModule ~package name with | None -> None | Some file -> showModule ~docstring:file.contents.docstring ~name:file.moduleName ~file @@ -113,11 +113,11 @@ let newHover ~(file : SharedTypes.file) ~getModule loc = let fromType ~docstring typ = let typeString = codeBlock (typ |> Shared.typeToString) in let extraTypeInfo = - let env = Query.fileEnv file in + let env = ProcessCmt.fileEnv file in match typ |> Shared.digConstructor with | None -> None | Some path -> ( - match digConstructor ~env ~getModule path with + match digConstructor ~env ~package path with | None -> None | Some (_env, {docstring; name = {txt}; item = {decl}}) -> let isUncurriedInternal = @@ -135,7 +135,7 @@ let newHover ~(file : SharedTypes.file) ~getModule loc = (typeString, docstring) in let parts = - match References.definedForLoc ~file ~getModule locKind with + match References.definedForLoc ~file ~package locKind with | None -> let typeString, docstring = t |> fromType ~docstring:[] in typeString :: docstring diff --git a/analysis/src/NewCompletions.ml b/analysis/src/NewCompletions.ml index f98c532ce..26d033806 100644 --- a/analysis/src/NewCompletions.ml +++ b/analysis/src/NewCompletions.ml @@ -13,7 +13,7 @@ let showConstructor {cname = {txt}; args; res} = ^ (res |?>> (fun typ -> "\n" ^ (typ |> Shared.typeToString)) |? "") (* TODO: local opens *) -let resolveOpens ~env ~previous opens ~getModule = +let resolveOpens ~env ~previous opens ~package = List.fold_left (fun previous path -> (* Finding an open, first trying to find it in previoulsly resolved opens *) @@ -23,25 +23,26 @@ let resolveOpens ~env ~previous opens ~getModule = match path with | Tip _ -> previous | Nested (name, path) -> ( - match getModule name with + match ProcessCmt.fileForModule ~package name with | None -> Log.log ("Could not get module " ^ name); previous (* TODO: warn? *) | Some file -> ( match - Query.resolvePath ~env:(Query.fileEnv file) ~getModule ~path + ProcessCmt.resolvePath ~env:(ProcessCmt.fileEnv file) ~package + ~path with | None -> Log.log ("Could not resolve in " ^ name); previous | Some (env, _placeholder) -> previous @ [env]))) | env :: rest -> ( - match Query.resolvePath ~env ~getModule ~path with + match ProcessCmt.resolvePath ~env ~package ~path with | None -> loop rest | Some (env, _placeholder) -> previous @ [env]) in Log.log ("resolving open " ^ pathToString path); - match Query.resolvePath ~env ~getModule ~path with + match ProcessCmt.resolvePath ~env ~package ~path with | None -> Log.log "Not local"; loop previous @@ -136,17 +137,16 @@ let determineCompletion items = Maybe the way to fix it is to make note of what things in an open override locally defined things... *) -let getEnvWithOpens ~pos ~(env : Query.queryEnv) ~getModule - ~(opens : Query.queryEnv list) path = - (* Query.resolvePath(~env, ~path, ~getModule) *) - match Query.resolveFromStamps ~env ~path ~getModule ~pos with +let getEnvWithOpens ~pos ~(env : ProcessCmt.queryEnv) ~package + ~(opens : ProcessCmt.queryEnv list) path = + match ProcessCmt.resolveFromStamps ~env ~path ~package ~pos with | Some x -> Some x | None -> let rec loop opens = match opens with | env :: rest -> ( - Log.log ("Looking for env in " ^ Uri2.toString env.Query.file.uri); - match Query.resolvePath ~env ~getModule ~path with + Log.log ("Looking for env in " ^ Uri2.toString env.ProcessCmt.qFile.uri); + match ProcessCmt.resolvePath ~env ~package ~path with | Some x -> Some x | None -> loop rest) | [] -> ( @@ -154,12 +154,12 @@ let getEnvWithOpens ~pos ~(env : Query.queryEnv) ~getModule | Tip _ -> None | Nested (top, path) -> ( Log.log ("Getting module " ^ top); - match getModule top with + match ProcessCmt.fileForModule ~package top with | None -> None | Some file -> Log.log "got it"; - let env = Query.fileEnv file in - Query.resolvePath ~env ~getModule ~path + let env = ProcessCmt.fileEnv file in + ProcessCmt.resolvePath ~env ~package ~path |> Infix.logIfAbsent "Unable to resolve the path")) in loop opens @@ -195,15 +195,15 @@ let detail name contents = | Constructor (c, t) -> showConstructor c ^ "\n\n" ^ (t.item.decl |> Shared.declToString t.name.txt) -let localValueCompletions ~pos ~(env : Query.queryEnv) suffix = +let localValueCompletions ~pos ~(env : ProcessCmt.queryEnv) suffix = let results = [] in Log.log "---------------- LOCAL VAL"; let results = if suffix = "" || isCapitalized suffix then results - @ completionForDeclareds ~pos env.file.stamps.modules suffix (fun m -> + @ completionForDeclareds ~pos env.qFile.stamps.modules suffix (fun m -> Module m) - @ (completionForConstructors env.exported.types env.file.stamps.types + @ (completionForConstructors env.qExported.types env.qFile.stamps.types (* TODO declared thingsz *) suffix |> List.map (fun (c, t) -> @@ -213,35 +213,35 @@ let localValueCompletions ~pos ~(env : Query.queryEnv) suffix = let results = if suffix = "" || not (isCapitalized suffix) then results - @ completionForDeclareds ~pos env.file.stamps.values suffix (fun v -> + @ completionForDeclareds ~pos env.qFile.stamps.values suffix (fun v -> Value v) - @ completionForDeclareds ~pos env.file.stamps.types suffix (fun t -> + @ completionForDeclareds ~pos env.qFile.stamps.types suffix (fun t -> Type t) - @ (completionForFields env.exported.types env.file.stamps.types suffix + @ (completionForFields env.qExported.types env.qFile.stamps.types suffix |> List.map (fun (f, t) -> {(emptyDeclared f.fname.txt) with item = Field (f, t)})) else results in - results |> List.map (fun x -> (env.file.uri, x)) + results |> List.map (fun x -> (env.qFile.uri, x)) -let valueCompletions ~(env : Query.queryEnv) suffix = - Log.log (" - Completing in " ^ Uri2.toString env.file.uri); +let valueCompletions ~(env : ProcessCmt.queryEnv) suffix = + Log.log (" - Completing in " ^ Uri2.toString env.qFile.uri); let results = [] in let results = if suffix = "" || isCapitalized suffix then ( (* Get rid of lowercase modules (#417) *) - env.exported.modules + env.qExported.modules |> Hashtbl.filter_map_inplace (fun name key -> match isCapitalized name with true -> Some key | false -> None); let moduleCompletions = - completionForExporteds env.exported.modules env.file.stamps.modules + completionForExporteds env.qExported.modules env.qFile.stamps.modules suffix (fun m -> Module m) in (* Log.log(" -- capitalized " ++ string_of_int(Hashtbl.length(env.exported.types)) ++ " exported types"); *) (* env.exported.types |> Hashtbl.iter((name, _) => Log.log(" > " ++ name)); *) results @ moduleCompletions @ ((* TODO declared thingsz *) - completionForConstructors env.exported.types env.file.stamps.types + completionForConstructors env.qExported.types env.qFile.stamps.types suffix |> List.map (fun (c, t) -> {(emptyDeclared c.cname.txt) with item = Constructor (c, t)}))) @@ -251,70 +251,72 @@ let valueCompletions ~(env : Query.queryEnv) suffix = if suffix = "" || not (isCapitalized suffix) then ( Log.log " -- not capitalized"; results - @ completionForExporteds env.exported.values env.file.stamps.values suffix - (fun v -> Value v) - @ completionForExporteds env.exported.types env.file.stamps.types suffix + @ completionForExporteds env.qExported.values env.qFile.stamps.values + suffix (fun v -> Value v) + @ completionForExporteds env.qExported.types env.qFile.stamps.types suffix (fun t -> Type t) - @ (completionForFields env.exported.types env.file.stamps.types suffix + @ (completionForFields env.qExported.types env.qFile.stamps.types suffix |> List.map (fun (f, t) -> {(emptyDeclared f.fname.txt) with item = Field (f, t)}))) else results in (* Log.log("Getting value completions " ++ env.file.uri); Log.log(String.concat(", ", results |. Belt.List.map(x => x.name.txt))); *) - results |> List.map (fun x -> (env.file.uri, x)) + results |> List.map (fun x -> (env.qFile.uri, x)) -let attributeCompletions ~(env : Query.queryEnv) ~suffix = +let attributeCompletions ~(env : ProcessCmt.queryEnv) ~suffix = let results = [] in let results = if suffix = "" || isCapitalized suffix then results - @ completionForExporteds env.exported.modules env.file.stamps.modules + @ completionForExporteds env.qExported.modules env.qFile.stamps.modules suffix (fun m -> Module m) else results in let results = if suffix = "" || not (isCapitalized suffix) then results - @ completionForExporteds env.exported.values env.file.stamps.values suffix - (fun v -> Value v) + @ completionForExporteds env.qExported.values env.qFile.stamps.values + suffix (fun v -> Value v) (* completionForExporteds(env.exported.types, env.file.stamps.types, suffix, t => Type(t)) @ *) - @ (completionForFields env.exported.types env.file.stamps.types suffix + @ (completionForFields env.qExported.types env.qFile.stamps.types suffix |> List.map (fun (f, t) -> {(emptyDeclared f.fname.txt) with item = Field (f, t)})) else results in - results |> List.map (fun x -> (env.file.uri, x)) + results |> List.map (fun x -> (env.qFile.uri, x)) (* TODO filter out things that are defined after the current position *) -let resolveRawOpens ~env ~getModule ~rawOpens ~package = +let resolveRawOpens ~env ~rawOpens ~package = (* TODO Stdlib instead of Pervasives *) let packageOpens = "Pervasives" :: package.TopTypes.opens in Log.log ("Package opens " ^ String.concat " " packageOpens); let opens = resolveOpens ~env ~previous: - (List.map Query.fileEnv (packageOpens |> Utils.filterMap getModule)) - rawOpens ~getModule + (List.map ProcessCmt.fileEnv + (packageOpens |> Utils.filterMap (ProcessCmt.fileForModule ~package))) + rawOpens ~package in opens -let getItems ~full ~package ~rawOpens ~getModule ~allModules ~pos ~parts = +let getItems ~full ~package ~rawOpens ~allModules ~pos ~parts = Log.log ("Opens folkz > " ^ string_of_int (List.length rawOpens) ^ " " ^ String.concat " ... " (rawOpens |> List.map pathToString)); - let env = Query.fileEnv full.file in + let env = ProcessCmt.fileEnv full.file in let packageOpens = "Pervasives" :: package.TopTypes.opens in Log.log ("Package opens " ^ String.concat " " packageOpens); - let resolvedOpens = resolveRawOpens ~env ~getModule ~rawOpens ~package in + let resolvedOpens = resolveRawOpens ~env ~rawOpens ~package in Log.log ("Opens nows " ^ string_of_int (List.length resolvedOpens) ^ " " ^ String.concat " " - (resolvedOpens |> List.map (fun e -> Uri2.toString e.Query.file.uri))); + (resolvedOpens + |> List.map (fun e -> Uri2.toString e.ProcessCmt.qFile.uri))); (* Last open takes priority *) let opens = List.rev resolvedOpens in match parts with @@ -347,7 +349,7 @@ let getItems ~full ~package ~rawOpens ~getModule ~allModules ~pos ~parts = with | true -> Some - ( env.file.uri, + ( env.qFile.uri, {(emptyDeclared name) with item = FileModule name} ) | false -> None) in @@ -357,7 +359,7 @@ let getItems ~full ~package ~rawOpens ~getModule ~allModules ~pos ~parts = match determineCompletion multiple with | `Normal path -> ( Log.log ("normal " ^ pathToString path); - match getEnvWithOpens ~pos ~env ~getModule ~opens path with + match getEnvWithOpens ~pos ~env ~package ~opens path with | Some (env, suffix) -> Log.log "Got the env"; valueCompletions ~env suffix @@ -368,14 +370,14 @@ let getItems ~full ~package ~rawOpens ~getModule ~allModules ~pos ~parts = | [] -> [] | first :: rest -> ( Log.log ("-------------- Looking for " ^ first); - match Query.findInScope pos first env.file.stamps.values with + match ProcessCmt.findInScope pos first env.qFile.stamps.values with | None -> [] | Some declared -> ( Log.log ("Found it! " ^ declared.name.txt); match declared.item |> Shared.digConstructor with | None -> [] | Some path -> ( - match Hover.digConstructor ~env ~getModule path with + match Hover.digConstructor ~env ~package path with | None -> [] | Some (env, typ) -> ( match @@ -397,7 +399,7 @@ let getItems ~full ~package ~rawOpens ~getModule ~allModules ~pos ~parts = match attr.typ |> Shared.digConstructor with | None -> None | Some path -> - Hover.digConstructor ~env ~getModule path)) + Hover.digConstructor ~env ~package path)) | _ -> None)) (Some (env, typ)) with @@ -409,7 +411,7 @@ let getItems ~full ~package ~rawOpens ~getModule ~allModules ~pos ~parts = |> Utils.filterMap (fun f -> if Utils.startsWith f.fname.txt suffix then Some - ( env.file.uri, + ( env.qFile.uri, { (emptyDeclared f.fname.txt) with item = Field (f, typ); @@ -417,7 +419,7 @@ let getItems ~full ~package ~rawOpens ~getModule ~allModules ~pos ~parts = else None) | _ -> [])))))) | `AbsAttribute path -> ( - match getEnvWithOpens ~pos ~env ~getModule ~opens path with + match getEnvWithOpens ~pos ~env ~package ~opens path with | None -> [] | Some (env, suffix) -> attributeCompletions ~env ~suffix @@ -433,20 +435,16 @@ let mkItem ~name ~kind ~detail ~deprecated ~docstring ~uri ~pos_lnum = ^ "\n" ^ Uri2.toString uri ^ ":" ^ string_of_int pos_lnum in let tags = - match deprecated = None with - | true -> [] - | false -> [1 (* deprecated *)] + match deprecated = None with true -> [] | false -> [1 (* deprecated *)] in - Protocol.{ - label = name; - kind = kind; - tags = tags; - detail = detail; - documentation = { - kind = "markdown"; - value = valueMessage; - }; - } + Protocol. + { + label = name; + kind; + tags; + detail; + documentation = {kind = "markdown"; value = valueMessage}; + } let processCompletable ~findItems ~full ~package ~pos ~rawOpens (completable : PartialParser.completable) = @@ -666,7 +664,7 @@ let processCompletable ~findItems ~full ~package ~pos ~rawOpens |> List.filter (fun (name, _t) -> Utils.startsWith name prefix) |> List.map mkLabel -let computeCompletions ~full ~maybeText ~package ~pos ~state = +let computeCompletions ~full ~maybeText ~package ~pos = match maybeText with | None -> [] | Some text -> ( @@ -682,9 +680,7 @@ let computeCompletions ~full ~maybeText ~package ~pos ~state = in let findItems ~exact parts = let items = - getItems ~full ~package ~rawOpens - ~getModule:(State.fileForModule state ~package) - ~allModules ~pos ~parts + getItems ~full ~package ~rawOpens ~allModules ~pos ~parts in match parts |> List.rev with | last :: _ when exact -> diff --git a/analysis/src/Packages.ml b/analysis/src/Packages.ml index 585d571b3..56a789985 100644 --- a/analysis/src/Packages.ml +++ b/analysis/src/Packages.ml @@ -113,7 +113,7 @@ let findRoot ~uri packagesByRoot = in loop (Filename.dirname path) -let getPackage ~uri state = +let getPackage ~uri = if Hashtbl.mem state.rootForUri uri then Ok (Hashtbl.find state.packagesByRoot (Hashtbl.find state.rootForUri uri)) else diff --git a/analysis/src/ProcessCmt.ml b/analysis/src/ProcessCmt.ml index d0c15b4c1..6cb61490c 100644 --- a/analysis/src/ProcessCmt.ml +++ b/analysis/src/ProcessCmt.ml @@ -2,6 +2,10 @@ open Typedtree open SharedTypes open Infix +type queryEnv = {qFile : file; qExported : exported} + +let fileEnv file = {qFile = file; qExported = file.contents.exported} + let itemsExtent items = let open Typedtree in match items with @@ -511,3 +515,836 @@ let forCmt ~moduleName ~uri ({cmt_modname; cmt_annots} : Cmt_format.cmt_infos) = let contents = forSignature ~env signature.sig_items in {uri; moduleName = cmt_modname; stamps = env.stamps; contents} | _ -> SharedTypes.emptyFile moduleName uri + +let fileForCmt ~moduleName ~uri cmt = + match Shared.tryReadCmt cmt with + | Error e -> Error e + | Ok infos -> Ok (forCmt ~moduleName ~uri infos) + +let extraForFile ~(file : SharedTypes.file) = + let extra = initExtra () in + let addLocation loc ident = + extra.locations <- (loc, ident) :: extra.locations + in + let addReference stamp loc = + Hashtbl.replace extra.internalReferences stamp + (loc + :: + (match Hashtbl.mem extra.internalReferences stamp with + | true -> Hashtbl.find extra.internalReferences stamp + | false -> [])) + in + file.stamps.modules + |> Hashtbl.iter (fun stamp d -> + addLocation d.name.loc (LModule (Definition (stamp, Module))); + addReference stamp d.name.loc); + file.stamps.values + |> Hashtbl.iter (fun stamp d -> + addLocation d.name.loc (Typed (d.item, Definition (stamp, Value))); + addReference stamp d.name.loc); + file.stamps.types + |> Hashtbl.iter (fun stamp d -> + addLocation d.name.loc + (TypeDefinition (d.name.txt, d.item.Type.decl, stamp)); + addReference stamp d.name.loc; + match d.item.Type.kind with + | Record labels -> + labels + |> List.iter (fun {stamp; fname; typ} -> + addReference stamp fname.loc; + addLocation fname.loc + (Typed (typ, Definition (d.stamp, Field fname.txt)))) + | Variant constructos -> + constructos + |> List.iter (fun {stamp; cname} -> + addReference stamp cname.loc; + let t = + { + Types.id = 0; + level = 0; + desc = + Tconstr + ( Path.Pident + {Ident.stamp; name = d.name.txt; flags = 0}, + [], + ref Types.Mnil ); + } + in + addLocation cname.loc + (Typed (t, Definition (d.stamp, Constructor cname.txt)))) + | _ -> ()); + extra + +let rec relative ident path = + match (ident, path) with + | Longident.Lident name, Path.Pdot (path, pname, _) when pname = name -> + Some path + | Longident.Ldot (ident, name), Path.Pdot (path, pname, _) when pname = name + -> + relative ident path + (* | (Ldot(Lident("*predef*" | "exn"), _), Pident(_)) => None *) + | _ -> None + +let findClosestMatchingOpen opens path ident loc = + match relative ident path with + | None -> None + | Some openNeedle -> ( + let matching = + Hashtbl.fold + (fun _ op res -> + if Utils.locWithinLoc loc op.extent && Path.same op.path openNeedle + then op :: res + else res) + opens [] + |> List.sort (fun (a : SharedTypes.openTracker) b -> + b.loc.loc_start.pos_cnum - a.loc.loc_start.pos_cnum) + in + match matching with [] -> None | first :: _ -> Some first) + +let rec joinPaths modulePath path = + match modulePath with + | Path.Pident ident -> (ident.stamp, ident.name, path) + | Papply (fnPath, _argPath) -> joinPaths fnPath path + | Pdot (inner, name, _) -> joinPaths inner (Nested (name, path)) + +let rec makePath modulePath = + match modulePath with + | Path.Pident ident when ident.stamp == 0 -> `GlobalMod ident.name + | Pident ident -> `Stamp ident.stamp + | Papply (fnPath, _argPath) -> makePath fnPath + | Pdot (inner, name, _) -> `Path (joinPaths inner (Tip name)) + +let rec resolvePathInner ~env ~path = + match path with + | Tip name -> Some (`Local (env, name)) + | Nested (subName, subPath) -> ( + match Hashtbl.find_opt env.qExported.modules subName with + | None -> None + | Some stamp -> ( + match Hashtbl.find_opt env.qFile.stamps.modules stamp with + | None -> None + | Some {item = kind} -> findInModule ~env kind subPath)) + +and findInModule ~env kind path = + match kind with + | Structure {exported} -> + resolvePathInner ~env:{env with qExported = exported} ~path + | Ident modulePath -> ( + let stamp, moduleName, fullPath = joinPaths modulePath path in + if stamp = 0 then Some (`Global (moduleName, fullPath)) + else + match Hashtbl.find_opt env.qFile.stamps.modules stamp with + | None -> None + | Some {item = kind} -> findInModule ~env kind fullPath) + +let fromCompilerPath ~env path = + match makePath path with + | `Stamp stamp -> `Stamp stamp + | `Path (0, moduleName, path) -> `Global (moduleName, path) + | `GlobalMod name -> `GlobalMod name + | `Path (stamp, _moduleName, path) -> ( + let res = + match Hashtbl.find_opt env.qFile.stamps.modules stamp with + | None -> None + | Some {item = kind} -> findInModule ~env kind path + in + match res with + | None -> `Not_found + | Some (`Local (env, name)) -> `Exported (env, name) + | Some (`Global (moduleName, fullPath)) -> `Global (moduleName, fullPath)) + +module F (Collector : sig + val extra : extra + + val file : file + + val scopeExtent : Location.t list ref +end) = +struct + let extra = Collector.extra + + let makeRelativePath basePath otherPath = + let rec loop base other tip = + if Path.same base other then Some tip + else + match other with + | Pdot (inner, name, _) -> loop basePath inner (Nested (name, tip)) + | _ -> None + in + match otherPath with + | Path.Pdot (inner, name, _) -> loop basePath inner (Tip name) + | _ -> None + + let maybeAddUse path ident loc tip = + match findClosestMatchingOpen extra.opens path ident loc with + | None -> () + | Some tracker -> ( + match makeRelativePath tracker.path path with + | None -> () + | Some relpath -> tracker.used <- (relpath, tip, loc) :: tracker.used) + + let addLocation loc ident = extra.locations <- (loc, ident) :: extra.locations + + let addReference stamp loc = + Hashtbl.replace extra.internalReferences stamp + (loc + :: + (match Hashtbl.mem extra.internalReferences stamp with + | true -> Hashtbl.find extra.internalReferences stamp + | false -> [])) + + let addExternalReference moduleName path tip loc = + (* TODO need to follow the path, and be able to load the files to follow module references... *) + Hashtbl.replace extra.externalReferences moduleName + ((path, tip, loc) + :: + (match Hashtbl.mem extra.externalReferences moduleName with + | true -> Hashtbl.find extra.externalReferences moduleName + | false -> [])) + + let env = fileEnv Collector.file + + let addForPath path lident loc typ tip = + maybeAddUse path lident loc tip; + let identName = Longident.last lident in + let identLoc = Utils.endOfLocation loc (String.length identName) in + let locType = + match fromCompilerPath ~env path with + | `Stamp stamp -> + addReference stamp identLoc; + LocalReference (stamp, tip) + | `Not_found -> NotFound + | `Global (moduleName, path) -> + addExternalReference moduleName path tip identLoc; + GlobalReference (moduleName, path, tip) + | `Exported (env, name) -> ( + match + Hashtbl.find_opt + (match tip = Type with + | true -> env.qExported.types + | false -> env.qExported.values) + name + with + | Some stamp -> + addReference stamp identLoc; + LocalReference (stamp, tip) + | None -> NotFound) + | `GlobalMod _ -> NotFound + in + addLocation loc (Typed (typ, locType)) + + let addForPathParent path loc = + let locType = + match fromCompilerPath ~env path with + | `GlobalMod name -> + (* TODO track external references to filenames to handle renames well *) + TopLevelModule name + | `Stamp stamp -> + addReference stamp loc; + LModule (LocalReference (stamp, Module)) + | `Not_found -> LModule NotFound + | `Global (moduleName, path) -> + addExternalReference moduleName path Module loc; + LModule (GlobalReference (moduleName, path, Module)) + | `Exported (env, name) -> ( + match Hashtbl.find_opt env.qExported.modules name with + | Some stamp -> + addReference stamp loc; + LModule (LocalReference (stamp, Module)) + | None -> LModule NotFound) + in + addLocation loc locType + + let getTypeAtPath ~env path = + match fromCompilerPath ~env path with + | `GlobalMod _ -> `Not_found + | `Global (moduleName, path) -> `Global (moduleName, path) + | `Not_found -> `Not_found + | `Exported (env, name) -> ( + match Hashtbl.find_opt env.qExported.types name with + | None -> `Not_found + | Some stamp -> ( + let declaredType = Hashtbl.find_opt env.qFile.stamps.types stamp in + match declaredType with + | Some declaredType -> `Local declaredType + | None -> `Not_found)) + | `Stamp stamp -> ( + let declaredType = Hashtbl.find_opt env.qFile.stamps.types stamp in + match declaredType with + | Some declaredType -> `Local declaredType + | None -> `Not_found) + + let handleConstructor path txt = + let typeName = + match path with + | Path.Pdot (_path, typename, _) -> typename + | Pident ident -> Ident.name ident + | _ -> assert false + in + let open Longident in + match txt with + | Longident.Lident name -> (name, Lident typeName) + | Ldot (left, name) -> (name, Ldot (left, typeName)) + | Lapply (_, _) -> assert false + + let addForField recordType item {Asttypes.txt; loc} = + match (Shared.dig recordType).desc with + | Tconstr (path, _args, _memo) -> + let t = getTypeAtPath ~env path in + let {Types.lbl_res} = item in + let name, typeLident = handleConstructor path txt in + maybeAddUse path typeLident loc (Field name); + let nameLoc = Utils.endOfLocation loc (String.length name) in + let locType = + match t with + | `Local {stamp; item = {kind = Record fields}} -> ( + match fields |> List.find_opt (fun f -> f.fname.txt = name) with + | Some {stamp = astamp} -> + addReference astamp nameLoc; + LocalReference (stamp, Field name) + | None -> NotFound) + | `Global (moduleName, path) -> + addExternalReference moduleName path (Field name) nameLoc; + GlobalReference (moduleName, path, Field name) + | _ -> NotFound + in + addLocation nameLoc (Typed (lbl_res, locType)) + | _ -> () + + let addForRecord recordType items = + match (Shared.dig recordType).desc with + | Tconstr (path, _args, _memo) -> + let t = getTypeAtPath ~env path in + items + |> List.iter (fun ({Asttypes.txt; loc}, {Types.lbl_res}, _) -> + (* let name = Longident.last(txt); *) + let name, typeLident = handleConstructor path txt in + maybeAddUse path typeLident loc (Field name); + let nameLoc = Utils.endOfLocation loc (String.length name) in + let locType = + match t with + | `Local {stamp; item = {kind = Record fields}} -> ( + match + fields |> List.find_opt (fun f -> f.fname.txt = name) + with + | Some {stamp = astamp} -> + addReference astamp nameLoc; + LocalReference (stamp, Field name) + | None -> NotFound) + | `Global (moduleName, path) -> + addExternalReference moduleName path (Field name) nameLoc; + GlobalReference (moduleName, path, Field name) + | _ -> NotFound + in + addLocation nameLoc (Typed (lbl_res, locType))) + | _ -> () + + let addForConstructor constructorType {Asttypes.txt; loc} {Types.cstr_name} = + match (Shared.dig constructorType).desc with + | Tconstr (path, _args, _memo) -> + (* let name = Longident.last(txt); *) + let name, typeLident = handleConstructor path txt in + maybeAddUse path typeLident loc (Constructor name); + let nameLoc = Utils.endOfLocation loc (String.length name) in + let t = getTypeAtPath ~env path in + let locType = + match t with + | `Local {stamp; item = {kind = Variant constructors}} -> ( + match + constructors |> List.find_opt (fun c -> c.cname.txt = cstr_name) + with + | Some {stamp = cstamp} -> + addReference cstamp nameLoc; + LocalReference (stamp, Constructor name) + | None -> NotFound) + | `Global (moduleName, path) -> + addExternalReference moduleName path (Constructor name) nameLoc; + GlobalReference (moduleName, path, Constructor name) + | _ -> NotFound + in + addLocation nameLoc (Typed (constructorType, locType)) + | _ -> () + + let currentScopeExtent () = + if !Collector.scopeExtent = [] then Location.none + else List.hd !Collector.scopeExtent + + let addScopeExtent loc = + Collector.scopeExtent := loc :: !Collector.scopeExtent + + let popScopeExtent () = + if List.length !Collector.scopeExtent > 1 then + Collector.scopeExtent := List.tl !Collector.scopeExtent + + let rec addForLongident top (path : Path.t) (txt : Longident.t) loc = + if not loc.Location.loc_ghost then ( + let idLength = + String.length (String.concat "." (Longident.flatten txt)) + in + let reportedLength = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in + let isPpx = idLength <> reportedLength in + if isPpx then + match top with + | Some (t, tip) -> addForPath path txt loc t tip + | None -> addForPathParent path loc + else + let l = Utils.endOfLocation loc (String.length (Longident.last txt)) in + (match top with + | Some (t, tip) -> addForPath path txt l t tip + | None -> addForPathParent path l); + match (path, txt) with + | Pdot (pinner, _pname, _), Ldot (inner, name) -> + addForLongident None pinner inner + (Utils.chopLocationEnd loc (String.length name + 1)) + | Pident _, Lident _ -> () + | _ -> ()) + + let rec handle_module_expr expr = + match expr with + | Tmod_constraint (expr, _, _, _) -> handle_module_expr expr.mod_desc + | Tmod_ident (path, {txt; loc}) -> + Log.log ("Ident!! " ^ String.concat "." (Longident.flatten txt)); + maybeAddUse path txt loc Module; + addForLongident None path txt loc + | Tmod_functor (_ident, _argName, _maybeType, resultExpr) -> + handle_module_expr resultExpr.mod_desc + | Tmod_apply (obj, arg, _) -> + handle_module_expr obj.mod_desc; + handle_module_expr arg.mod_desc + | _ -> () + + open Typedtree + include TypedtreeIter.DefaultIteratorArgument + + let enter_structure_item item = + match item.str_desc with + | Tstr_attribute + ( {Asttypes.txt = "ocaml.explanation"; loc}, + PStr + [ + { + pstr_desc = + Pstr_eval + ({pexp_desc = Pexp_constant (Pconst_string (doc, _))}, _); + }; + ] ) -> + addLocation loc (Explanation doc) + | Tstr_include {incl_mod = expr} -> handle_module_expr expr.mod_desc + | Tstr_module {mb_expr} -> handle_module_expr mb_expr.mod_desc + | Tstr_open {open_path; open_txt = {txt; loc}} -> + (* Log.log("Have an open here"); *) + maybeAddUse open_path txt loc Module; + let tracker = + { + path = open_path; + loc; + used = []; + extent = + { + loc_ghost = true; + loc_start = loc.loc_end; + loc_end = (currentScopeExtent ()).loc_end; + }; + } + in + addForLongident None open_path txt loc; + Hashtbl.replace Collector.extra.opens loc tracker + | _ -> () + + let enter_structure {str_items} = + if str_items <> [] then + let first = List.hd str_items in + let last = List.nth str_items (List.length str_items - 1) in + let extent = + { + Location.loc_ghost = true; + loc_start = first.str_loc.loc_start; + loc_end = last.str_loc.loc_end; + } + in + addScopeExtent extent + + let leave_structure str = if str.str_items <> [] then popScopeExtent () + + let enter_signature_item item = + match item.sig_desc with + | Tsig_value {val_id; val_loc; val_name = name; val_desc; val_attributes} -> + let stamp = Ident.binding_time val_id in + if not (Hashtbl.mem Collector.file.stamps.values stamp) then ( + let declared = + ProcessAttributes.newDeclared ~name ~stamp ~extent:val_loc + ~scope: + { + loc_ghost = true; + loc_start = val_loc.loc_end; + loc_end = (currentScopeExtent ()).loc_end; + } + ~modulePath:NotVisible ~item:val_desc.ctyp_type false val_attributes + in + Hashtbl.add Collector.file.stamps.values stamp declared; + addReference stamp name.loc; + addLocation name.loc + (Typed (val_desc.ctyp_type, Definition (stamp, Value)))) + | _ -> () + + let enter_core_type {ctyp_type; ctyp_desc} = + match ctyp_desc with + | Ttyp_constr (path, {txt; loc}, _args) -> + (* addForPath(path, txt, loc, Shared.makeFlexible(ctyp_type), Type) *) + addForLongident (Some (ctyp_type, Type)) path txt loc + | _ -> () + + let enter_pattern {pat_desc; pat_loc; pat_type; pat_attributes} = + let addForPattern stamp name = + if not (Hashtbl.mem Collector.file.stamps.values stamp) then ( + let declared = + ProcessAttributes.newDeclared ~name ~stamp + ~scope: + { + loc_ghost = true; + loc_start = pat_loc.loc_end; + loc_end = (currentScopeExtent ()).loc_end; + } + ~modulePath:NotVisible ~extent:pat_loc ~item:pat_type false + pat_attributes + in + Hashtbl.add Collector.file.stamps.values stamp declared; + addReference stamp name.loc; + addLocation name.loc (Typed (pat_type, Definition (stamp, Value)))) + in + (* Log.log("Entering pattern " ++ Utils.showLocation(pat_loc)); *) + match pat_desc with + | Tpat_record (items, _) -> addForRecord pat_type items + | Tpat_construct (lident, constructor, _) -> + addForConstructor pat_type lident constructor + | Tpat_alias (_inner, ident, name) -> + let stamp = Ident.binding_time ident in + addForPattern stamp name + | Tpat_var (ident, name) -> + (* Log.log("Pattern " ++ name.txt); *) + let stamp = Ident.binding_time ident in + addForPattern stamp name + | _ -> () + + let enter_expression expression = + expression.exp_extra + |> List.iter (fun (e, eloc, _) -> + match e with + | Texp_open (_, path, _ident, _) -> + Hashtbl.add extra.opens eloc + {path; loc = eloc; extent = expression.exp_loc; used = []} + | _ -> ()); + match expression.exp_desc with + | Texp_ident (path, {txt; loc}, {val_type}) -> + addForLongident (Some (val_type, Value)) path txt loc + | Texp_record {fields} -> + addForRecord expression.exp_type + (fields |> Array.to_list + |> Utils.filterMap (fun (desc, item) -> + match item with + | Overridden (loc, _) -> Some (loc, desc, ()) + | _ -> None)) + | Texp_constant constant -> + addLocation expression.exp_loc (Constant constant) + (* Skip unit and list literals *) + | Texp_construct ({txt = Lident ("()" | "::"); loc}, _, _args) + when loc.loc_end.pos_cnum - loc.loc_start.pos_cnum <> 2 -> + () + | Texp_construct (lident, constructor, _args) -> + addForConstructor expression.exp_type lident constructor + | Texp_field (inner, lident, label_description) -> + addForField inner.exp_type label_description lident + | Texp_let (_, _, _) -> + (* TODO this scope tracking won't work for recursive *) + addScopeExtent expression.exp_loc + | Texp_function {cases} -> ( + match cases with [{c_rhs}] -> addScopeExtent c_rhs.exp_loc | _ -> ()) + | _ -> () + + let leave_expression expression = + match expression.exp_desc with + | Texp_let (_isrec, _bindings, _expr) -> popScopeExtent () + | Texp_function {cases} -> ( + match cases with [_] -> popScopeExtent () | _ -> ()) + | _ -> () +end + +let forItems ~(file : SharedTypes.file) items parts = + let extra = extraForFile ~file in + let extent = itemsExtent items in + let extent = + { + extent with + loc_end = + { + extent.loc_end with + pos_lnum = extent.loc_end.pos_lnum + 1000000; + pos_cnum = extent.loc_end.pos_cnum + 100000000; + }; + } + in + (* TODO look through parts and extend the extent *) + let module Iter = TypedtreeIter.MakeIterator (F (struct + let scopeExtent = ref [extent] + + let extra = extra + + let file = file + end)) in + List.iter Iter.iter_structure_item items; + (* Log.log("Parts " ++ string_of_int(Array.length(parts))); *) + parts + |> Array.iter (fun part -> + match part with + | Cmt_format.Partial_signature str -> Iter.iter_signature str + | Partial_signature_item str -> Iter.iter_signature_item str + | Partial_expression expression -> Iter.iter_expression expression + | Partial_pattern pattern -> Iter.iter_pattern pattern + | Partial_class_expr class_expr -> Iter.iter_class_expr class_expr + | Partial_module_type module_type -> Iter.iter_module_type module_type + | Partial_structure _ | Partial_structure_item _ -> ()); + extra + +let extraForCmt ~file ({cmt_annots} : Cmt_format.cmt_infos) = + match cmt_annots with + | Partial_implementation parts -> + let items = + parts |> Array.to_list + |> Utils.filterMap (fun (p : Cmt_format.binary_part) -> + match p with + | Partial_structure str -> Some str.str_items + | Partial_structure_item str -> Some [str] + (* | Partial_expression(exp) => Some([ str]) *) + | _ -> None) + |> List.concat + in + forItems ~file items parts + | Implementation structure -> forItems ~file structure.str_items [||] + | Partial_interface _ | Interface _ -> forItems ~file [] [||] + | _ -> forItems ~file [] [||] + +let fullForCmt ~moduleName ~uri cmt = + match Shared.tryReadCmt cmt with + | Error e -> Error e + | Ok infos -> + let file = forCmt ~moduleName ~uri infos in + let extra = extraForCmt ~file infos in + Ok {SharedTypes.file; extra} + +open SharedTypes + +let newDocsForCmt ~moduleName cmtCache changed cmt src = + let open Infix in + let uri = Uri2.fromPath (src |? cmt) in + match fileForCmt ~moduleName ~uri cmt with + | Error e -> + Log.log e; + None + | Ok file -> + Hashtbl.replace cmtCache cmt (changed, file); + Some file + +let getFullFromCmt ~uri = + let path = Uri2.toPath uri in + match Packages.getPackage uri with + | Error e -> Error e + | Ok package -> ( + let moduleName = + BuildSystem.namespacedName package.namespace (FindFiles.getName path) + in + match Hashtbl.find_opt package.pathsForModule moduleName with + | Some paths -> ( + let cmt = SharedTypes.getCmt ~interface:(Utils.endsWith path "i") paths in + match fullForCmt ~moduleName ~uri cmt with + | Error e -> Error e + | Ok full -> + Hashtbl.replace package.interModuleDependencies moduleName + (SharedTypes.hashList full.extra.externalReferences |> List.map fst); + Ok (package, full)) + | None -> Error ("can't find module " ^ moduleName)) + +let fileForUri uri = + match getFullFromCmt ~uri with + | Error e -> Error e + | Ok (_package, {extra; file}) -> Ok (file, extra) + +let extraForModule ~package modname = + if Hashtbl.mem package.TopTypes.pathsForModule modname then + let paths = Hashtbl.find package.pathsForModule modname in + match SharedTypes.getSrc paths with + | None -> None + | Some src -> ( + match getFullFromCmt ~uri:(Uri2.fromPath src) with + | Ok (_package, {extra}) -> Some extra + | Error _ -> None) + else None + +let docsForCmt ~moduleName cmt src state = + if Hashtbl.mem state.TopTypes.cmtCache cmt then + let mtime, docs = Hashtbl.find state.cmtCache cmt in + (* TODO: I should really throttle this mtime checking to like every 50 ms or so *) + match Files.getMtime cmt with + | None -> + Log.log + ("\226\154\160\239\184\143 cannot get docs for nonexistant cmt " ^ cmt); + None + | Some changed -> + if changed > mtime then + newDocsForCmt ~moduleName state.cmtCache changed cmt src + else Some docs + else + match Files.getMtime cmt with + | None -> + Log.log + ("\226\154\160\239\184\143 cannot get docs for nonexistant cmt " ^ cmt); + None + | Some changed -> newDocsForCmt ~moduleName state.cmtCache changed cmt src + +let docsForModule modname ~package = + if Hashtbl.mem package.TopTypes.pathsForModule modname then ( + let paths = Hashtbl.find package.pathsForModule modname in + (* TODO: do better *) + let cmt = SharedTypes.getCmt paths in + let src = SharedTypes.getSrc paths in + Log.log ("FINDING docs for module " ^ SharedTypes.showPaths paths); + let open Infix in + Log.log ("FINDING " ^ cmt ^ " src " ^ (src |? "")); + match docsForCmt ~moduleName:modname cmt src TopTypes.state with + | None -> None + | Some docs -> Some (docs, src)) + else ( + Log.log ("No path for module " ^ modname); + None) + +let fileForModule ~package modname = + match docsForModule modname ~package with + | None -> None + | Some (file, _) -> Some file + +let rec resolvePath ~env ~path ~package = + match resolvePathInner ~env ~path with + | None -> None + | Some result -> ( + match result with + | `Local (env, name) -> Some (env, name) + | `Global (moduleName, fullPath) -> ( + match fileForModule ~package moduleName with + | None -> None + | Some file -> resolvePath ~env:(fileEnv file) ~path:fullPath ~package)) + +let tupleOfLexing {Lexing.pos_lnum; pos_cnum; pos_bol} = + (pos_lnum - 1, pos_cnum - pos_bol) + +let locationIsBefore {Location.loc_start} pos = tupleOfLexing loc_start <= pos + +let findInScope pos name stamps = + (* Log.log("Find " ++ name ++ " with " ++ string_of_int(Hashtbl.length(stamps)) ++ " stamps"); *) + Hashtbl.fold + (fun _stamp declared result -> + if declared.name.txt = name then + (* Log.log("a stamp " ++ Utils.showLocation(declared.scopeLoc) ++ " " ++ string_of_int(l) ++ "," ++ string_of_int(c)); *) + if locationIsBefore declared.scopeLoc pos then + match result with + | None -> Some declared + | Some current -> + if + current.name.loc.loc_start.pos_cnum + < declared.name.loc.loc_start.pos_cnum + then Some declared + else result + else result + else (* Log.log("wrong name " ++ declared.name.txt); *) + result) + stamps None + +let resolveFromStamps ~(env : queryEnv) ~path ~package ~pos = + match path with + | Tip name -> Some (env, name) + | Nested (name, inner) -> ( + (* Log.log("Finding from stamps " ++ name); *) + match findInScope pos name env.qFile.stamps.modules with + | None -> None + | Some declared -> ( + (* Log.log("found it"); *) + match findInModule ~env declared.item inner with + | None -> None + | Some res -> ( + match res with + | `Local (env, name) -> Some (env, name) + | `Global (moduleName, fullPath) -> ( + match fileForModule ~package moduleName with + | None -> None + | Some file -> resolvePath ~env:(fileEnv file) ~path:fullPath ~package + )))) + +let resolveModuleFromCompilerPath ~env ~package path = + match fromCompilerPath ~env path with + | `Global (moduleName, path) -> ( + match fileForModule ~package moduleName with + | None -> None + | Some file -> ( + let env = fileEnv file in + match resolvePath ~env ~package ~path with + | None -> None + | Some (env, name) -> ( + match Hashtbl.find_opt env.qExported.modules name with + | None -> None + | Some stamp -> ( + match Hashtbl.find_opt env.qFile.stamps.modules stamp with + | None -> None + | Some declared -> Some (env, Some declared))))) + | `Stamp stamp -> ( + match Hashtbl.find_opt env.qFile.stamps.modules stamp with + | None -> None + | Some declared -> Some (env, Some declared)) + | `GlobalMod moduleName -> ( + match fileForModule ~package moduleName with + | None -> None + | Some file -> + let env = fileEnv file in + Some (env, None)) + | `Not_found -> None + | `Exported (env, name) -> ( + match Hashtbl.find_opt env.qExported.modules name with + | None -> None + | Some stamp -> ( + match Hashtbl.find_opt env.qFile.stamps.modules stamp with + | None -> None + | Some declared -> Some (env, Some declared))) + +let resolveFromCompilerPath ~env ~package path = + match fromCompilerPath ~env path with + | `Global (moduleName, path) -> ( + let res = + match fileForModule ~package moduleName with + | None -> None + | Some file -> + let env = fileEnv file in + resolvePath ~env ~package ~path + in + match res with + | None -> `Not_found + | Some (env, name) -> `Exported (env, name)) + | `Stamp stamp -> `Stamp stamp + | `GlobalMod _ -> `Not_found + | `Not_found -> `Not_found + | `Exported (env, name) -> `Exported (env, name) + +let rec getSourceUri ~(env : queryEnv) ~package path = + match path with + | File (uri, _moduleName) -> uri + | NotVisible -> env.qFile.uri + | IncludedModule (path, inner) -> ( + Log.log "INCLUDED MODULE"; + match resolveModuleFromCompilerPath ~env ~package path with + | None -> + Log.log "NOT FOUND"; + getSourceUri ~env ~package inner + | Some (env, _declared) -> env.qFile.uri) + | ExportedModule (_, inner) -> getSourceUri ~env ~package inner + +let exportedForTip ~(env : queryEnv) name tip = + match tip with + | Value -> Hashtbl.find_opt env.qExported.values name + | Field _ | Constructor _ | Type -> Hashtbl.find_opt env.qExported.types name + | Module -> Hashtbl.find_opt env.qExported.modules name diff --git a/analysis/src/ProcessExtra.ml b/analysis/src/ProcessExtra.ml deleted file mode 100644 index f4ddfad71..000000000 --- a/analysis/src/ProcessExtra.ml +++ /dev/null @@ -1,544 +0,0 @@ -open Typedtree -open SharedTypes - -let handleConstructor path txt = - let typeName = - match path with - | Path.Pdot (_path, typename, _) -> typename - | Pident ident -> Ident.name ident - | _ -> assert false - in - let open Longident in - match txt with - | Longident.Lident name -> (name, Lident typeName) - | Ldot (left, name) -> (name, Ldot (left, typeName)) - | Lapply (_, _) -> assert false - -let rec relative ident path = - match (ident, path) with - | Longident.Lident name, Path.Pdot (path, pname, _) when pname = name -> - Some path - | Longident.Ldot (ident, name), Path.Pdot (path, pname, _) when pname = name - -> - relative ident path - (* | (Ldot(Lident("*predef*" | "exn"), _), Pident(_)) => None *) - | _ -> None - -let findClosestMatchingOpen opens path ident loc = - match relative ident path with - | None -> None - | Some openNeedle -> ( - let matching = - Hashtbl.fold - (fun _ op res -> - if Utils.locWithinLoc loc op.extent && Path.same op.path openNeedle - then op :: res - else res) - opens [] - |> List.sort (fun (a : SharedTypes.openTracker) b -> - b.loc.loc_start.pos_cnum - a.loc.loc_start.pos_cnum) - in - match matching with [] -> None | first :: _ -> Some first ) - -let getTypeAtPath ~env path = - match Query.fromCompilerPath ~env path with - | `GlobalMod _ -> `Not_found - | `Global (moduleName, path) -> `Global (moduleName, path) - | `Not_found -> `Not_found - | `Exported (env, name) -> ( - match Hashtbl.find_opt env.exported.types name with - | None -> `Not_found - | Some stamp -> ( - let declaredType = Hashtbl.find_opt env.file.stamps.types stamp in - match declaredType with - | Some declaredType -> `Local declaredType - | None -> `Not_found ) ) - | `Stamp stamp -> ( - let declaredType = Hashtbl.find_opt env.file.stamps.types stamp in - match declaredType with - | Some declaredType -> `Local declaredType - | None -> `Not_found ) - -module F (Collector : sig - val extra : extra - - val file : file - - val scopeExtent : Location.t list ref -end) = -struct - let extra = Collector.extra - - let maybeAddUse path ident loc tip = - match findClosestMatchingOpen extra.opens path ident loc with - | None -> () - | Some tracker -> ( - match Query.makeRelativePath tracker.path path with - | None -> () - | Some relpath -> tracker.used <- (relpath, tip, loc) :: tracker.used ) - - let addLocation loc ident = extra.locations <- (loc, ident) :: extra.locations - - let addReference stamp loc = - Hashtbl.replace extra.internalReferences stamp - ( loc - :: - ( match Hashtbl.mem extra.internalReferences stamp with - | true -> Hashtbl.find extra.internalReferences stamp - | false -> [] ) ) - - let addExternalReference moduleName path tip loc = - (* TODO need to follow the path, and be able to load the files to follow module references... *) - Hashtbl.replace extra.externalReferences moduleName - ( (path, tip, loc) - :: - ( match Hashtbl.mem extra.externalReferences moduleName with - | true -> Hashtbl.find extra.externalReferences moduleName - | false -> [] ) ) - - let env = Query.fileEnv Collector.file - - let getTypeAtPath = getTypeAtPath ~env - - let addForPath path lident loc typ tip = - maybeAddUse path lident loc tip; - let identName = Longident.last lident in - let identLoc = Utils.endOfLocation loc (String.length identName) in - let locType = - match Query.fromCompilerPath ~env path with - | `Stamp stamp -> - addReference stamp identLoc; - LocalReference (stamp, tip) - | `Not_found -> NotFound - | `Global (moduleName, path) -> - addExternalReference moduleName path tip identLoc; - GlobalReference (moduleName, path, tip) - | `Exported (env, name) -> ( - match - Hashtbl.find_opt - ( match tip = Type with - | true -> env.exported.types - | false -> env.exported.values ) - name - with - | Some stamp -> - addReference stamp identLoc; - LocalReference (stamp, tip) - | None -> NotFound ) - | `GlobalMod _ -> NotFound - in - addLocation loc (Typed (typ, locType)) - - let addForPathParent path loc = - let locType = - match Query.fromCompilerPath ~env path with - | `GlobalMod name -> - (* TODO track external references to filenames to handle renames well *) - TopLevelModule name - | `Stamp stamp -> - addReference stamp loc; - LModule (LocalReference (stamp, Module)) - | `Not_found -> LModule NotFound - | `Global (moduleName, path) -> - addExternalReference moduleName path Module loc; - LModule (GlobalReference (moduleName, path, Module)) - | `Exported (env, name) -> ( - match Hashtbl.find_opt env.exported.modules name with - | Some stamp -> - addReference stamp loc; - LModule (LocalReference (stamp, Module)) - | None -> LModule NotFound ) - in - addLocation loc locType - - let addForField recordType item {Asttypes.txt; loc} = - match (Shared.dig recordType).desc with - | Tconstr (path, _args, _memo) -> - let t = getTypeAtPath path in - let {Types.lbl_res} = item in - let name, typeLident = handleConstructor path txt in - maybeAddUse path typeLident loc (Field name); - let nameLoc = Utils.endOfLocation loc (String.length name) in - let locType = - match t with - | `Local {stamp; item = {kind = Record fields}} -> ( - match fields |> List.find_opt (fun f -> f.fname.txt = name) with - | Some {stamp = astamp} -> - addReference astamp nameLoc; - LocalReference (stamp, Field name) - | None -> NotFound ) - | `Global (moduleName, path) -> - addExternalReference moduleName path (Field name) nameLoc; - GlobalReference (moduleName, path, Field name) - | _ -> NotFound - in - addLocation nameLoc (Typed (lbl_res, locType)) - | _ -> () - - let addForRecord recordType items = - match (Shared.dig recordType).desc with - | Tconstr (path, _args, _memo) -> - let t = getTypeAtPath path in - items - |> List.iter (fun ({Asttypes.txt; loc}, {Types.lbl_res}, _) -> - (* let name = Longident.last(txt); *) - let name, typeLident = handleConstructor path txt in - maybeAddUse path typeLident loc (Field name); - let nameLoc = Utils.endOfLocation loc (String.length name) in - let locType = - match t with - | `Local {stamp; item = {kind = Record fields}} -> ( - match - fields |> List.find_opt (fun f -> f.fname.txt = name) - with - | Some {stamp = astamp} -> - addReference astamp nameLoc; - LocalReference (stamp, Field name) - | None -> NotFound ) - | `Global (moduleName, path) -> - addExternalReference moduleName path (Field name) nameLoc; - GlobalReference (moduleName, path, Field name) - | _ -> NotFound - in - addLocation nameLoc (Typed (lbl_res, locType))) - | _ -> () - - let addForConstructor constructorType {Asttypes.txt; loc} {Types.cstr_name} = - match (Shared.dig constructorType).desc with - | Tconstr (path, _args, _memo) -> - (* let name = Longident.last(txt); *) - let name, typeLident = handleConstructor path txt in - maybeAddUse path typeLident loc (Constructor name); - let nameLoc = Utils.endOfLocation loc (String.length name) in - let t = getTypeAtPath path in - let locType = - match t with - | `Local {stamp; item = {kind = Variant constructors}} -> ( - match - constructors |> List.find_opt (fun c -> c.cname.txt = cstr_name) - with - | Some {stamp = cstamp} -> - addReference cstamp nameLoc; - LocalReference (stamp, Constructor name) - | None -> NotFound ) - | `Global (moduleName, path) -> - addExternalReference moduleName path (Constructor name) nameLoc; - GlobalReference (moduleName, path, Constructor name) - | _ -> NotFound - in - addLocation nameLoc (Typed (constructorType, locType)) - | _ -> () - - let currentScopeExtent () = - if !Collector.scopeExtent = [] then Location.none - else List.hd !Collector.scopeExtent - - let addScopeExtent loc = - Collector.scopeExtent := loc :: !Collector.scopeExtent - - let popScopeExtent () = - if List.length !Collector.scopeExtent > 1 then - Collector.scopeExtent := List.tl !Collector.scopeExtent - - let rec addForLongident top (path : Path.t) (txt : Longident.t) loc = - if not loc.Location.loc_ghost then ( - let idLength = - String.length (String.concat "." (Longident.flatten txt)) - in - let reportedLength = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum in - let isPpx = idLength <> reportedLength in - if isPpx then - match top with - | Some (t, tip) -> addForPath path txt loc t tip - | None -> addForPathParent path loc - else - let l = Utils.endOfLocation loc (String.length (Longident.last txt)) in - ( match top with - | Some (t, tip) -> addForPath path txt l t tip - | None -> addForPathParent path l ); - match (path, txt) with - | Pdot (pinner, _pname, _), Ldot (inner, name) -> - addForLongident None pinner inner - (Utils.chopLocationEnd loc (String.length name + 1)) - | Pident _, Lident _ -> () - | _ -> () ) - - let rec handle_module_expr expr = - match expr with - | Tmod_constraint (expr, _, _, _) -> handle_module_expr expr.mod_desc - | Tmod_ident (path, {txt; loc}) -> - Log.log ("Ident!! " ^ String.concat "." (Longident.flatten txt)); - maybeAddUse path txt loc Module; - addForLongident None path txt loc - | Tmod_functor (_ident, _argName, _maybeType, resultExpr) -> - handle_module_expr resultExpr.mod_desc - | Tmod_apply (obj, arg, _) -> - handle_module_expr obj.mod_desc; - handle_module_expr arg.mod_desc - | _ -> () - - open Typedtree - include TypedtreeIter.DefaultIteratorArgument - - let enter_structure_item item = - match item.str_desc with - | Tstr_attribute - ( {Asttypes.txt = "ocaml.explanation"; loc}, - PStr - [ - { - pstr_desc = - Pstr_eval - ({pexp_desc = Pexp_constant (Pconst_string (doc, _))}, _); - }; - ] ) -> - addLocation loc (Explanation doc) - | Tstr_include {incl_mod = expr} -> handle_module_expr expr.mod_desc - | Tstr_module {mb_expr} -> handle_module_expr mb_expr.mod_desc - | Tstr_open {open_path; open_txt = {txt; loc}} -> - (* Log.log("Have an open here"); *) - maybeAddUse open_path txt loc Module; - let tracker = - { - path = open_path; - loc; - used = []; - extent = - { - loc_ghost = true; - loc_start = loc.loc_end; - loc_end = (currentScopeExtent ()).loc_end; - }; - } - in - addForLongident None open_path txt loc; - Hashtbl.replace Collector.extra.opens loc tracker - | _ -> () - - let enter_structure {str_items} = - if str_items <> [] then - let first = List.hd str_items in - let last = List.nth str_items (List.length str_items - 1) in - let extent = - { - Location.loc_ghost = true; - loc_start = first.str_loc.loc_start; - loc_end = last.str_loc.loc_end; - } - in - addScopeExtent extent - - let leave_structure str = if str.str_items <> [] then popScopeExtent () - - let enter_signature_item item = - match item.sig_desc with - | Tsig_value {val_id; val_loc; val_name = name; val_desc; val_attributes} -> - let stamp = Ident.binding_time val_id in - if not (Hashtbl.mem Collector.file.stamps.values stamp) then ( - let declared = - ProcessAttributes.newDeclared ~name ~stamp ~extent:val_loc - ~scope: - { - loc_ghost = true; - loc_start = val_loc.loc_end; - loc_end = (currentScopeExtent ()).loc_end; - } - ~modulePath:NotVisible - ~item:val_desc.ctyp_type false val_attributes - in - Hashtbl.add Collector.file.stamps.values stamp declared; - addReference stamp name.loc; - addLocation name.loc - (Typed (val_desc.ctyp_type, Definition (stamp, Value))) ) - | _ -> () - - let enter_core_type {ctyp_type; ctyp_desc} = - match ctyp_desc with - | Ttyp_constr (path, {txt; loc}, _args) -> - (* addForPath(path, txt, loc, Shared.makeFlexible(ctyp_type), Type) *) - addForLongident (Some (ctyp_type, Type)) path txt loc - | _ -> () - - let enter_pattern {pat_desc; pat_loc; pat_type; pat_attributes} = - let addForPattern stamp name = - if not (Hashtbl.mem Collector.file.stamps.values stamp) then ( - let declared = - ProcessAttributes.newDeclared ~name ~stamp - ~scope: - { - loc_ghost = true; - loc_start = pat_loc.loc_end; - loc_end = (currentScopeExtent ()).loc_end; - } - ~modulePath:NotVisible ~extent:pat_loc - ~item:pat_type false pat_attributes - in - Hashtbl.add Collector.file.stamps.values stamp declared; - addReference stamp name.loc; - addLocation name.loc (Typed (pat_type, Definition (stamp, Value))) ) - in - (* Log.log("Entering pattern " ++ Utils.showLocation(pat_loc)); *) - match pat_desc with - | Tpat_record (items, _) -> addForRecord pat_type items - | Tpat_construct (lident, constructor, _) -> - addForConstructor pat_type lident constructor - | Tpat_alias (_inner, ident, name) -> - let stamp = Ident.binding_time ident in - addForPattern stamp name - | Tpat_var (ident, name) -> - (* Log.log("Pattern " ++ name.txt); *) - let stamp = Ident.binding_time ident in - addForPattern stamp name - | _ -> () - - let enter_expression expression = - expression.exp_extra - |> List.iter (fun (e, eloc, _) -> - match e with - | Texp_open (_, path, _ident, _) -> - Hashtbl.add extra.opens eloc - {path; loc = eloc; extent = expression.exp_loc; used = []} - | _ -> ()); - match expression.exp_desc with - | Texp_ident (path, {txt; loc}, {val_type}) -> - addForLongident (Some (val_type, Value)) path txt loc - | Texp_record {fields} -> - addForRecord expression.exp_type - ( fields |> Array.to_list - |> Utils.filterMap (fun (desc, item) -> - match item with - | Overridden (loc, _) -> Some (loc, desc, ()) - | _ -> None) ) - | Texp_constant constant -> - addLocation expression.exp_loc (Constant constant) - (* Skip unit and list literals *) - | Texp_construct ({txt = Lident ("()" | "::"); loc}, _, _args) - when loc.loc_end.pos_cnum - loc.loc_start.pos_cnum <> 2 -> - () - | Texp_construct (lident, constructor, _args) -> - addForConstructor expression.exp_type lident constructor - | Texp_field (inner, lident, label_description) -> - addForField inner.exp_type label_description lident - | Texp_let (_, _, _) -> - (* TODO this scope tracking won't work for recursive *) - addScopeExtent expression.exp_loc - | Texp_function {cases} -> ( - match cases with [{c_rhs}] -> addScopeExtent c_rhs.exp_loc | _ -> () ) - | _ -> () - - let leave_expression expression = - match expression.exp_desc with - | Texp_let (_isrec, _bindings, _expr) -> popScopeExtent () - | Texp_function {cases} -> ( - match cases with [_] -> popScopeExtent () | _ -> () ) - | _ -> () -end - -let forFile ~file = - let extra = initExtra () in - let addLocation loc ident = - extra.locations <- (loc, ident) :: extra.locations - in - let addReference stamp loc = - Hashtbl.replace extra.internalReferences stamp - ( loc - :: - ( match Hashtbl.mem extra.internalReferences stamp with - | true -> Hashtbl.find extra.internalReferences stamp - | false -> [] ) ) - in - file.stamps.modules - |> Hashtbl.iter (fun stamp d -> - addLocation d.name.loc (LModule (Definition (stamp, Module))); - addReference stamp d.name.loc); - file.stamps.values - |> Hashtbl.iter (fun stamp d -> - addLocation d.name.loc (Typed (d.item, Definition (stamp, Value))); - addReference stamp d.name.loc); - file.stamps.types - |> Hashtbl.iter (fun stamp d -> - addLocation d.name.loc (TypeDefinition (d.name.txt, d.item.Type.decl, stamp)); - addReference stamp d.name.loc; - match d.item.Type.kind with - | Record labels -> - labels - |> List.iter (fun {stamp; fname; typ} -> - addReference stamp fname.loc; - addLocation fname.loc - (Typed (typ, Definition (d.stamp, Field fname.txt)))) - | Variant constructos -> - constructos - |> List.iter (fun {stamp; cname} -> - addReference stamp cname.loc; - let t = - { - Types.id = 0; - level = 0; - desc = - Tconstr - ( Path.Pident - {Ident.stamp; name = d.name.txt; flags = 0}, - [], - ref Types.Mnil ); - } - in - addLocation cname.loc - (Typed (t, Definition (d.stamp, Constructor cname.txt)))) - | _ -> ()); - extra - -let forItems ~file items parts = - let extra = forFile ~file in - let extent = ProcessCmt.itemsExtent items in - let extent = - { - extent with - loc_end = - { - extent.loc_end with - pos_lnum = extent.loc_end.pos_lnum + 1000000; - pos_cnum = extent.loc_end.pos_cnum + 100000000; - }; - } - in - (* TODO look through parts and extend the extent *) - let module Iter = TypedtreeIter.MakeIterator (F (struct - let scopeExtent = ref [extent] - - let extra = extra - - let file = file - end)) in - List.iter Iter.iter_structure_item items; - (* Log.log("Parts " ++ string_of_int(Array.length(parts))); *) - parts - |> Array.iter (fun part -> - match part with - | Cmt_format.Partial_signature str -> Iter.iter_signature str - | Partial_signature_item str -> Iter.iter_signature_item str - | Partial_expression expression -> Iter.iter_expression expression - | Partial_pattern pattern -> Iter.iter_pattern pattern - | Partial_class_expr class_expr -> Iter.iter_class_expr class_expr - | Partial_module_type module_type -> Iter.iter_module_type module_type - | Partial_structure _ | Partial_structure_item _ -> ()); - extra - -let forCmt ~file ({cmt_annots} : Cmt_format.cmt_infos) = - match cmt_annots with - | Partial_implementation parts -> - let items = - parts |> Array.to_list - |> Utils.filterMap (fun (p : Cmt_format.binary_part) -> - match p with - | Partial_structure str -> Some str.str_items - | Partial_structure_item str -> Some [str] - (* | Partial_expression(exp) => Some([ str]) *) - | _ -> None) - |> List.concat - in - forItems ~file items parts - | Implementation structure -> forItems ~file structure.str_items [||] - | Partial_interface _ | Interface _ -> - (** TODO actually process signature items *) - forItems ~file [] [||] - | _ -> forItems ~file [] [||] diff --git a/analysis/src/Process_406.ml b/analysis/src/Process_406.ml deleted file mode 100644 index 961dd0fc1..000000000 --- a/analysis/src/Process_406.ml +++ /dev/null @@ -1,14 +0,0 @@ -let fileForCmt ~moduleName ~uri cmt = - match Shared.tryReadCmt cmt with - | Error e -> Error e - | Ok infos -> Ok (ProcessCmt.forCmt ~moduleName ~uri infos) - -let fullForCmt ~moduleName ~uri cmt = - match Shared.tryReadCmt cmt with - | Error e -> Error e - | Ok infos -> - let file = ProcessCmt.forCmt ~moduleName ~uri infos in - let extra = ProcessExtra.forCmt ~file infos in - Ok {SharedTypes.file; extra} - -module PrintType = PrintType diff --git a/analysis/src/Process_406.mli b/analysis/src/Process_406.mli deleted file mode 100644 index 40522e531..000000000 --- a/analysis/src/Process_406.mli +++ /dev/null @@ -1,5 +0,0 @@ -val fileForCmt : - moduleName:string -> uri:Uri2.t -> string -> (SharedTypes.file, string) result - -val fullForCmt : - moduleName:string -> uri:Uri2.t -> string -> (SharedTypes.full, string) result diff --git a/analysis/src/Query.ml b/analysis/src/Query.ml deleted file mode 100644 index e3e4f7056..000000000 --- a/analysis/src/Query.ml +++ /dev/null @@ -1,245 +0,0 @@ -open SharedTypes - -type queryEnv = {file : file; exported : exported} - -let fileEnv file = {file; exported = file.contents.exported} - -let tupleOfLexing {Lexing.pos_lnum; pos_cnum; pos_bol} = - (pos_lnum - 1, pos_cnum - pos_bol) - -let locationIsBefore {Location.loc_start} pos = tupleOfLexing loc_start <= pos - -let findInScope pos name stamps = - (* Log.log("Find " ++ name ++ " with " ++ string_of_int(Hashtbl.length(stamps)) ++ " stamps"); *) - Hashtbl.fold - (fun _stamp declared result -> - if declared.name.txt = name then - (* Log.log("a stamp " ++ Utils.showLocation(declared.scopeLoc) ++ " " ++ string_of_int(l) ++ "," ++ string_of_int(c)); *) - if locationIsBefore declared.scopeLoc pos then - match result with - | None -> Some declared - | Some current -> - if - current.name.loc.loc_start.pos_cnum - < declared.name.loc.loc_start.pos_cnum - then Some declared - else result - else result - else - (* Log.log("wrong name " ++ declared.name.txt); *) - result - ) - stamps None - -let rec joinPaths modulePath path = - match modulePath with - | Path.Pident ident -> (ident.stamp, ident.name, path) - | Papply (fnPath, _argPath) -> joinPaths fnPath path - | Pdot (inner, name, _) -> joinPaths inner (Nested (name, path)) - -let rec makePath modulePath = - match modulePath with - | Path.Pident ident when ident.stamp == 0 -> `GlobalMod ident.name - | Pident ident -> `Stamp ident.stamp - | Papply (fnPath, _argPath) -> makePath fnPath - | Pdot (inner, name, _) -> `Path (joinPaths inner (Tip name)) - -let makeRelativePath basePath otherPath = - let rec loop base other tip = - if Path.same base other then Some tip - else - match other with - | Pdot (inner, name, _) -> loop basePath inner (Nested (name, tip)) - | _ -> None - in - match otherPath with - | Path.Pdot (inner, name, _) -> loop basePath inner (Tip name) - | _ -> None - -let rec resolvePathInner ~env ~path = - match path with - | Tip name -> Some (`Local (env, name)) - | Nested (subName, subPath) -> ( - match Hashtbl.find_opt env.exported.modules subName with - | None -> None - | Some stamp -> ( - match Hashtbl.find_opt env.file.stamps.modules stamp with - | None -> None - | Some {item = kind} -> findInModule ~env kind subPath ) ) - -and findInModule ~env kind path = - match kind with - | Structure {exported} -> resolvePathInner ~env:{env with exported} ~path - | Ident modulePath -> ( - let stamp, moduleName, fullPath = joinPaths modulePath path in - if stamp = 0 then Some (`Global (moduleName, fullPath)) - else - match Hashtbl.find_opt env.file.stamps.modules stamp with - | None -> None - | Some {item = kind} -> findInModule ~env kind fullPath ) - -(* let rec findSubModule = (~env, ~getModule) *) - -let rec resolvePath ~env ~path ~getModule = - match resolvePathInner ~env ~path with - | None -> None - | Some result -> ( - match result with - | `Local (env, name) -> Some (env, name) - | `Global (moduleName, fullPath) -> ( - match getModule moduleName with - | None -> None - | Some file -> resolvePath ~env:(fileEnv file) ~path:fullPath ~getModule ) - ) - -let resolveFromStamps ~env ~path ~getModule ~pos = - match path with - | Tip name -> Some (env, name) - | Nested (name, inner) -> ( - (* Log.log("Finding from stamps " ++ name); *) - match findInScope pos name env.file.stamps.modules with - | None -> None - | Some declared -> ( - (* Log.log("found it"); *) - match findInModule ~env declared.item inner with - | None -> None - | Some res -> ( - match res with - | `Local (env, name) -> Some (env, name) - | `Global (moduleName, fullPath) -> ( - match getModule moduleName with - | None -> None - | Some file -> - resolvePath ~env:(fileEnv file) ~path:fullPath ~getModule ) ) ) ) - -open Infix - -let fromCompilerPath ~env path = - match makePath path with - | `Stamp stamp -> `Stamp stamp - | `Path (0, moduleName, path) -> `Global (moduleName, path) - | `GlobalMod name -> `GlobalMod name - | `Path (stamp, _moduleName, path) -> ( - let res = - match Hashtbl.find_opt env.file.stamps.modules stamp with - | None -> None - | Some {item = kind} -> findInModule ~env kind path - in - match res with - | None -> `Not_found - | Some (`Local (env, name)) -> `Exported (env, name) - | Some (`Global (moduleName, fullPath)) -> `Global (moduleName, fullPath) ) - -let resolveModuleFromCompilerPath ~env ~getModule path = - match fromCompilerPath ~env path with - | `Global (moduleName, path) -> ( - match getModule moduleName with - | None -> None - | Some file -> ( - let env = fileEnv file in - match resolvePath ~env ~getModule ~path with - | None -> None - | Some (env, name) -> ( - match Hashtbl.find_opt env.exported.modules name with - | None -> None - | Some stamp -> ( - match Hashtbl.find_opt env.file.stamps.modules stamp with - | None -> None - | Some declared -> Some (env, Some declared) ) ) ) ) - | `Stamp stamp -> ( - match Hashtbl.find_opt env.file.stamps.modules stamp with - | None -> None - | Some declared -> Some (env, Some declared) ) - | `GlobalMod moduleName -> ( - match getModule moduleName with - | None -> None - | Some file -> - let env = fileEnv file in - Some (env, None) ) - | `Not_found -> None - | `Exported (env, name) -> ( - match Hashtbl.find_opt env.exported.modules name with - | None -> None - | Some stamp -> ( - match Hashtbl.find_opt env.file.stamps.modules stamp with - | None -> None - | Some declared -> Some (env, Some declared) ) ) - -let resolveFromCompilerPath ~env ~getModule path = - match fromCompilerPath ~env path with - | `Global (moduleName, path) -> ( - let res = - match getModule moduleName with - | None -> None - | Some file -> - let env = fileEnv file in - resolvePath ~env ~getModule ~path - in - match res with - | None -> `Not_found - | Some (env, name) -> `Exported (env, name) ) - | `Stamp stamp -> `Stamp stamp - | `GlobalMod _ -> `Not_found - | `Not_found -> `Not_found - | `Exported (env, name) -> `Exported (env, name) - -let declaredForExportedTip ~(stamps : stamps) ~(exported : exported) name tip = - match tip with - | Value -> - Hashtbl.find_opt exported.values name |?> fun stamp -> - Hashtbl.find_opt stamps.values stamp |?>> fun x -> {x with item = ()} - | Field _ | Constructor _ | Type -> - Hashtbl.find_opt exported.types name |?> fun stamp -> - Hashtbl.find_opt stamps.types stamp |?>> fun x -> {x with item = ()} - | Module -> - Hashtbl.find_opt exported.modules name |?> fun stamp -> - Hashtbl.find_opt stamps.modules stamp |?>> fun x -> {x with item = ()} - -let declaredForTip ~stamps stamp tip = - match tip with - | Value -> - Hashtbl.find_opt stamps.values stamp |?>> fun x -> {x with item = ()} - | Field _ | Constructor _ | Type -> - Hashtbl.find_opt stamps.types stamp |?>> fun x -> {x with item = ()} - | Module -> - Hashtbl.find_opt stamps.modules stamp |?>> fun x -> {x with item = ()} - -let getField file stamp name = - match Hashtbl.find_opt file.stamps.types stamp with - | None -> None - | Some {item = {kind}} -> ( - match kind with - | Record fields -> fields |> List.find_opt (fun f -> f.fname.txt = name) - | _ -> None ) - -let getConstructor file stamp name = - match Hashtbl.find_opt file.stamps.types stamp with - | None -> None - | Some {item = {kind}} -> ( - match kind with - | Variant constructors -> ( - match - constructors |> List.find_opt (fun const -> const.cname.txt = name) - with - | None -> None - | Some const -> Some const ) - | _ -> None ) - -let exportedForTip ~env name tip = - match tip with - | Value -> Hashtbl.find_opt env.exported.values name - | Field _ | Constructor _ | Type -> Hashtbl.find_opt env.exported.types name - | Module -> Hashtbl.find_opt env.exported.modules name - -let rec getSourceUri ~env ~getModule path = - match path with - | File (uri, _moduleName) -> uri - | NotVisible -> env.file.uri - | IncludedModule (path, inner) -> ( - Log.log "INCLUDED MODULE"; - match resolveModuleFromCompilerPath ~env ~getModule path with - | None -> - Log.log "NOT FOUND"; - getSourceUri ~env ~getModule inner - | Some (env, _declared) -> env.file.uri ) - | ExportedModule (_, inner) -> getSourceUri ~env ~getModule inner diff --git a/analysis/src/References.ml b/analysis/src/References.ml index 6df538dea..4bd7e7f24 100644 --- a/analysis/src/References.ml +++ b/analysis/src/References.ml @@ -61,22 +61,53 @@ let locForPos ~extra pos = | l :: _ -> Some l | _ -> None -let definedForLoc ~file ~getModule locKind = +let declaredForTip ~stamps stamp tip = + let open Infix in + match tip with + | Value -> + Hashtbl.find_opt stamps.values stamp |?>> fun x -> {x with item = ()} + | Field _ | Constructor _ | Type -> + Hashtbl.find_opt stamps.types stamp |?>> fun x -> {x with item = ()} + | Module -> + Hashtbl.find_opt stamps.modules stamp |?>> fun x -> {x with item = ()} + +let getField file stamp name = + match Hashtbl.find_opt file.stamps.types stamp with + | None -> None + | Some {item = {kind}} -> ( + match kind with + | Record fields -> fields |> List.find_opt (fun f -> f.fname.txt = name) + | _ -> None) + +let getConstructor file stamp name = + match Hashtbl.find_opt file.stamps.types stamp with + | None -> None + | Some {item = {kind}} -> ( + match kind with + | Variant constructors -> ( + match + constructors |> List.find_opt (fun const -> const.cname.txt = name) + with + | None -> None + | Some const -> Some const) + | _ -> None) + +let definedForLoc ~file ~package locKind = let inner ~file stamp tip = match tip with | Constructor name -> ( - match Query.getConstructor file stamp name with + match getConstructor file stamp name with | None -> None | Some constructor -> Some ([], `Constructor constructor)) | Field name -> ( - match Query.getField file stamp name with + match getField file stamp name with | None -> None | Some field -> Some ([], `Field field)) | _ -> ( maybeLog ("Trying for declared " ^ tipToString tip ^ " " ^ string_of_int stamp ^ " in file " ^ Uri2.toString file.uri); - match Query.declaredForTip ~stamps:file.stamps stamp tip with + match declaredForTip ~stamps:file.stamps stamp tip with | None -> None | Some declared -> Some (declared.docstring, `Declared)) in @@ -86,25 +117,25 @@ let definedForLoc ~file ~getModule locKind = inner ~file stamp tip | GlobalReference (moduleName, path, tip) -> ( maybeLog ("Getting global " ^ moduleName); - match getModule moduleName with + match ProcessCmt.fileForModule ~package moduleName with | None -> Log.log ("Cannot get module " ^ moduleName); None | Some file -> ( - let env = Query.fileEnv file in - match Query.resolvePath ~env ~path ~getModule with + let env = ProcessCmt.fileEnv file in + match ProcessCmt.resolvePath ~env ~path ~package with | None -> Log.log ("Cannot resolve path " ^ pathToString path); None | Some (env, name) -> ( - match Query.exportedForTip ~env name tip with + match ProcessCmt.exportedForTip ~env name tip with | None -> Log.log ("Exported not found for tip " ^ name ^ " > " ^ tipToString tip); None | Some stamp -> ( maybeLog ("Getting for " ^ string_of_int stamp ^ " in " ^ name); - match inner ~file:env.file stamp tip with + match inner ~file:env.qFile stamp tip with | None -> Log.log "could not get defined"; None @@ -112,8 +143,21 @@ let definedForLoc ~file ~getModule locKind = maybeLog "Yes!! got it"; Some res)))) -let alternateDeclared ~file ~pathsForModule ~getUri declared tip = - match Hashtbl.find_opt pathsForModule file.moduleName with +let declaredForExportedTip ~(stamps : stamps) ~(exported : exported) name tip = + let open Infix in + match tip with + | Value -> + Hashtbl.find_opt exported.values name |?> fun stamp -> + Hashtbl.find_opt stamps.values stamp |?>> fun x -> {x with item = ()} + | Field _ | Constructor _ | Type -> + Hashtbl.find_opt exported.types name |?> fun stamp -> + Hashtbl.find_opt stamps.types stamp |?>> fun x -> {x with item = ()} + | Module -> + Hashtbl.find_opt exported.modules name |?> fun stamp -> + Hashtbl.find_opt stamps.modules stamp |?>> fun x -> {x with item = ()} + +let alternateDeclared ~file ~package declared tip = + match Hashtbl.find_opt package.TopTypes.pathsForModule file.moduleName with | None -> None | Some paths -> ( maybeLog ("paths for " ^ file.moduleName); @@ -123,62 +167,62 @@ let alternateDeclared ~file ~pathsForModule ~getUri declared tip = let intfUri = Uri2.fromPath intf in let implUri = Uri2.fromPath impl in if intfUri = file.uri then - match getUri implUri with + match ProcessCmt.fileForUri implUri with | Error e -> Log.log e; None | Ok (file, extra) -> ( match - Query.declaredForExportedTip ~stamps:file.stamps + declaredForExportedTip ~stamps:file.stamps ~exported:file.contents.exported declared.name.txt tip with | None -> None | Some declared -> Some (file, extra, declared)) else - match getUri intfUri with + match ProcessCmt.fileForUri intfUri with | Error e -> Log.log e; None | Ok (file, extra) -> ( match - Query.declaredForExportedTip ~stamps:file.stamps + declaredForExportedTip ~stamps:file.stamps ~exported:file.contents.exported declared.name.txt tip with | None -> None | Some declared -> Some (file, extra, declared))) | _ -> None) -let resolveModuleReference ~file ~getModule (declared : moduleKind declared) = +let resolveModuleReference ~file ~package (declared : moduleKind declared) = match declared.item with | Structure _ -> Some (file, Some declared) | Ident path -> ( - let env = Query.fileEnv file in - match Query.fromCompilerPath ~env path with + let env = ProcessCmt.fileEnv file in + match ProcessCmt.fromCompilerPath ~env path with | `Not_found -> None | `Exported (env, name) -> ( - match Hashtbl.find_opt env.exported.modules name with + match Hashtbl.find_opt env.qExported.modules name with | None -> None | Some stamp -> ( - match Hashtbl.find_opt env.file.stamps.modules stamp with + match Hashtbl.find_opt env.qFile.stamps.modules stamp with | None -> None | Some md -> - Some (env.file, Some md) + Some (env.qFile, Some md) (* Some((env.file.uri, validateLoc(md.name.loc, md.extentLoc))) *))) | `Global (moduleName, path) -> ( - match getModule moduleName with + match ProcessCmt.fileForModule ~package moduleName with | None -> None | Some file -> ( - let env = Query.fileEnv file in - match Query.resolvePath ~env ~getModule ~path with + let env = ProcessCmt.fileEnv file in + match ProcessCmt.resolvePath ~env ~package ~path with | None -> None | Some (env, name) -> ( - match Hashtbl.find_opt env.exported.modules name with + match Hashtbl.find_opt env.qExported.modules name with | None -> None | Some stamp -> ( - match Hashtbl.find_opt env.file.stamps.modules stamp with + match Hashtbl.find_opt env.qFile.stamps.modules stamp with | None -> None | Some md -> - Some (env.file, Some md) + Some (env.qFile, Some md) (* Some((env.file.uri, validateLoc(md.name.loc, md.extentLoc))) *) )))) | `Stamp stamp -> ( @@ -188,7 +232,7 @@ let resolveModuleReference ~file ~getModule (declared : moduleKind declared) = Some (file, Some md) (* Some((file.uri, validateLoc(md.name.loc, md.extentLoc))) *)) | `GlobalMod name -> ( - match getModule name with + match ProcessCmt.fileForModule ~package name with | None -> None | Some file -> (* maybeLog("Congrats, found a global mod"); *) @@ -206,11 +250,11 @@ let validateLoc (loc : Location.t) (backup : Location.t) = else backup else loc -let resolveModuleDefinition ~file ~getModule stamp = +let resolveModuleDefinition ~file ~package stamp = match Hashtbl.find_opt file.stamps.modules stamp with | None -> None | Some md -> ( - match resolveModuleReference ~file ~getModule md with + match resolveModuleReference ~file ~package md with | None -> None | Some (file, declared) -> let loc = @@ -220,24 +264,24 @@ let resolveModuleDefinition ~file ~getModule stamp = in Some (file.uri, loc)) -let definition ~file ~getModule stamp tip = +let definition ~file ~package stamp tip = match tip with | Constructor name -> ( - match Query.getConstructor file stamp name with + match getConstructor file stamp name with | None -> None | Some constructor -> Some (file.uri, constructor.cname.loc)) | Field name -> ( - match Query.getField file stamp name with + match getField file stamp name with | None -> None | Some field -> Some (file.uri, field.fname.loc)) - | Module -> resolveModuleDefinition ~file ~getModule stamp + | Module -> resolveModuleDefinition ~file ~package stamp | _ -> ( - match Query.declaredForTip ~stamps:file.stamps stamp tip with + match declaredForTip ~stamps:file.stamps stamp tip with | None -> None | Some declared -> let loc = validateLoc declared.name.loc declared.extentLoc in - let env = Query.fileEnv file in - let uri = Query.getSourceUri ~env ~getModule declared.modulePath in + let env = ProcessCmt.fileEnv file in + let uri = ProcessCmt.getSourceUri ~env ~package declared.modulePath in maybeLog ("Inner uri " ^ Uri2.toString uri); Some (uri, loc)) @@ -248,17 +292,17 @@ let orLog message v = None | _ -> v -let definitionForLoc ~pathsForModule ~file ~getUri ~getModule loc = +let definitionForLoc ~package ~file loc = match loc with | Typed (_, Definition (stamp, tip)) -> ( maybeLog "Trying to find a defintion for a definition"; - match Query.declaredForTip ~stamps:file.stamps stamp tip with + match declaredForTip ~stamps:file.stamps stamp tip with | None -> None | Some declared -> maybeLog "Declared"; if declared.exported then ( maybeLog ("exported, looking for alternate " ^ file.moduleName); - match alternateDeclared ~pathsForModule ~file ~getUri declared tip with + match alternateDeclared ~package ~file declared tip with | None -> None | Some (file, _extra, declared) -> let loc = validateLoc declared.name.loc declared.extentLoc in @@ -274,7 +318,7 @@ let definitionForLoc ~pathsForModule ~file ~getUri ~getModule loc = maybeLog ("Toplevel " ^ name); let open Infix in match - Hashtbl.find_opt pathsForModule name + Hashtbl.find_opt package.pathsForModule name |> orLog "No paths found" |?> getSrc |> orLog "No src found" with | None -> None @@ -282,25 +326,25 @@ let definitionForLoc ~pathsForModule ~file ~getUri ~getModule loc = | LModule (LocalReference (stamp, tip)) | Typed (_, LocalReference (stamp, tip)) -> maybeLog ("Local defn " ^ tipToString tip); - definition ~file ~getModule stamp tip + definition ~file ~package stamp tip | LModule (GlobalReference (moduleName, path, tip)) | Typed (_, GlobalReference (moduleName, path, tip)) -> ( maybeLog ("Global defn " ^ moduleName ^ " " ^ pathToString path ^ " : " ^ tipToString tip); - match getModule moduleName with + match ProcessCmt.fileForModule ~package moduleName with | None -> None | Some file -> ( - let env = Query.fileEnv file in - match Query.resolvePath ~env ~path ~getModule with + let env = ProcessCmt.fileEnv file in + match ProcessCmt.resolvePath ~env ~path ~package with | None -> None | Some (env, name) -> ( - match Query.exportedForTip ~env name tip with + match ProcessCmt.exportedForTip ~env name tip with | None -> None | Some stamp -> (* oooh wht do I do if the stamp is inside a pseudo-file? *) maybeLog ("Got stamp " ^ string_of_int stamp); - definition ~file:env.file ~getModule stamp tip))) + definition ~file:env.qFile ~package stamp tip))) let isVisible (declared : _ SharedTypes.declared) = declared.exported @@ -325,15 +369,13 @@ let rec pathFromVisibility visibilityPath current = let pathFromVisibility visibilityPath tipName = pathFromVisibility visibilityPath (Tip tipName) -let forLocalStamp ~pathsForModule ~file ~extra ~allModules ~getModule ~getUri - ~getExtra stamp tip = - let env = Query.fileEnv file in +let forLocalStamp ~package ~file ~extra stamp tip = + let env = ProcessCmt.fileEnv file in let open Infix in match match tip with - | Constructor name -> - Query.getConstructor file stamp name |?>> fun x -> x.stamp - | Field name -> Query.getField file stamp name |?>> fun x -> x.stamp + | Constructor name -> getConstructor file stamp name |?>> fun x -> x.stamp + | Field name -> getField file stamp name |?>> fun x -> x.stamp | _ -> Some stamp with | None -> [] @@ -343,22 +385,19 @@ let forLocalStamp ~pathsForModule ~file ~extra ~allModules ~getModule ~getUri | Some local -> maybeLog ("Checking externals: " ^ string_of_int stamp); let externals = - match Query.declaredForTip ~stamps:env.file.stamps stamp tip with + match declaredForTip ~stamps:env.qFile.stamps stamp tip with | None -> [] | Some declared -> if isVisible declared then ( let alternativeReferences = - match - alternateDeclared ~pathsForModule ~file ~getUri declared tip - with + match alternateDeclared ~package ~file declared tip with | None -> [] | Some (file, extra, {stamp}) -> ( match match tip with | Constructor name -> - Query.getConstructor file stamp name |?>> fun x -> x.stamp - | Field name -> - Query.getField file stamp name |?>> fun x -> x.stamp + getConstructor file stamp name |?>> fun x -> x.stamp + | Field name -> getField file stamp name |?>> fun x -> x.stamp | _ -> Some stamp with | None -> [] @@ -377,13 +416,13 @@ let forLocalStamp ~pathsForModule ~file ~extra ~allModules ~getModule ~getUri maybeLog ("Now checking path " ^ pathToString path); let thisModuleName = file.moduleName in let externals = - allModules + package.localModules |> List.filter (fun name -> name <> file.moduleName) |> Utils.filterMap (fun name -> - match getModule name with + match ProcessCmt.fileForModule ~package name with | None -> None | Some file -> ( - match getExtra name with + match ProcessCmt.extraForModule ~package name with | None -> None | Some extra -> ( match @@ -408,8 +447,7 @@ let forLocalStamp ~pathsForModule ~file ~extra ~allModules ~getModule ~getUri in (file.uri, local) :: externals) -let allReferencesForLoc ~pathsForModule ~getUri ~file ~extra ~allModules - ~getModule ~getExtra loc = +let allReferencesForLoc ~package ~file ~extra loc = match loc with | Explanation _ | Typed (_, NotFound) @@ -417,33 +455,31 @@ let allReferencesForLoc ~pathsForModule ~getUri ~file ~extra ~allModules | TopLevelModule _ | Constant _ -> [] | TypeDefinition (_, _, stamp) -> - forLocalStamp ~pathsForModule ~getUri ~file ~extra ~allModules ~getModule - ~getExtra stamp Type + forLocalStamp ~package ~file ~extra stamp Type | Typed (_, (LocalReference (stamp, tip) | Definition (stamp, tip))) | LModule (LocalReference (stamp, tip) | Definition (stamp, tip)) -> maybeLog ("Finding references for " ^ Uri2.toString file.uri ^ " and stamp " ^ string_of_int stamp ^ " and tip " ^ tipToString tip); - forLocalStamp ~pathsForModule ~getUri ~file ~extra ~allModules ~getModule - ~getExtra stamp tip + forLocalStamp ~package ~file ~extra stamp tip | LModule (GlobalReference (moduleName, path, tip)) | Typed (_, GlobalReference (moduleName, path, tip)) -> ( - match getModule moduleName with + match ProcessCmt.fileForModule ~package moduleName with | None -> [] | Some file -> ( - let env = Query.fileEnv file in - match Query.resolvePath ~env ~path ~getModule with + let env = ProcessCmt.fileEnv file in + match ProcessCmt.resolvePath ~env ~path ~package with | None -> [] | Some (env, name) -> ( - match Query.exportedForTip ~env name tip with + match ProcessCmt.exportedForTip ~env name tip with | None -> [] | Some stamp -> ( - match getUri env.file.uri with + match ProcessCmt.fileForUri env.qFile.uri with | Error _ -> [] | Ok (file, extra) -> maybeLog - ("Finding references for (global) " ^ Uri2.toString env.file.uri - ^ " and stamp " ^ string_of_int stamp ^ " and tip " - ^ tipToString tip); - forLocalStamp ~pathsForModule ~getUri ~file ~extra ~allModules - ~getModule ~getExtra stamp tip)))) + ("Finding references for (global) " + ^ Uri2.toString env.qFile.uri + ^ " and stamp " ^ string_of_int stamp ^ " and tip " + ^ tipToString tip); + forLocalStamp ~package ~file ~extra stamp tip)))) diff --git a/analysis/src/State.ml b/analysis/src/State.ml deleted file mode 100644 index 049ab1fb1..000000000 --- a/analysis/src/State.ml +++ /dev/null @@ -1,88 +0,0 @@ -let newDocsForCmt ~moduleName cmtCache changed cmt src = - let open Infix in - let uri = Uri2.fromPath (src |? cmt) in - match Process_406.fileForCmt ~moduleName ~uri cmt with - | Error e -> - Log.log e; - None - | Ok file -> - Hashtbl.replace cmtCache cmt (changed, file); - Some file - -let docsForCmt ~moduleName cmt src state = - if Hashtbl.mem state.TopTypes.cmtCache cmt then - let mtime, docs = Hashtbl.find state.cmtCache cmt in - (* TODO: I should really throttle this mtime checking to like every 50 ms or so *) - match Files.getMtime cmt with - | None -> - Log.log - ("\226\154\160\239\184\143 cannot get docs for nonexistant cmt " ^ cmt); - None - | Some changed -> - if changed > mtime then - newDocsForCmt ~moduleName state.cmtCache changed cmt src - else Some docs - else - match Files.getMtime cmt with - | None -> - Log.log - ("\226\154\160\239\184\143 cannot get docs for nonexistant cmt " ^ cmt); - None - | Some changed -> newDocsForCmt ~moduleName state.cmtCache changed cmt src - -open Infix - -let getFullFromCmt ~state ~uri = - let path = Uri2.toPath uri in - match Packages.getPackage uri state with - | Error e -> Error e - | Ok package -> ( - let moduleName = - BuildSystem.namespacedName package.namespace (FindFiles.getName path) - in - match Hashtbl.find_opt package.pathsForModule moduleName with - | Some paths -> ( - let cmt = SharedTypes.getCmt ~interface:(Utils.endsWith path "i") paths in - match Process_406.fullForCmt ~moduleName ~uri cmt with - | Error e -> Error e - | Ok full -> - Hashtbl.replace package.interModuleDependencies moduleName - (SharedTypes.hashList full.extra.externalReferences |> List.map fst); - Ok (package, full)) - | None -> Error ("can't find module " ^ moduleName)) - -let docsForModule modname state ~package = - if Hashtbl.mem package.TopTypes.pathsForModule modname then ( - let paths = Hashtbl.find package.pathsForModule modname in - (* TODO: do better *) - let cmt = SharedTypes.getCmt paths in - let src = SharedTypes.getSrc paths in - Log.log ("FINDING docs for module " ^ SharedTypes.showPaths paths); - Log.log ("FINDING " ^ cmt ^ " src " ^ (src |? "")); - match docsForCmt ~moduleName:modname cmt src state with - | None -> None - | Some docs -> Some (docs, src)) - else ( - Log.log ("No path for module " ^ modname); - None) - -let fileForUri state uri = - match getFullFromCmt ~state ~uri with - | Error e -> Error e - | Ok (_package, {extra; file}) -> Ok (file, extra) - -let fileForModule state ~package modname = - match docsForModule modname state ~package with - | None -> None - | Some (file, _) -> Some file - -let extraForModule state ~package modname = - if Hashtbl.mem package.TopTypes.pathsForModule modname then - let paths = Hashtbl.find package.pathsForModule modname in - match SharedTypes.getSrc paths with - | None -> None - | Some src -> ( - match getFullFromCmt ~state ~uri:(Uri2.fromPath src) with - | Ok (_package, {extra}) -> Some extra - | Error _ -> None) - else None diff --git a/analysis/src/TopTypes.ml b/analysis/src/TopTypes.ml index 1f200514f..3854311b9 100644 --- a/analysis/src/TopTypes.ml +++ b/analysis/src/TopTypes.ml @@ -23,9 +23,11 @@ type state = { cmtCache : (filePath, float * SharedTypes.file) Hashtbl.t; } -let empty () = +(* There's only one state, so it can as well be global *) +let state = { packagesByRoot = Hashtbl.create 1; rootForUri = Hashtbl.create 30; cmtCache = Hashtbl.create 30; } + diff --git a/analysis/src/Uri2.ml b/analysis/src/Uri2.ml index e90558d29..28535da0f 100644 --- a/analysis/src/Uri2.ml +++ b/analysis/src/Uri2.ml @@ -1,6 +1,8 @@ module Uri : sig type t + val fromLocalPath : string -> t + val fromPath : string -> t val stripPath : bool ref @@ -17,13 +19,17 @@ end = struct if Sys.os_type = "Unix" then "file://" ^ path else "file://" - ^ ( Str.global_replace (Str.regexp_string "\\") "/" path + ^ (Str.global_replace (Str.regexp_string "\\") "/" path |> Str.substitute_first (Str.regexp "^\\([a-zA-Z]\\):") (fun text -> let name = Str.matched_group 1 text in - "/" ^ String.lowercase_ascii name ^ "%3A") ) + "/" ^ String.lowercase_ascii name ^ "%3A")) let fromPath path = {path; uri = pathToUri path} + let fromLocalPath localPath = + let path = Files.maybeConcat (Unix.getcwd ()) localPath in + fromPath path + let toPath {path} = path let toString {uri} = if !stripPath then Filename.basename uri else uri