diff --git a/src/BuildSystem.ml b/src/BuildSystem.ml new file mode 100644 index 00000000..e94a2ce7 --- /dev/null +++ b/src/BuildSystem.ml @@ -0,0 +1,29 @@ +let namespacedName namespace name = + match namespace with + | None -> name + | Some namespace -> name ^ "-" ^ namespace + +open Infix + +let getBsPlatformDir rootPath = + let result = + ModuleResolution.resolveNodeModulePath ~startPath:rootPath "bs-platform" + in + let result = + if result = None then + ModuleResolution.resolveNodeModulePath ~startPath:rootPath "rescript" + else result + in + match result with + | Some path -> Ok path + | None -> + let message = "bs-platform could not be found" in + Log.log message; + Error message + +let getCompiledBase root = Files.ifExists (root /+ "lib" /+ "bs") + +let getStdlib base = + match getBsPlatformDir base with + | Error e -> Error e + | Ok bsPlatformDir -> Ok (bsPlatformDir /+ "lib" /+ "ocaml") diff --git a/src/BuildSystem.re b/src/BuildSystem.re deleted file mode 100644 index 3e768d62..00000000 --- a/src/BuildSystem.re +++ /dev/null @@ -1,37 +0,0 @@ -let namespacedName = (namespace, name) => - switch (namespace) { - | None => name - | Some(namespace) => name ++ "-" ++ namespace - }; - -open Infix; - -let getBsPlatformDir = rootPath => { - let result = - ModuleResolution.resolveNodeModulePath( - ~startPath=rootPath, - "bs-platform", - ); - let result = - if (result == None) { - ModuleResolution.resolveNodeModulePath(~startPath=rootPath, "rescript"); - } else { - result; - }; - switch (result) { - | Some(path) => Ok(path) - | None => - let message = "bs-platform could not be found"; - Log.log(message); - Error(message); - }; -}; - -let getCompiledBase = root => { - Files.ifExists(root /+ "lib" /+ "bs"); -}; -let getStdlib = base => - switch (getBsPlatformDir(base)) { - | Error(e) => Error(e) - | Ok(bsPlatformDir) => Ok(bsPlatformDir /+ "lib" /+ "ocaml") - }; diff --git a/src/EditorSupportCommands.ml b/src/EditorSupportCommands.ml new file mode 100644 index 00000000..ccc1e393 --- /dev/null +++ b/src/EditorSupportCommands.ml @@ -0,0 +1,136 @@ +module J = JsonShort + +let dumpLocations state ~package ~file ~extra ~selectPos uri = + let locations = + extra.SharedTypes.locations + |> List.filter (fun (l, _) -> not l.Location.loc_ghost) + in + let locations = + match selectPos with + | Some pos -> ( + let pos = Utils.cmtLocFromVscode pos in + match References.locForPos ~extra:{extra with locations} pos with + | None -> [] + | Some l -> [l] ) + | None -> locations + in + let dedupTable = Hashtbl.create 1 in + let dedupHover hover i = + let isCandidate = String.length hover > 10 in + if isCandidate then ( + match Hashtbl.find_opt dedupTable hover with + | Some n -> J.s ("#" ^ string_of_int n) + | None -> + Hashtbl.replace dedupTable hover i; + J.s hover ) + else J.s hover + in + let locationsInfo = + locations + |> Utils.filterMapIndex (fun i ((location : Location.t), loc) -> + let locIsModule = + match loc with + | SharedTypes.LModule _ | TopLevelModule _ -> true + | TypeDefinition _ | Typed _ | Constant _ | Explanation _ -> false + in + let hoverText = + Hover.newHover ~file + ~getModule:(State.fileForModule state ~package) + loc + in + let hover = + match hoverText with + | None -> [] + | Some s -> [("hover", dedupHover s i)] + in + let uriLocOpt = + References.definitionForLoc ~pathsForModule:package.pathsForModule + ~file ~getUri:(State.fileForUri state) + ~getModule:(State.fileForModule state ~package) + loc + in + let def, skipZero = + match uriLocOpt with + | None -> ([], false) + | Some (uri2, loc) -> + let uriIsCurrentFile = uri = uri2 in + let posIsZero {Lexing.pos_lnum; pos_bol; pos_cnum} = + pos_lnum = 1 && pos_cnum - pos_bol = 0 + in + (* Skip if range is all zero, unless it's a module *) + let skipZero = + (not locIsModule) && loc.loc_start |> posIsZero + && loc.loc_end |> posIsZero + in + let range = ("range", Protocol.rangeOfLoc loc) in + ( + [ + ("definition", + J.o + (match uriIsCurrentFile with + | true -> [range] + | false -> [("uri", Json.String (Uri2.toString uri2)); range]) + ) + ], + skipZero + ) + in + let skip = skipZero || (hover = [] && def = []) in + match skip with + | true -> None + | false -> Some (J.o ([("range", Protocol.rangeOfLoc location)] @ hover @ def))) + |> J.l + in + Json.stringify locationsInfo + +(* Split (line,char) from filepath:line:char *) +let splitLineChar pathWithPos = + let mkPos line char = Some (line |> int_of_string, char |> int_of_string) in + match pathWithPos |> String.split_on_char ':' with + | [filePath; line; char] -> (filePath, mkPos line char) + | [drive; rest; line; char] -> + (* c:\... on Windows *) + (drive ^ ":" ^ rest, mkPos line char) + | _ -> (pathWithPos, None) + +let dump files = + Shared.cacheTypeToString := true; + let state = TopTypes.empty () in + files + |> List.iter (fun pathWithPos -> + let filePath, selectPos = pathWithPos |> splitLineChar in + let filePath = Files.maybeConcat (Unix.getcwd ()) filePath in + let uri = Uri2.fromPath filePath in + let result = + match State.getFullFromCmt ~state ~uri with + | Error message -> + prerr_endline message; + "[]" + | Ok (package, {file; extra}) -> + dumpLocations state ~package ~file ~extra ~selectPos uri + in + print_endline result) + +let autocomplete ~currentFile ~full ~package ~pos ~state = + let maybeText = Files.readFile currentFile in + let completions = + NewCompletions.computeCompletions ~full ~maybeText ~package ~pos ~state + in + Json.stringify completions + +let complete ~pathWithPos ~currentFile = + let state = TopTypes.empty () in + match pathWithPos |> splitLineChar with + | filePath, Some pos -> + let filePath = Files.maybeConcat (Unix.getcwd ()) filePath in + let uri = Uri2.fromPath filePath in + let result = + match State.getFullFromCmt ~state ~uri with + | Error message -> + prerr_endline message; + "[]" + | Ok (package, full) -> + autocomplete ~currentFile ~full ~package ~pos ~state + in + print_endline result + | _ -> () diff --git a/src/EditorSupportCommands.re b/src/EditorSupportCommands.re deleted file mode 100644 index deda143e..00000000 --- a/src/EditorSupportCommands.re +++ /dev/null @@ -1,171 +0,0 @@ -module J = JsonShort; - -let dumpLocations = (state, ~package, ~file, ~extra, ~selectPos, uri) => { - let locations = - extra.SharedTypes.locations - |> List.filter(((l, _)) => !l.Location.loc_ghost); - let locations = { - switch (selectPos) { - | Some(pos) => - let pos = Utils.cmtLocFromVscode(pos); - switch (References.locForPos(~extra={...extra, locations}, pos)) { - | None => [] - | Some(l) => [l] - }; - | None => locations - }; - }; - let dedupTable = Hashtbl.create(1); - let dedupHover = (hover, i) => { - let isCandidate = String.length(hover) > 10; - if (isCandidate) { - switch (Hashtbl.find_opt(dedupTable, hover)) { - | Some(n) => J.s("#" ++ string_of_int(n)) - | None => - Hashtbl.replace(dedupTable, hover, i); - J.s(hover); - }; - } else { - J.s(hover); - }; - }; - let locationsInfo = - locations - |> Utils.filterMapIndex((i, (location: Location.t, loc)) => { - let locIsModule = - switch (loc) { - | SharedTypes.LModule(_) - | TopLevelModule(_) => true - | TypeDefinition(_) - | Typed(_) - | Constant(_) - | Explanation(_) => false - }; - - let hoverText = - Hover.newHover( - ~file, - ~getModule=State.fileForModule(state, ~package), - loc, - ); - let hover = - switch (hoverText) { - | None => [] - | Some(s) => [("hover", dedupHover(s, i))] - }; - - let uriLocOpt = - References.definitionForLoc( - ~pathsForModule=package.pathsForModule, - ~file, - ~getUri=State.fileForUri(state), - ~getModule=State.fileForModule(state, ~package), - loc, - ); - let (def, skipZero) = - switch (uriLocOpt) { - | None => ([], false) - | Some((uri2, loc)) => - let uriIsCurrentFile = uri == uri2; - let posIsZero = ({Lexing.pos_lnum, pos_bol, pos_cnum}) => - pos_lnum == 1 && pos_cnum - pos_bol == 0; - // Skip if range is all zero, unless it's a module - let skipZero = - !locIsModule - && loc.loc_start - |> posIsZero - && loc.loc_end - |> posIsZero; - let range = ("range", Protocol.rangeOfLoc(loc)); - ( - [ - ( - "definition", - J.o( - uriIsCurrentFile - ? [range] - : [("uri", Json.String(Uri2.toString(uri2))), range], - ), - ), - ], - skipZero, - ); - }; - let skip = skipZero || hover == [] && def == []; - skip - ? None - : Some( - J.o( - [("range", Protocol.rangeOfLoc(location))] @ hover @ def, - ), - ); - }) - |> J.l; - - Json.stringify(locationsInfo); -}; - -// Split (line,char) from filepath:line:char -let splitLineChar = pathWithPos => { - let mkPos = (line, char) => - Some((line |> int_of_string, char |> int_of_string)); - switch (pathWithPos |> String.split_on_char(':')) { - | [filePath, line, char] => (filePath, mkPos(line, char)) - | [drive, rest, line, char] => - // c:\... on Windows - (drive ++ ":" ++ rest, mkPos(line, char)) - | _ => (pathWithPos, None) - }; -}; - -let dump = files => { - Shared.cacheTypeToString := true; - let state = TopTypes.empty(); - files - |> List.iter(pathWithPos => { - let (filePath, selectPos) = pathWithPos |> splitLineChar; - let filePath = Files.maybeConcat(Unix.getcwd(), filePath); - let uri = Uri2.fromPath(filePath); - let result = - switch (State.getFullFromCmt(~state, ~uri)) { - | Error(message) => - prerr_endline(message); - "[]"; - | Ok((package, {file, extra})) => - dumpLocations(state, ~package, ~file, ~extra, ~selectPos, uri) - }; - print_endline(result); - }); -}; - -let autocomplete = (~currentFile, ~full, ~package, ~pos, ~state) => { - let maybeText = Files.readFile(currentFile); - let completions = - NewCompletions.computeCompletions( - ~full, - ~maybeText, - ~package, - ~pos, - ~state, - ); - Json.stringify(completions); -}; - -let complete = (~pathWithPos, ~currentFile) => { - let state = TopTypes.empty(); - switch (pathWithPos |> splitLineChar) { - | (filePath, Some(pos)) => - let filePath = Files.maybeConcat(Unix.getcwd(), filePath); - let uri = Uri2.fromPath(filePath); - let result = - switch (State.getFullFromCmt(~state, ~uri)) { - | Error(message) => - prerr_endline(message); - "[]"; - | Ok((package, full)) => - autocomplete(~currentFile, ~full, ~package, ~pos, ~state) - }; - print_endline(result); - | _ => () - }; -}; diff --git a/src/Files.ml b/src/Files.ml new file mode 100644 index 00000000..4271e7f8 --- /dev/null +++ b/src/Files.ml @@ -0,0 +1,133 @@ +let split str string = Str.split (Str.regexp_string str) string + +let removeExtraDots path = + Str.global_replace (Str.regexp_string "/./") "/" path + |> Str.global_replace (Str.regexp {|^\./\.\./|}) "../" + +(* Win32 & MacOS are case-insensitive *) +let pathEq = + match Sys.os_type = "Linux" with + | true -> fun a b -> a = b + | false -> fun a b -> String.lowercase_ascii a = String.lowercase_ascii b + +let pathStartsWith text prefix = + String.length prefix <= String.length text + && pathEq (String.sub text 0 (String.length prefix)) prefix + +let sliceToEnd str pos = String.sub str pos (String.length str - pos) + +let relpath base path = + if pathStartsWith path base then + let baselen = String.length base in + let rest = String.sub path baselen (String.length path - baselen) in + if rest = "" then "." ^ Filename.dir_sep + else if rest.[0] = Filename.dir_sep.[0] then + if String.length rest > 1 && rest.[1] = '.' then sliceToEnd rest 1 + else "." ^ rest + else if rest.[0] = '.' then rest + else "." ^ Filename.dir_sep ^ rest + else + let rec loop bp pp = + match (bp, pp) with + | "." :: ra, _ -> loop ra pp + | _, "." :: rb -> loop bp rb + | a :: ra, b :: rb when pathEq a b -> loop ra rb + | _ -> (bp, pp) + in + let base, path = + loop (split Filename.dir_sep base) (split Filename.dir_sep path) + in + String.concat Filename.dir_sep + ( ( match base = [] with + | true -> ["."] + | false -> List.map (fun _ -> "..") base ) + @ path ) + |> removeExtraDots + +let maybeStat path = + try Some (Unix.stat path) with Unix.Unix_error (Unix.ENOENT, _, _) -> None + +let getMtime path = + match maybeStat path with Some {Unix.st_mtime} -> Some st_mtime | _ -> None + +let readFile path = + match maybeStat path with + | Some {Unix.st_kind = Unix.S_REG} -> + let ic = open_in path in + let try_read () = + match input_line ic with exception End_of_file -> None | x -> Some x + in + let rec loop acc = + match try_read () with + | Some s -> loop (s :: acc) + | None -> + close_in ic; + List.rev acc + in + let text = loop [] |> String.concat (String.make 1 '\n') in + Some text + | _ -> None + +let readFileResult path = + match readFile path with + | None -> Error ("Unable to read " ^ path) + | Some text -> Ok text + +let exists path = match maybeStat path with None -> false | Some _ -> true + +let ifExists path = match exists path with true -> Some path | false -> None + +let readDirectory dir = + let maybeGet handle = + try Some (Unix.readdir handle) with End_of_file -> None + in + let rec loop handle = + match maybeGet handle with + | None -> + Unix.closedir handle; + [] + | Some name + when name = Filename.current_dir_name || name = Filename.parent_dir_name + -> + loop handle + | Some name -> name :: loop handle + in + match Unix.opendir dir with + | exception Unix.Unix_error (Unix.ENOENT, "opendir", _dir) -> [] + | handle -> loop handle + +let rec collectDirs path = + match maybeStat path with + | None -> [] + | Some {Unix.st_kind = Unix.S_DIR} -> + path + :: ( readDirectory path + |> List.map (fun name -> collectDirs (Filename.concat path name)) + |> List.concat ) + | _ -> [] + +let rec collect ?(checkDir = fun _ -> true) path test = + match maybeStat path with + | None -> [] + | Some {Unix.st_kind = Unix.S_DIR} -> + if checkDir path then + readDirectory path + |> List.map (fun name -> + collect ~checkDir (Filename.concat path name) test) + |> List.concat + else [] + | _ -> ( match test path with true -> [path] | false -> [] ) + +let fileConcat a b = + if + b <> "" + && b.[0] = '.' + && String.length b >= 2 + && b.[1] = Filename.dir_sep.[0] + then Filename.concat a (String.sub b 2 (String.length b - 2)) + else Filename.concat a b + +let isFullPath b = + b.[0] = '/' || (Sys.win32 && String.length b > 1 && b.[1] = ':') + +let maybeConcat a b = if b <> "" && isFullPath b then b else fileConcat a b diff --git a/src/Files.re b/src/Files.re deleted file mode 100644 index 57efaa5f..00000000 --- a/src/Files.re +++ /dev/null @@ -1,170 +0,0 @@ -let split = (str, string) => Str.split(Str.regexp_string(str), string); - -let removeExtraDots = path => - Str.global_replace(Str.regexp_string("/./"), "/", path) - |> Str.global_replace(Str.regexp({|^\./\.\./|}), "../"); - -// Win32 & MacOS are case-insensitive -let pathEq = - Sys.os_type == "Linux" - ? (a, b) => a == b - : ((a, b) => String.lowercase_ascii(a) == String.lowercase_ascii(b)); - -let pathStartsWith = (text, prefix) => - String.length(prefix) <= String.length(text) - && pathEq(String.sub(text, 0, String.length(prefix)), prefix); -let sliceToEnd = (str, pos) => - String.sub(str, pos, String.length(str) - pos); - -let relpath = (base, path) => - if (pathStartsWith(path, base)) { - let baselen = String.length(base); - let rest = String.sub(path, baselen, String.length(path) - baselen); - if (rest == "") { - "." ++ Filename.dir_sep; - } else if (rest.[0] == Filename.dir_sep.[0]) { - if (String.length(rest) > 1 && rest.[1] == '.') { - sliceToEnd(rest, 1); - } else { - "." ++ rest; - }; - } else if (rest.[0] == '.') { - rest; - } else { - "." ++ Filename.dir_sep ++ rest; - }; - } else { - let rec loop = (bp, pp) => { - switch (bp, pp) { - | ([".", ...ra], _) => loop(ra, pp) - | (_, [".", ...rb]) => loop(bp, rb) - | ([a, ...ra], [b, ...rb]) when pathEq(a, b) => loop(ra, rb) - | _ => (bp, pp) - }; - }; - let (base, path) = - loop(split(Filename.dir_sep, base), split(Filename.dir_sep, path)); - String.concat( - Filename.dir_sep, - (base == [] ? ["."] : List.map(_ => "..", base)) @ path, - ) - |> removeExtraDots; - }; - -let maybeStat = path => - try(Some(Unix.stat(path))) { - | Unix.Unix_error(Unix.ENOENT, _, _) => None - }; - -let getMtime = path => - switch (maybeStat(path)) { - | Some({Unix.st_mtime}) => Some(st_mtime) - | _ => None - }; - -let readFile = path => { - switch (maybeStat(path)) { - | Some({Unix.st_kind: Unix.S_REG}) => - let ic = open_in(path); - let try_read = () => - switch (input_line(ic)) { - | exception End_of_file => None - | x => Some(x) - }; - let rec loop = acc => - switch (try_read()) { - | Some(s) => loop([s, ...acc]) - | None => - close_in(ic); - List.rev(acc); - }; - let text = loop([]) |> String.concat(String.make(1, '\n')); - Some(text); - | _ => None - }; -}; - -let readFileResult = path => - switch (readFile(path)) { - | None => Error("Unable to read " ++ path) - | Some(text) => Ok(text) - }; - -let exists = path => - switch (maybeStat(path)) { - | None => false - | Some(_) => true - }; - -let ifExists = path => exists(path) ? Some(path) : None; - -let readDirectory = dir => { - let maybeGet = handle => - try(Some(Unix.readdir(handle))) { - | End_of_file => None - }; - let rec loop = handle => - switch (maybeGet(handle)) { - | None => - Unix.closedir(handle); - []; - | Some(name) - when - name == Filename.current_dir_name || name == Filename.parent_dir_name => - loop(handle) - | Some(name) => [name, ...loop(handle)] - }; - switch (Unix.opendir(dir)) { - | exception (Unix.Unix_error(Unix.ENOENT, "opendir", _dir)) => [] - | handle => loop(handle) - }; -}; - -let rec collectDirs = path => { - switch (maybeStat(path)) { - | None => [] - | Some({Unix.st_kind: Unix.S_DIR}) => [ - path, - ...readDirectory(path) - |> List.map(name => collectDirs(Filename.concat(path, name))) - |> List.concat, - ] - | _ => [] - }; -}; - -let rec collect = (~checkDir=_ => true, path, test) => - switch (maybeStat(path)) { - | None => [] - | Some({Unix.st_kind: Unix.S_DIR}) => - if (checkDir(path)) { - readDirectory(path) - |> List.map(name => - collect(~checkDir, Filename.concat(path, name), test) - ) - |> List.concat; - } else { - []; - } - | _ => test(path) ? [path] : [] - }; - -let fileConcat = (a, b) => - if (b != "" - && b.[0] == '.' - && String.length(b) >= 2 - && b.[1] == Filename.dir_sep.[0]) { - Filename.concat(a, String.sub(b, 2, String.length(b) - 2)); - } else { - Filename.concat(a, b); - }; - -let isFullPath = b => - b.[0] == '/' || Sys.win32 && String.length(b) > 1 && b.[1] == ':'; - -let maybeConcat = (a, b) => - if (b != "" && isFullPath(b)) { - b; - } else { - fileConcat(a, b); - }; diff --git a/src/FindFiles.ml b/src/FindFiles.ml new file mode 100644 index 00000000..abf949cc --- /dev/null +++ b/src/FindFiles.ml @@ -0,0 +1,293 @@ +open Infix + +let ifDebug debug name fn v = + if debug then Log.log (name ^ ": " ^ fn v); + v + +(* Returns a list of paths, relative to the provided `base` *) +let getSourceDirectories ~includeDev base config = + let rec handleItem current item = + match item with + | Json.Array contents -> + List.map (handleItem current) contents |> List.concat + | Json.String text -> [current /+ text] + | Json.Object _ -> ( + let dir = + Json.get "dir" item |?> Json.string |? "Must specify directory" + in + let typ = + match includeDev with + | true -> "lib" + | false -> item |> Json.get "type" |?> Json.string |? "lib" + in + if typ = "dev" then [] + else + match item |> Json.get "subdirs" with + | None | Some Json.False -> [current /+ dir] + | Some Json.True -> + Files.collectDirs (base /+ current /+ dir) + (* |> ifDebug(true, "Subdirs", String.concat(" - ")) *) + |> List.filter (fun name -> name <> Filename.current_dir_name) + |> List.map (Files.relpath base) + | Some item -> (current /+ dir) :: handleItem (current /+ dir) item ) + | _ -> failwith "Invalid subdirs entry" + in + config |> Json.get "sources" |?>> handleItem "" |? [] + +let isCompiledFile name = + Filename.check_suffix name ".cmt" || Filename.check_suffix name ".cmti" + +let isSourceFile name = + Filename.check_suffix name ".re" + || Filename.check_suffix name ".rei" + || Filename.check_suffix name ".res" + || Filename.check_suffix name ".resi" + || Filename.check_suffix name ".ml" + || Filename.check_suffix name ".mli" + +let compiledNameSpace name = + Str.split (Str.regexp_string "-") name + |> List.map String.capitalize_ascii + |> String.concat "" + (* Remove underscores??? Whyyy bucklescript, whyyyy *) + |> Str.split (Str.regexp_string "_") + |> String.concat "" + +let compiledBaseName ~namespace name = + Filename.chop_extension name + ^ match namespace with None -> "" | Some n -> "-" ^ compiledNameSpace n + +let getName x = + Filename.basename x |> Filename.chop_extension |> String.capitalize_ascii + +let filterDuplicates cmts = + (* Remove .cmt's that have .cmti's *) + let intfs = Hashtbl.create 100 in + cmts + |> List.iter (fun path -> + if + Filename.check_suffix path ".rei" + || Filename.check_suffix path ".mli" + || Filename.check_suffix path ".cmti" + then Hashtbl.add intfs (getName path) true); + cmts + |> List.filter (fun path -> + not + ( ( Filename.check_suffix path ".re" + || Filename.check_suffix path ".ml" + || Filename.check_suffix path ".cmt" ) + && Hashtbl.mem intfs (getName path) )) + +let nameSpaceToName n = + n + |> Str.split (Str.regexp "[-/@]") + |> List.map String.capitalize_ascii + |> String.concat "" + +let getNamespace config = + let ns = Json.get "namespace" config in + let isNamespaced = + ns |?> Json.bool |? (ns |?> Json.string |?> (fun _ -> Some true) |? false) + in + match isNamespaced with + | true -> + ns |?> Json.string + |?? (Json.get "name" config |?> Json.string) + |! "name is required if namespace is true" |> nameSpaceToName + |> fun s -> Some s + | false -> None + +let collectFiles directory = + let allFiles = Files.readDirectory directory in + let compileds = allFiles |> List.filter isCompiledFile |> filterDuplicates in + let sources = allFiles |> List.filter isSourceFile |> filterDuplicates in + compileds + |> List.map (fun path -> + let modName = getName path in + let compiled = directory /+ path in + let source = + Utils.find + (fun name -> + match getName name = modName with + | true -> Some (directory /+ name) + | false -> None) + sources + in + (modName, SharedTypes.Impl (compiled, source))) + +(* returns a list of (absolute path to cmt(i), relative path from base to source file) *) +let findProjectFiles ~debug namespace root sourceDirectories compiledBase = + let files = + sourceDirectories + |> List.map (Files.fileConcat root) + |> ifDebug debug "Source directories" (String.concat " - ") + |> List.map (fun name -> Files.collect name isSourceFile) + |> List.concat |> Utils.dedup + |> ifDebug debug "Source files found" (String.concat " : ") + (* + |> filterDuplicates + |> Utils.filterMap(path => { + let rel = Files.relpath(root, path); + ifOneExists([ + compiledBase /+ cmtName(~namespace, rel), + compiledBase /+ cmiName(~namespace, rel), + ]) |?>> cm => (cm, path) + }) + |> ifDebug(debug, "With compiled base", (items) => String.concat("\n", List.map(((a, b)) => a ++ " : " ++ b, items))) + |> List.filter(((full, rel)) => Files.exists(full)) + /* TODO more than just Impl() */ + |> List.map(((cmt, src)) => (getName(src), SharedTypes.Impl(cmt, Some(src)))) + *) + in + let interfaces = Hashtbl.create 100 in + files + |> List.iter (fun path -> + if + Filename.check_suffix path ".rei" + || Filename.check_suffix path ".resi" + || Filename.check_suffix path ".mli" + then ( + Log.log ("Adding intf " ^ path); + Hashtbl.replace interfaces (getName path) path )); + let normals = + files + |> Utils.filterMap (fun path -> + if + Filename.check_suffix path ".re" + || Filename.check_suffix path ".res" + || Filename.check_suffix path ".ml" + then ( + let mname = getName path in + let intf = Hashtbl.find_opt interfaces mname in + Hashtbl.remove interfaces mname; + let base = compiledBaseName ~namespace (Files.relpath root path) in + match intf with + | Some intf -> + let cmti = (compiledBase /+ base) ^ ".cmti" in + let cmt = (compiledBase /+ base) ^ ".cmt" in + if Files.exists cmti then + if Files.exists cmt then + (* Log.log("Intf and impl " ++ cmti ++ " " ++ cmt) *) + Some (mname, SharedTypes.IntfAndImpl (cmti, intf, cmt, path)) + else Some (mname, Intf (cmti, intf)) + else ( + (* Log.log("Just intf " ++ cmti) *) + Log.log ("Bad source file (no cmt/cmti/cmi) " ^ (compiledBase /+ base)); + None + ) + | None -> + let cmt = (compiledBase /+ base) ^ ".cmt" in + if Files.exists cmt then Some (mname, Impl (cmt, Some path)) + else ( + Log.log ("Bad source file (no cmt/cmi) " ^ (compiledBase /+ base)); + None + ) + ) else ( + Log.log ("Bad source file (extension) " ^ path); + None + ) + ) + in + let result = + List.append normals + (Hashtbl.fold + (fun mname intf res -> + let base = compiledBaseName ~namespace (Files.relpath root intf) in + Log.log ("Extra intf " ^ intf); + let cmti = (compiledBase /+ base) ^ ".cmti" in + if Files.exists cmti then + (mname, SharedTypes.Intf (cmti, intf)) :: res + else res) + interfaces []) + |> List.map (fun (name, paths) -> + match namespace with + | None -> (name, paths) + | Some namespace -> (name ^ "-" ^ namespace, paths)) + in + match namespace with + | None -> result + | Some namespace -> + let mname = nameSpaceToName namespace in + let cmt = (compiledBase /+ namespace) ^ ".cmt" in + Log.log ("adding namespace " ^ namespace ^ " : " ^ mname ^ " : " ^ cmt); + (mname, Impl (cmt, None)) :: result + +(* +let loadStdlib = stdlib => { + collectFiles(stdlib) + |> List.filter(((_, (cmt, src))) => Files.exists(cmt)) +}; +*) + +let findDependencyFiles ~debug base config = + let deps = + config |> Json.get "bs-dependencies" |?> Json.array |? [] + |> optMap Json.string + in + let devDeps = + config + |> Json.get "bs-dev-dependencies" + |?> Json.array |? [] |> optMap Json.string + in + let deps = deps @ devDeps in + Log.log ("Deps " ^ String.concat ", " deps); + let depFiles = + deps + |> List.map (fun name -> + let result = + ModuleResolution.resolveNodeModulePath ~startPath:base name + |?> fun loc -> + let innerPath = loc /+ "bsconfig.json" in + Log.log ("Dep loc " ^ innerPath); + match Files.readFile innerPath with + | Some text -> ( + let inner = Json.parse text in + let namespace = getNamespace inner in + let directories = + getSourceDirectories ~includeDev:false loc inner + in + match BuildSystem.getCompiledBase loc with + | None -> None + | Some compiledBase -> + if debug then Log.log ("Compiled base: " ^ compiledBase); + let compiledDirectories = + directories |> List.map (Files.fileConcat compiledBase) + in + let compiledDirectories = + match namespace = None with + | true -> compiledDirectories + | false -> compiledBase :: compiledDirectories + in + let files = + findProjectFiles ~debug namespace loc directories + compiledBase + in + (* + let files = switch (namespace) { + | None => + files + | Some(namespace) => + files + |> List.map(((name, paths)) => + (namespace ++ "-" ++ name, paths) + ) + }; + *) + Some (compiledDirectories, files) ) + | None -> None + in + match result with + | Some dependency -> dependency + | None -> + Log.log ("Skipping nonexistent dependency: " ^ name); + ([], []) + ) + in + let directories, files = List.split depFiles in + let files = List.concat files in + match BuildSystem.getStdlib base with + | Error e -> Error e + | Ok stdlibDirectory -> + let directories = stdlibDirectory :: List.concat directories in + let results = files @ collectFiles stdlibDirectory in + Ok (directories, results) diff --git a/src/FindFiles.re b/src/FindFiles.re deleted file mode 100644 index 0a327a03..00000000 --- a/src/FindFiles.re +++ /dev/null @@ -1,355 +0,0 @@ -open Infix; - -let ifDebug = (debug, name, fn, v) => { - if (debug) { - Log.log(name ++ ": " ++ fn(v)); - }; - v; -}; - -/** - * Returns a list of paths, relative to the provided `base` - * - */ -let getSourceDirectories = (~includeDev, base, config) => { - let rec handleItem = (current, item) => { - switch (item) { - | Json.Array(contents) => - List.map(handleItem(current), contents) |> List.concat - | Json.String(text) => [current /+ text] - | Json.Object(_) => - let dir = - Json.get("dir", item) |?> Json.string |? "Must specify directory"; - let typ = - includeDev - ? "lib" : item |> Json.get("type") |?> Json.string |? "lib"; - if (typ == "dev") { - []; - } else { - switch (item |> Json.get("subdirs")) { - | None - | Some(Json.False) => [current /+ dir] - | Some(Json.True) => - Files.collectDirs(base /+ current /+ dir) - /* |> ifDebug(true, "Subdirs", String.concat(" - ")) */ - |> List.filter(name => name != Filename.current_dir_name) - |> List.map(Files.relpath(base)) - | Some(item) => [ - current /+ dir, - ...handleItem(current /+ dir, item), - ] - }; - }; - | _ => failwith("Invalid subdirs entry") - }; - }; - config |> Json.get("sources") |?>> handleItem("") |? []; -}; - -let isCompiledFile = name => - Filename.check_suffix(name, ".cmt") || Filename.check_suffix(name, ".cmti"); - -let isSourceFile = name => - Filename.check_suffix(name, ".re") - || Filename.check_suffix(name, ".rei") - || Filename.check_suffix(name, ".res") - || Filename.check_suffix(name, ".resi") - || Filename.check_suffix(name, ".ml") - || Filename.check_suffix(name, ".mli"); - -let compiledNameSpace = name => - Str.split(Str.regexp_string("-"), name) - |> List.map(String.capitalize_ascii) - |> String.concat("") - /* Remove underscores??? Whyyy bucklescript, whyyyy */ - |> Str.split(Str.regexp_string("_")) - |> String.concat(""); - -let compiledBaseName = (~namespace, name) => - Filename.chop_extension(name) - ++ ( - switch (namespace) { - | None => "" - | Some(n) => "-" ++ compiledNameSpace(n) - } - ); - -let getName = x => - Filename.basename(x) |> Filename.chop_extension |> String.capitalize_ascii; - -let filterDuplicates = cmts => { - /* Remove .cmt's that have .cmti's */ - let intfs = Hashtbl.create(100); - cmts - |> List.iter(path => - if (Filename.check_suffix(path, ".rei") - || Filename.check_suffix(path, ".mli") - || Filename.check_suffix(path, ".cmti")) { - Hashtbl.add(intfs, getName(path), true); - } - ); - cmts - |> List.filter(path => - !( - ( - Filename.check_suffix(path, ".re") - || Filename.check_suffix(path, ".ml") - || Filename.check_suffix(path, ".cmt") - ) - && Hashtbl.mem(intfs, getName(path)) - ) - ); -}; - -let nameSpaceToName = n => - n - |> Str.split(Str.regexp("[-/@]")) - |> List.map(String.capitalize_ascii) - |> String.concat(""); - -let getNamespace = config => { - let ns = Json.get("namespace", config); - let isNamespaced = - ns |?> Json.bool |? (ns |?> Json.string |?> (_ => Some(true)) |? false); - isNamespaced - ? ns - |?> Json.string - |?? (Json.get("name", config) |?> Json.string) - |! "name is required if namespace is true" - |> nameSpaceToName - |> (s => Some(s)) - : None; -}; - -let collectFiles = directory => { - let allFiles = Files.readDirectory(directory); - let compileds = allFiles |> List.filter(isCompiledFile) |> filterDuplicates; - let sources = allFiles |> List.filter(isSourceFile) |> filterDuplicates; - compileds - |> List.map(path => { - let modName = getName(path); - let compiled = directory /+ path; - let source = - Utils.find( - name => getName(name) == modName ? Some(directory /+ name) : None, - sources, - ); - (modName, SharedTypes.Impl(compiled, source)); - }); -}; - -/** - * returns a list of (absolute path to cmt(i), relative path from base to source file) - */ -let findProjectFiles = - (~debug, namespace, root, sourceDirectories, compiledBase) => { - let files = - sourceDirectories - |> List.map(Files.fileConcat(root)) - |> ifDebug(debug, "Source directories", String.concat(" - ")) - |> List.map(name => Files.collect(name, isSourceFile)) - |> List.concat - |> Utils.dedup - |> ifDebug(debug, "Source files found", String.concat(" : ")); - - /* |> filterDuplicates - |> Utils.filterMap(path => { - let rel = Files.relpath(root, path); - ifOneExists([ - compiledBase /+ cmtName(~namespace, rel), - compiledBase /+ cmiName(~namespace, rel), - ]) |?>> cm => (cm, path) - }) - |> ifDebug(debug, "With compiled base", (items) => String.concat("\n", List.map(((a, b)) => a ++ " : " ++ b, items))) - |> List.filter(((full, rel)) => Files.exists(full)) - /* TODO more than just Impl() */ - |> List.map(((cmt, src)) => (getName(src), SharedTypes.Impl(cmt, Some(src)))) */ - let interfaces = Hashtbl.create(100); - files - |> List.iter(path => - if (Filename.check_suffix(path, ".rei") - || Filename.check_suffix(path, ".resi") - || Filename.check_suffix(path, ".mli")) { - Log.log("Adding intf " ++ path); - Hashtbl.replace(interfaces, getName(path), path); - } - ); - - let normals = - files - |> Utils.filterMap(path => - if (Filename.check_suffix(path, ".re") - || Filename.check_suffix(path, ".res") - || Filename.check_suffix(path, ".ml")) { - let mname = getName(path); - let intf = Hashtbl.find_opt(interfaces, mname); - Hashtbl.remove(interfaces, mname); - let base = - compiledBaseName(~namespace, Files.relpath(root, path)); - switch (intf) { - | Some(intf) => - let cmti = compiledBase /+ base ++ ".cmti"; - let cmt = compiledBase /+ base ++ ".cmt"; - if (Files.exists(cmti)) { - if (Files.exists(cmt)) { - /* Log.log("Intf and impl " ++ cmti ++ " " ++ cmt); */ - Some(( - mname, - SharedTypes.IntfAndImpl(cmti, intf, cmt, path), - )); - } else { - /* Log.log("Just intf " ++ cmti); */ - Some(( - mname, - Intf(cmti, intf), - )); - }; - } else { - Log.log( - "Bad source file (no cmt/cmti/cmi) " ++ compiledBase /+ base, - ); - None; - }; - | None => - let cmt = compiledBase /+ base ++ ".cmt"; - if (Files.exists(cmt)) { - Some((mname, Impl(cmt, Some(path)))); - } else { - Log.log( - "Bad source file (no cmt/cmi) " ++ compiledBase /+ base, - ); - None; - }; - }; - } else { - Log.log("Bad source file (extension) " ++ path); - None; - } - ); - - let result = - List.append( - normals, - Hashtbl.fold( - (mname, intf, res) => { - let base = compiledBaseName(~namespace, Files.relpath(root, intf)); - Log.log("Extra intf " ++ intf); - let cmti = compiledBase /+ base ++ ".cmti"; - if (Files.exists(cmti)) { - [(mname, SharedTypes.Intf(cmti, intf)), ...res]; - } else { - res; - }; - }, - interfaces, - [], - ), - ) - |> List.map(((name, paths)) => - switch (namespace) { - | None => (name, paths) - | Some(namespace) => (name ++ "-" ++ namespace, paths) - } - ); - - switch (namespace) { - | None => result - | Some(namespace) => - let mname = nameSpaceToName(namespace); - let cmt = compiledBase /+ namespace ++ ".cmt"; - Log.log( - "adding namespace " ++ namespace ++ " : " ++ mname ++ " : " ++ cmt, - ); - [(mname, Impl(cmt, None)), ...result]; - }; -}; - -/* let loadStdlib = stdlib => { - collectFiles(stdlib) - |> List.filter(((_, (cmt, src))) => Files.exists(cmt)) - }; */ - -let findDependencyFiles = (~debug, base, config) => { - let deps = - config - |> Json.get("bs-dependencies") - |?> Json.array - |? [] - |> optMap(Json.string); - let devDeps = - config - |> Json.get("bs-dev-dependencies") - |?> Json.array - |? [] - |> optMap(Json.string); - let deps = deps @ devDeps; - Log.log("Deps " ++ String.concat(", ", deps)); - let depFiles = - deps - |> List.map(name => { - let result = - ModuleResolution.resolveNodeModulePath(~startPath=base, name) - |?> ( - loc => { - let innerPath = loc /+ "bsconfig.json"; - Log.log("Dep loc " ++ innerPath); - switch (Files.readFile(innerPath)) { - | Some(text) => - let inner = Json.parse(text); - let namespace = getNamespace(inner); - let directories = - getSourceDirectories(~includeDev=false, loc, inner); - switch (BuildSystem.getCompiledBase(loc)) { - | None => None - | Some(compiledBase) => - if (debug) { - Log.log("Compiled base: " ++ compiledBase); - }; - let compiledDirectories = - directories |> List.map(Files.fileConcat(compiledBase)); - let compiledDirectories = - namespace == None - ? compiledDirectories - : [compiledBase, ...compiledDirectories]; - let files = - findProjectFiles( - ~debug, - namespace, - loc, - directories, - compiledBase, - ); - /* let files = - switch (namespace) { - | None => - files - | Some(namespace) => - files - |> List.map(((name, paths)) => - (namespace ++ "-" ++ name, paths) - ) - }; */ - Some((compiledDirectories, files)); - }; - | None => None - }; - } - ); - - switch (result) { - | Some(dependency) => dependency - | None => - Log.log("Skipping nonexistent dependency: " ++ name); - ([], []); - }; - }); - let (directories, files) = List.split(depFiles); - let files = List.concat(files); - switch (BuildSystem.getStdlib(base)) { - | Error(e) => Error(e) - | Ok(stdlibDirectory) => - let directories = [stdlibDirectory, ...List.concat(directories)]; - let results = files @ collectFiles(stdlibDirectory); - Ok((directories, results)); - }; -}; diff --git a/src/Hover.ml b/src/Hover.ml new file mode 100644 index 00000000..0c4ad8a8 --- /dev/null +++ b/src/Hover.ml @@ -0,0 +1,160 @@ +let digConstructor ~env ~getModule path = + match Query.resolveFromCompilerPath ~env ~getModule path with + | `Not_found -> None + | `Stamp stamp -> ( + match Hashtbl.find_opt env.file.stamps.types stamp with + | None -> None + | Some t -> Some (env, t) ) + | `Exported (env, name) -> ( + match Hashtbl.find_opt env.exported.types name with + | None -> None + | Some stamp -> ( + match Hashtbl.find_opt env.file.stamps.types stamp with + | None -> None + | Some t -> Some (env, t) ) ) + | _ -> None + +let codeBlock code = Printf.sprintf "```rescript\n%s\n```" code + +let showModuleTopLevel ~docstring ~name + (topLevel : SharedTypes.moduleItem SharedTypes.declared list) = + let contents = + topLevel + |> List.map (fun item -> + match item.SharedTypes.item with + (* TODO pretty print module contents *) + | SharedTypes.MType ({decl}, recStatus) -> + " " ^ (decl |> Shared.declToString ~recStatus item.name.txt) + | Module _ -> " module " ^ item.name.txt + | MValue typ -> + " let " ^ item.name.txt ^ ": " ^ (typ |> Shared.typeToString)) (* TODO indent *) + |> String.concat "\n" + in + let full = "module " ^ name ^ " = {" ^ "\n" ^ contents ^ "\n}" in + let doc = + match docstring with + | [] -> "" + | _ :: _ -> "\n" ^ (docstring |> String.concat "\n") ^ "\n" + in + Some (doc ^ codeBlock full) + +let showModule ~docstring ~(file : SharedTypes.file) ~name + (declared : SharedTypes.moduleKind SharedTypes.declared option) = + match declared with + | None -> showModuleTopLevel ~docstring ~name file.contents.topLevel + | Some {item = Structure {topLevel}} -> + showModuleTopLevel ~docstring ~name topLevel + | Some {item = Ident _} -> Some "Unable to resolve module reference" + +let newHover ~(file : SharedTypes.file) ~getModule loc = + match loc with + | SharedTypes.Explanation text -> Some text + | TypeDefinition (name, decl, _stamp) -> + let typeDef = Shared.declToString name decl in + Some (codeBlock typeDef) + | LModule (Definition (stamp, _tip)) | LModule (LocalReference (stamp, _tip)) + -> ( + match Hashtbl.find_opt file.stamps.modules stamp with + | None -> None + | Some md -> ( + match References.resolveModuleReference ~file ~getModule md with + | None -> None + | Some (file, declared) -> + let name, docstring = + match declared with + | Some d -> (d.name.txt, d.docstring) + | None -> (file.moduleName, file.contents.docstring) + in + showModule ~docstring ~name ~file declared ) ) + | LModule (GlobalReference (moduleName, path, tip)) -> ( + match getModule moduleName with + | None -> None + | Some file -> ( + let env = Query.fileEnv file in + match Query.resolvePath ~env ~path ~getModule with + | None -> None + | Some (env, name) -> ( + match Query.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 + | None -> None + | Some (file, declared) -> + let name, docstring = + match declared with + | Some d -> (d.name.txt, d.docstring) + | None -> (file.moduleName, file.contents.docstring) + in + showModule ~docstring ~name ~file declared ) ) ) ) ) + | LModule NotFound -> None + | TopLevelModule name -> ( + match getModule name with + | None -> None + | Some file -> + showModule ~docstring:file.contents.docstring ~name:file.moduleName ~file + None ) + | Typed (_, Definition (_, (Field _ | Constructor _))) -> None + | Constant t -> + Some + ( match t with + | Const_int _ -> "int" + | Const_char _ -> "char" + | Const_string _ -> "string" + | Const_float _ -> "float" + | Const_int32 _ -> "int32" + | Const_int64 _ -> "int64" + | Const_nativeint _ -> "int" ) + | Typed (t, locKind) -> + let fromType ~docstring typ = + let typeString = codeBlock (typ |> Shared.typeToString) in + let extraTypeInfo = + let env = Query.fileEnv file in + match typ |> Shared.digConstructor with + | None -> None + | Some path -> ( + match digConstructor ~env ~getModule path with + | None -> None + | Some (_env, {docstring; name = {txt}; item = {decl}}) -> + let isUncurriedInternal = + Utils.startsWith (Path.name path) "Js.Fn.arity" + in + if isUncurriedInternal then None + else Some (decl |> Shared.declToString txt, docstring) ) + in + let typeString, docstring = + match extraTypeInfo with + | None -> (typeString, docstring) + | Some (extra, extraDocstring) -> + (typeString ^ "\n\n" ^ codeBlock extra, extraDocstring) + in + (typeString, docstring) + in + let parts = + match References.definedForLoc ~file ~getModule locKind with + | None -> + let typeString, docstring = t |> fromType ~docstring:[] in + typeString :: docstring + | Some (docstring, res) -> ( + match res with + | `Declared -> + let typeString, docstring = t |> fromType ~docstring in + typeString :: docstring + | `Constructor {cname = {txt}; args} -> + let typeString, docstring = t |> fromType ~docstring in + let argsString = + match args with + | [] -> "" + | _ -> + args + |> List.map (fun (t, _) -> Shared.typeToString t) + |> String.concat ", " |> Printf.sprintf "(%s)" + in + typeString :: codeBlock (txt ^ argsString) :: docstring + | `Field {typ} -> + let typeString, docstring = typ |> fromType ~docstring in + typeString :: docstring ) + in + Some (String.concat "\n\n" parts) diff --git a/src/Hover.re b/src/Hover.re deleted file mode 100644 index 075d8ec3..00000000 --- a/src/Hover.re +++ /dev/null @@ -1,208 +0,0 @@ -let digConstructor = (~env, ~getModule, path) => { - switch (Query.resolveFromCompilerPath(~env, ~getModule, path)) { - | `Not_found => None - | `Stamp(stamp) => - switch (Hashtbl.find_opt(env.file.stamps.types, stamp)) { - | None => None - | Some(t) => Some((env, t)) - } - | `Exported(env, name) => - switch (Hashtbl.find_opt(env.exported.types, name)) { - | None => None - | Some(stamp) => - switch (Hashtbl.find_opt(env.file.stamps.types, stamp)) { - | None => None - | Some(t) => Some((env, t)) - } - } - | _ => None - }; -}; - -let codeBlock = code => { - Printf.sprintf("```rescript\n%s\n```", code); -}; - -let showModuleTopLevel = - ( - ~docstring, - ~name, - topLevel: list(SharedTypes.declared(SharedTypes.moduleItem)), - ) => { - let contents = - topLevel - |> List.map(item => - switch (item.SharedTypes.item) { - /*** TODO pretty print module contents */ - | SharedTypes.MType({decl}, recStatus) => - " " ++ (decl |> Shared.declToString(~recStatus, item.name.txt)) - | Module(_) => " module " ++ item.name.txt - | MValue(typ) => - " let " ++ item.name.txt ++ ": " ++ (typ |> Shared.typeToString) /* TODO indent */ - } - ) - |> String.concat("\n"); - let full = "module " ++ name ++ " = {" ++ "\n" ++ contents ++ "\n}"; - let doc = - switch (docstring) { - | [] => "" - | [_, ..._] => "\n" ++ (docstring |> String.concat("\n")) ++ "\n" - }; - Some(doc ++ codeBlock(full)); -}; - -let showModule = - ( - ~docstring, - ~file: SharedTypes.file, - ~name, - declared: option(SharedTypes.declared(SharedTypes.moduleKind)), - ) => { - switch (declared) { - | None => showModuleTopLevel(~docstring, ~name, file.contents.topLevel) - | Some({item: Structure({topLevel})}) => - showModuleTopLevel(~docstring, ~name, topLevel) - | Some({item: Ident(_)}) => Some("Unable to resolve module reference") - }; -}; - -let newHover = (~file: SharedTypes.file, ~getModule, loc) => { - switch (loc) { - | SharedTypes.Explanation(text) => Some(text) - | TypeDefinition(name, decl, _stamp) => - let typeDef = Shared.declToString(name, decl); - Some(codeBlock(typeDef)); - | LModule(Definition(stamp, _tip)) - | LModule(LocalReference(stamp, _tip)) => - switch (Hashtbl.find_opt(file.stamps.modules, stamp)) { - | None => None - | Some(md) => - switch (References.resolveModuleReference(~file, ~getModule, md)) { - | None => None - | Some((file, declared)) => - let (name, docstring) = - switch (declared) { - | Some(d) => (d.name.txt, d.docstring) - | None => (file.moduleName, file.contents.docstring) - }; - showModule(~docstring, ~name, ~file, declared); - } - } - | LModule(GlobalReference(moduleName, path, tip)) => - switch (getModule(moduleName)) { - | None => None - | Some(file) => - let env = Query.fileEnv(file); - switch (Query.resolvePath(~env, ~path, ~getModule)) { - | None => None - | Some((env, name)) => - switch (Query.exportedForTip(~env, name, tip)) { - | None => None - | Some(stamp) => - switch (Hashtbl.find_opt(file.stamps.modules, stamp)) { - | None => None - | Some(md) => - switch (References.resolveModuleReference(~file, ~getModule, md)) { - | None => None - | Some((file, declared)) => - let (name, docstring) = - switch (declared) { - | Some(d) => (d.name.txt, d.docstring) - | None => (file.moduleName, file.contents.docstring) - }; - showModule(~docstring, ~name, ~file, declared); - } - } - } - }; - } - | LModule(NotFound) => None - | TopLevelModule(name) => - switch (getModule(name)) { - | None => None - | Some(file) => - showModule( - ~docstring=file.contents.docstring, - ~name=file.moduleName, - ~file, - None, - ) - } - | Typed(_, Definition(_, Field(_) | Constructor(_))) => None - | Constant(t) => - Some( - switch (t) { - | Const_int(_) => "int" - | Const_char(_) => "char" - | Const_string(_) => "string" - | Const_float(_) => "float" - | Const_int32(_) => "int32" - | Const_int64(_) => "int64" - | Const_nativeint(_) => "int" - }, - ) - | Typed(t, locKind) => - let fromType = (~docstring, typ) => { - let typeString = codeBlock(typ |> Shared.typeToString); - let extraTypeInfo = { - let env = Query.fileEnv(file); - switch (typ |> Shared.digConstructor) { - | None => None - | Some(path) => - switch (digConstructor(~env, ~getModule, path)) { - | None => None - | Some((_env, {docstring, name: {txt}, item: {decl}})) => - let isUncurriedInternal = - Utils.startsWith(Path.name(path), "Js.Fn.arity"); - if (isUncurriedInternal) { - None; - } else { - Some((decl |> Shared.declToString(txt), docstring)); - }; - } - }; - }; - let (typeString, docstring) = - switch (extraTypeInfo) { - | None => (typeString, docstring) - | Some((extra, extraDocstring)) => ( - typeString ++ "\n\n" ++ codeBlock(extra), - extraDocstring, - ) - }; - (typeString, docstring); - }; - - let parts = - switch (References.definedForLoc(~file, ~getModule, locKind)) { - | None => - let (typeString, docstring) = t |> fromType(~docstring=[]); - [typeString, ...docstring]; - | Some((docstring, res)) => - switch (res) { - | `Declared => - let (typeString, docstring) = t |> fromType(~docstring); - [typeString, ...docstring]; - | `Constructor({cname: {txt}, args}) => - let (typeString, docstring) = t |> fromType(~docstring); - - let argsString = - switch (args) { - | [] => "" - | _ => - args - |> List.map(((t, _)) => Shared.typeToString(t)) - |> String.concat(", ") - |> Printf.sprintf("(%s)") - }; - - [typeString, codeBlock(txt ++ argsString), ...docstring]; - | `Field({typ}) => - let (typeString, docstring) = typ |> fromType(~docstring); - [typeString, ...docstring]; - } - }; - - Some(String.concat("\n\n", parts)); - }; -}; diff --git a/src/Infix.ml b/src/Infix.ml new file mode 100644 index 00000000..85b1aa12 --- /dev/null +++ b/src/Infix.ml @@ -0,0 +1,31 @@ +(** + * This combines a filter and a map. + * You provide a function that turns an element into an optional of another element, + * and you get a list of all of the present results. + *) +let optMap : ('a -> 'b option) -> 'a list -> 'b list = fun fn items -> + List.fold_left + (fun result item -> + match fn item with None -> result | Some res -> res :: result) + [] items + +let ( |! ) o d = match o with None -> failwith d | Some v -> v + +let ( |? ) o d = match o with None -> d | Some v -> v + +let ( |?? ) o d = match o with None -> d | Some v -> Some v + +let ( |?> ) o fn = match o with None -> None | Some v -> fn v + +let ( |?>> ) o fn = match o with None -> None | Some v -> Some (fn v) + +let fold o d f = match o with None -> d | Some v -> f v + +let logIfAbsent message x = + match x with + | None -> + Log.log message; + None + | _ -> x + +let ( /+ ) = Files.fileConcat diff --git a/src/Infix.re b/src/Infix.re deleted file mode 100644 index eec5f46b..00000000 --- a/src/Infix.re +++ /dev/null @@ -1,57 +0,0 @@ -/** - * This combines a filter and a map. - * You provide a function that turns an element into an optional of another element, - * and you get a list of all of the present results. - */ -let optMap: ('a => option('b), list('a)) => list('b) = - (fn, items) => - List.fold_left( - (result, item) => - switch (fn(item)) { - | None => result - | Some(res) => [res, ...result] - }, - [], - items, - ); - -let (|!) = (o, d) => - switch (o) { - | None => failwith(d) - | Some(v) => v - }; -let (|?) = (o, d) => - switch (o) { - | None => d - | Some(v) => v - }; -let (|??) = (o, d) => - switch (o) { - | None => d - | Some(v) => Some(v) - }; -let (|?>) = (o, fn) => - switch (o) { - | None => None - | Some(v) => fn(v) - }; -let (|?>>) = (o, fn) => - switch (o) { - | None => None - | Some(v) => Some(fn(v)) - }; -let fold = (o, d, f) => - switch (o) { - | None => d - | Some(v) => f(v) - }; - -let logIfAbsent = (message, x) => - switch (x) { - | None => - Log.log(message); - None; - | _ => x - }; - -let (/+) = Files.fileConcat; diff --git a/src/JsonShort.ml b/src/JsonShort.ml new file mode 100644 index 00000000..78e28514 --- /dev/null +++ b/src/JsonShort.ml @@ -0,0 +1,7 @@ +open Json + +let o o = Object o +let s s = String s +let i i = Number (float_of_int i) +let l l = Array l +let null = Null diff --git a/src/JsonShort.re b/src/JsonShort.re deleted file mode 100644 index d44b077b..00000000 --- a/src/JsonShort.re +++ /dev/null @@ -1,6 +0,0 @@ -open Json; -let o = o => Object(o); -let s = s => String(s); -let i = i => Number(float_of_int(i)); -let l = l => Array(l); -let null = Null; diff --git a/src/Log.ml b/src/Log.ml new file mode 100644 index 00000000..cd63d875 --- /dev/null +++ b/src/Log.ml @@ -0,0 +1,6 @@ +let spamError = ref false + +let log msg = + if !spamError then ( + output_string stderr (msg ^ "\n"); + flush stderr ) diff --git a/src/Log.re b/src/Log.re deleted file mode 100644 index 00d00d2b..00000000 --- a/src/Log.re +++ /dev/null @@ -1,7 +0,0 @@ -let spamError = ref(false); - -let log = msg => - if (spamError^) { - output_string(stderr, msg ++ "\n"); - flush(stderr); - }; diff --git a/src/MarkdownOfOCamldoc.ml b/src/MarkdownOfOCamldoc.ml new file mode 100644 index 00000000..1d1afa86 --- /dev/null +++ b/src/MarkdownOfOCamldoc.ml @@ -0,0 +1,181 @@ +open Comment + +let withStyle style contents = + match style with + | `Bold -> Omd.Bold contents + | `Italic -> Omd.Emph contents + | `Emphasis -> Omd.Emph contents + | `Superscript -> Omd.Raw "Superscript" + | `Subscript -> Omd.Raw "Subscript" + +let stripLoc fn item = fn item.Location_.value + +let whiteLeft text = + let ln = String.length text in + let rec loop i = + match i >= ln with + | true -> i - 1 + | false -> ( match text.[i] = ' ' with true -> loop (i + 1) | false -> i ) + in + loop 0 + +let sliceToEnd text num = + let ln = String.length text in + if ln <= num then "" else String.sub text num (ln - num) + +let stripLeft text = + let lines = Str.split (Str.regexp_string "\n") text in + let rec loop lines = + match lines with + | [] -> 0 + | [one] -> whiteLeft one + | one :: more -> min (whiteLeft one) (loop more) + in + let min = loop (lines |> List.filter (fun x -> String.trim x <> "")) in + String.concat "\n" (List.map (fun line -> sliceToEnd line min) lines) + +let makeHeader level content = + match level with + | `Title -> Omd.H1 content + | `Section -> Omd.H2 content + | `Subsection -> Omd.H3 content + | `Subsubsection -> Omd.H4 content + +(* [ `Module | `ModuleType | `Type + | `Constructor | `Field | `Extension + | `Exception | `Value | `Class | `ClassType + | `Method | `InstanceVariable | `Label | `Page ] *) +let handleRef reference = + match reference with + | Paths.Reference.Root (name, _tag) -> name + | Paths.Reference.Resolved _ -> "resolved..." + | Paths.Reference.Dot (_, name) -> name + | Paths.Reference.Module (_, name) -> name + | Paths.Reference.ModuleType (_, name) -> name + | Paths.Reference.Type (_, name) -> name + | Paths.Reference.Constructor (_, name) -> name + | Paths.Reference.Field (_, name) -> name + | Paths.Reference.Extension (_, name) -> name + | Paths.Reference.Exception (_, name) -> name + | Paths.Reference.Value (_, name) -> name + | Paths.Reference.Class (_, name) -> name + | Paths.Reference.ClassType (_, name) -> name + | Paths.Reference.Method (_, name) -> name + | _ -> "(unhandled reference)" + +let rec showPath (path : Path.module_) = + match path with + | Path.Resolved _resolved -> "" + | Path.Root name -> name + | Path.Forward name -> name + | Path.Dot (inner, name) -> showPath inner ^ "." ^ name + | Path.Apply (one, two) -> showPath one ^ "(" ^ showPath two ^ ")" + +let convertItem item = + let rec convertItem item = + match item.Location_.value with + | `Heading (level, _label, content) -> + makeHeader level (List.map convertLink content) + | `Tag (`Author string) -> Omd.Text ("Author: " ^ string) + | `Tag (`Deprecated contents) -> + Omd.Paragraph + (Omd.Text "Deprecated: " :: List.map (stripLoc convertNestable) contents) + | `Tag (`Param (name, contents)) -> + Omd.Paragraph + ( Omd.Text ("Param: " ^ name) + :: List.map (stripLoc convertNestable) contents ) + | `Tag (`Raise (name, contents)) -> + Omd.Paragraph + ( Omd.Text ("Raises: " ^ name) + :: List.map (stripLoc convertNestable) contents ) + | `Tag (`Before (version, contents)) -> + Omd.Paragraph + ( Omd.Text ("Before: " ^ version) + :: List.map (stripLoc convertNestable) contents ) + | `Tag (`Return contents) -> + Omd.Paragraph + (Omd.Text "Returns: " :: List.map (stripLoc convertNestable) contents) + | `Tag (`See (_, link, contents)) -> + Omd.Paragraph + [ + Omd.Text "See: "; + Omd.Url (link, List.map (stripLoc convertNestable) contents, ""); + ] + | `Tag (`Since versionString) -> Omd.Text ("Since: " ^ versionString) + | `Tag (`Version versionString) -> Omd.Text ("Version: " ^ versionString) + | `Tag `Open -> Omd.Text "Open" + | `Tag `Closed -> Omd.Text "Closed" + | `Tag `Inline -> Omd.Text "Inline" + | `Tag (`Canonical (path, _reference)) -> + (* output_string(stderr, "Warning: Unhandled tag 'Canonical' in ocamldoc (please tell the reason-language-server maintainers)\n"); *) + Omd.Text (showPath path) (* ++ ", " ++ handleRef(reference)) *) + | `Tag _ -> + output_string stderr + "Warning: Unhandled tag in ocamldoc (please tell the \ + reason-language-server maintainers)\n"; + Omd.Text "Unhandled tag" + | #nestable_block_element as item -> convertNestable item + and convertNestable item = + match item with + | `Example (lang, contents) -> + let newLang = + match String.trim lang = "" with + | true -> "ml" + | false -> + let parts = Str.split (Str.regexp_string ";") (String.trim lang) in + if + List.mem "ml" parts || List.mem "ocaml" parts || List.mem "re" parts + || List.mem "reason" parts + then lang + else lang ^ ";ml" + in + Omd.Code_block (newLang, stripLeft contents) + | `Doc contents -> Omd.Paragraph [Omd.Text ("@doc " ^ contents)] + | `Paragraph inline -> Omd.Paragraph (List.map convertInline inline) + | `Code_block text -> Omd.Code_block ("ml", stripLeft text) + | `Verbatim text -> Omd.Raw text (* TODO *) + | `Modules _ -> + Log.log "Unhandled modules"; + Omd.Raw "!!!! Modules please" + | `List (`Ordered, children) -> + Omd.Ol (List.map (List.map (stripLoc convertNestable)) children) + | `List (`Unordered, children) -> + Omd.Ul (List.map (List.map (stripLoc convertNestable)) children) + and convertInline item = + match item.Location_.value with + | `Link (href, content) -> Omd.Url (href, List.map convertLink content, "") + | `Styled (style, contents) -> + withStyle style (List.map convertInline contents) + | `Reference (someref, _link) -> + let text = handleRef someref in + Omd.Text text + (* Omd.Url("#TODO-ref", [Omd.Text("REFERENCE"), ...List.map(convertLink, link)], "") *) + | #leaf_inline_element as rest -> convertLeaf rest + and convertLink item = + match item.Location_.value with + | `Styled (style, contents) -> + withStyle style (List.map convertLink contents) + | #leaf_inline_element as rest -> convertLeaf rest + and convertLeaf (item : Comment.leaf_inline_element) = + match item with + | `Space -> Omd.Text " " + | `Word text -> Omd.Text text + | `Code_span text -> Omd.Code ("", text) + in + convertItem item + +let convert text = + try + let res = + Parser_.parse_comment ~permissive:true ~sections_allowed:`All + ~containing_definition: + (Paths.Identifier.Root + ({Root.package = "hi"; file = Page "hi"; digest = "hi"}, "What")) + ~location:Lexing.dummy_pos ~text + in + match res.result with + | Error.Ok docs -> List.map convertItem docs + | Error message -> + [Omd.Text ("failed to parse: " ^ Error.to_string message)] + with exn -> + [Omd.Text ("Error (invalid syntax?) while parsing ocamldoc: " ^ Printexc.to_string exn)] diff --git a/src/MarkdownOfOCamldoc.re b/src/MarkdownOfOCamldoc.re deleted file mode 100644 index 934438c8..00000000 --- a/src/MarkdownOfOCamldoc.re +++ /dev/null @@ -1,229 +0,0 @@ -open Comment; - -let withStyle = (style, contents) => - switch (style) { - | `Bold => Omd.Bold(contents) - | `Italic => Omd.Emph(contents) - | `Emphasis => Omd.Emph(contents) - | `Superscript => Omd.Raw("Superscript") - | `Subscript => Omd.Raw("Subscript") - }; - -let stripLoc = (fn, item) => fn(item.Location_.value); - -let whiteLeft = text => { - let ln = String.length(text); - let rec loop = i => { - i >= ln ? i - 1 : text.[i] == ' ' ? loop(i + 1) : i; - }; - loop(0); -}; - -let sliceToEnd = (text, num) => { - let ln = String.length(text); - if (ln <= num) { - ""; - } else { - String.sub(text, num, ln - num); - }; -}; - -let stripLeft = text => { - let lines = Str.split(Str.regexp_string("\n"), text); - let rec loop = lines => - switch (lines) { - | [] => 0 - | [one] => whiteLeft(one) - | [one, ...more] => min(whiteLeft(one), loop(more)) - }; - let min = loop(lines |> List.filter(x => String.trim(x) != "")); - String.concat("\n", List.map(line => sliceToEnd(line, min), lines)); -}; - -let makeHeader = (level, content) => { - switch (level) { - | `Title => Omd.H1(content) - | `Section => Omd.H2(content) - | `Subsection => Omd.H3(content) - | `Subsubsection => Omd.H4(content) - }; -}; - -/* [ `Module | `ModuleType | `Type - | `Constructor | `Field | `Extension - | `Exception | `Value | `Class | `ClassType - | `Method | `InstanceVariable | `Label | `Page ] */ -let handleRef = reference => - switch (reference) { - | Paths.Reference.Root(name, _tag) => name - | Paths.Reference.Resolved(_) => "resolved..." - | Paths.Reference.Dot(_, name) => name - | Paths.Reference.Module(_, name) => name - | Paths.Reference.ModuleType(_, name) => name - | Paths.Reference.Type(_, name) => name - | Paths.Reference.Constructor(_, name) => name - | Paths.Reference.Field(_, name) => name - | Paths.Reference.Extension(_, name) => name - | Paths.Reference.Exception(_, name) => name - | Paths.Reference.Value(_, name) => name - | Paths.Reference.Class(_, name) => name - | Paths.Reference.ClassType(_, name) => name - | Paths.Reference.Method(_, name) => name - | _ => "(unhandled reference)" - }; - -let rec showPath = (path: Path.module_) => - switch (path) { - | Path.Resolved(_resolved) => "" - | Path.Root(name) => name - | Path.Forward(name) => name - | Path.Dot(inner, name) => showPath(inner) ++ "." ++ name - | Path.Apply(one, two) => showPath(one) ++ "(" ++ showPath(two) ++ ")" - }; - -let convertItem = item => { - let rec convertItem = item => - switch (item.Location_.value) { - | `Heading(level, _label, content) => - makeHeader(level, List.map(convertLink, content)) - | `Tag(`Author(string)) => Omd.Text("Author: " ++ string) - | `Tag(`Deprecated(contents)) => - Omd.Paragraph([ - Omd.Text("Deprecated: "), - ...List.map(stripLoc(convertNestable), contents), - ]) - | `Tag(`Param(name, contents)) => - Omd.Paragraph([ - Omd.Text("Param: " ++ name), - ...List.map(stripLoc(convertNestable), contents), - ]) - | `Tag(`Raise(name, contents)) => - Omd.Paragraph([ - Omd.Text("Raises: " ++ name), - ...List.map(stripLoc(convertNestable), contents), - ]) - | `Tag(`Before(version, contents)) => - Omd.Paragraph([ - Omd.Text("Before: " ++ version), - ...List.map(stripLoc(convertNestable), contents), - ]) - | `Tag(`Return(contents)) => - Omd.Paragraph([ - Omd.Text("Returns: "), - ...List.map(stripLoc(convertNestable), contents), - ]) - | `Tag(`See(_, link, contents)) => - Omd.Paragraph([ - Omd.Text("See: "), - Omd.Url(link, List.map(stripLoc(convertNestable), contents), ""), - ]) - | `Tag(`Since(versionString)) => Omd.Text("Since: " ++ versionString) - | `Tag(`Version(versionString)) => - Omd.Text("Version: " ++ versionString) - | `Tag(`Open) => Omd.Text("Open") - | `Tag(`Closed) => Omd.Text("Closed") - | `Tag(`Inline) => Omd.Text("Inline") - | `Tag(`Canonical(path, _reference)) => - // output_string(stderr, "Warning: Unhandled tag 'Canonical' in ocamldoc (please tell the reason-language-server maintainers)\n"); - Omd.Text(showPath(path)) // ++ ", " ++ handleRef(reference)) - | `Tag(_) => - output_string( - stderr, - "Warning: Unhandled tag in ocamldoc (please tell the reason-language-server maintainers)\n", - ); - Omd.Text("Unhandled tag"); - | #nestable_block_element as item => convertNestable(item) - } - - and convertNestable = item => - switch (item) { - | `Example(lang, contents) => - let newLang = - String.trim(lang) == "" - ? "ml" - : { - let parts = - Str.split(Str.regexp_string(";"), String.trim(lang)); - if (List.mem("ml", parts) - || List.mem("ocaml", parts) - || List.mem("re", parts) - || List.mem("reason", parts)) { - lang; - } else { - lang ++ ";ml"; - }; - }; - Omd.Code_block(newLang, stripLeft(contents)); - | `Doc(contents) => Omd.Paragraph([Omd.Text("@doc " ++ contents)]) - | `Paragraph(inline) => Omd.Paragraph(List.map(convertInline, inline)) - | `Code_block(text) => Omd.Code_block("ml", stripLeft(text)) - | `Verbatim(text) => Omd.Raw(text) /* TODO */ - | `Modules(_) => - Log.log("Unhandled modules"); - Omd.Raw("!!!! Modules please"); - | `List(`Ordered, children) => - Omd.Ol(List.map(List.map(stripLoc(convertNestable)), children)) - | `List(`Unordered, children) => - Omd.Ul(List.map(List.map(stripLoc(convertNestable)), children)) - } - - and convertInline = item => - switch (item.Location_.value) { - | `Link(href, content) => - Omd.Url(href, List.map(convertLink, content), "") - | `Styled(style, contents) => - withStyle(style, List.map(convertInline, contents)) - | `Reference(someref, _link) => - let text = handleRef(someref); - Omd.Text(text); - /* Omd.Url("#TODO-ref", [Omd.Text("REFERENCE"), ...List.map(convertLink, link)], "") */ - | #leaf_inline_element as rest => convertLeaf(rest) - } - - and convertLink = item => - switch (item.Location_.value) { - | `Styled(style, contents) => - withStyle(style, List.map(convertLink, contents)) - | #leaf_inline_element as rest => convertLeaf(rest) - } - - and convertLeaf = (item: Comment.leaf_inline_element) => - switch (item) { - | `Space => Omd.Text(" ") - | `Word(text) => Omd.Text(text) - | `Code_span(text) => Omd.Code("", text) - }; - - convertItem(item); -}; - -let convert = text => - try ( - { - let res = - Parser_.parse_comment( - ~permissive=true, - ~sections_allowed=`All, - ~containing_definition= - Paths.Identifier.Root( - {Root.package: "hi", file: Page("hi"), digest: "hi"}, - "What", - ), - ~location=Lexing.dummy_pos, - ~text, - ); - switch (res.result) { - | Error.Ok(docs) => List.map(convertItem, docs) - | Error(message) => [ - Omd.Text("failed to parse: " ++ Error.to_string(message)), - ] - }; - } - ) { - | exn => [ - Omd.Text( - "Error (invalid syntax?) while parsing ocamldoc: " - ++ Printexc.to_string(exn), - ), - ] - }; diff --git a/src/MerlinFile.ml b/src/MerlinFile.ml new file mode 100644 index 00000000..deb6106e --- /dev/null +++ b/src/MerlinFile.ml @@ -0,0 +1,19 @@ +let parseMerlin text = + let lines = Str.split (Str.regexp_string "\n") text in + List.fold_left + (fun (source, build, flags) line -> + if Utils.startsWith line "FLG " then + (source, build, Utils.chopPrefix line "FLG " :: flags) + else if Utils.startsWith line "S " then + (Utils.chopPrefix line "S " :: source, build, flags) + else if Utils.startsWith line "B " then + (source, Utils.chopPrefix line "B " :: build, flags) + else (source, build, flags)) + ([], [], []) lines + +let getFlags base = + let open RResult.InfixResult in + Files.readFile (base ^ "/.merlin") + |> RResult.orError "no .merlin file" + |?>> parseMerlin + |?>> fun (_, _, flags) -> flags |> List.rev diff --git a/src/MerlinFile.mli b/src/MerlinFile.mli new file mode 100644 index 00000000..22027988 --- /dev/null +++ b/src/MerlinFile.mli @@ -0,0 +1 @@ +val getFlags : string -> (string list, string) result diff --git a/src/MerlinFile.re b/src/MerlinFile.re deleted file mode 100644 index 461a8c8b..00000000 --- a/src/MerlinFile.re +++ /dev/null @@ -1,25 +0,0 @@ -let parseMerlin = text => { - let lines = Str.split(Str.regexp_string("\n"), text); - List.fold_left( - ((source, build, flags), line) => - if (Utils.startsWith(line, "FLG ")) { - (source, build, [Utils.chopPrefix(line, "FLG "), ...flags]); - } else if (Utils.startsWith(line, "S ")) { - ([Utils.chopPrefix(line, "S "), ...source], build, flags); - } else if (Utils.startsWith(line, "B ")) { - (source, [Utils.chopPrefix(line, "B "), ...build], flags); - } else { - (source, build, flags); - }, - ([], [], []), - lines, - ); -}; - -let getFlags = base => - RResult.InfixResult.( - Files.readFile(base ++ "/.merlin") - |> RResult.orError("no .merlin file") - |?>> parseMerlin - |?>> (((_, _, flags)) => flags |> List.rev) - ); diff --git a/src/MerlinFile.rei b/src/MerlinFile.rei deleted file mode 100644 index 8a8d5ee3..00000000 --- a/src/MerlinFile.rei +++ /dev/null @@ -1 +0,0 @@ -let getFlags: string => result(list(string), string); diff --git a/src/ModuleResolution.ml b/src/ModuleResolution.ml new file mode 100644 index 00000000..1aac4ee7 --- /dev/null +++ b/src/ModuleResolution.ml @@ -0,0 +1,11 @@ +open Infix + +let rec resolveNodeModulePath ~startPath name = + let path = startPath /+ "node_modules" /+ name in + match startPath with + | "/" -> ( match Files.exists path with true -> Some path | false -> None ) + | _ -> ( + match Files.exists path with + | true -> Some path + | false -> + resolveNodeModulePath ~startPath:(Filename.dirname startPath) name ) diff --git a/src/ModuleResolution.re b/src/ModuleResolution.re deleted file mode 100644 index ee2dca73..00000000 --- a/src/ModuleResolution.re +++ /dev/null @@ -1,12 +0,0 @@ -open Infix; - -let rec resolveNodeModulePath = (~startPath, name) => { - let path = startPath /+ "node_modules" /+ name; - switch (startPath) { - | "/" => Files.exists(path) ? Some(path) : None - | _ => - Files.exists(path) - ? Some(path) - : resolveNodeModulePath(~startPath=Filename.dirname(startPath), name) - }; -}; diff --git a/src/NewCompletions.ml b/src/NewCompletions.ml new file mode 100644 index 00000000..32103f41 --- /dev/null +++ b/src/NewCompletions.ml @@ -0,0 +1,693 @@ +open SharedTypes + +let showConstructor {cname = {txt}; args; res} = + let open Infix in + txt + ^ ( match args = [] with + | true -> "" + | false -> + "(" + ^ String.concat ", " + (args |> List.map (fun (typ, _) -> typ |> Shared.typeToString)) + ^ ")" ) + ^ (res |?>> (fun typ -> "\n" ^ (typ |> Shared.typeToString)) |? "") + +(* TODO: local opens *) +let resolveOpens ~env ~previous opens ~getModule = + List.fold_left + (fun previous path -> + (** Finding an open, first trying to find it in previoulsly resolved opens *) + let rec loop prev = + match prev with + | [] -> ( + match path with + | Tip _ -> previous + | Nested (name, path) -> ( + match getModule name with + | None -> + Log.log ("Could not get module " ^ name); + previous (* TODO: warn? *) + | Some file -> ( + match + Query.resolvePath ~env:(Query.fileEnv file) ~getModule ~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 + | None -> loop rest + | Some (env, _placeholder) -> previous @ [env] ) + in + Log.log ("resolving open " ^ pathToString path); + match Query.resolvePath ~env ~getModule ~path with + | None -> + Log.log "Not local"; + loop previous + | Some (env, _) -> + Log.log "Was local"; + previous @ [env]) + (* loop(previous) *) + previous opens + +let completionForDeclareds ~pos declareds prefix transformContents = + (* Log.log("complete for declares " ++ prefix); *) + Hashtbl.fold + (fun _stamp declared results -> + if + Utils.startsWith declared.name.txt prefix + && Utils.locationContainsFuzzy declared.scopeLoc pos + then {declared with item = transformContents declared.item} :: results + else + (* Log.log("Nope doesn't count " ++ Utils.showLocation(declared.scopeLoc) ++ " " ++ m); *) + results + ) + declareds [] + +let completionForExporteds exporteds + (stamps : (int, 'a SharedTypes.declared) Hashtbl.t) prefix transformContents + = + Hashtbl.fold + (fun name stamp results -> + (* Log.log("checking exported: " ++ name); *) + if Utils.startsWith name prefix then + let declared = Hashtbl.find stamps stamp in + {declared with item = transformContents declared.item} :: results + else results) + exporteds [] + +let completionForConstructors exportedTypes + (stamps : (int, SharedTypes.Type.t SharedTypes.declared) Hashtbl.t) prefix = + Hashtbl.fold + (fun _name stamp results -> + let t = Hashtbl.find stamps stamp in + match t.item.kind with + | SharedTypes.Type.Variant constructors -> + ( constructors + |> List.filter (fun c -> Utils.startsWith c.cname.txt prefix) + |> List.map (fun c -> (c, t)) ) + @ results + | _ -> results) + exportedTypes [] + +let completionForFields exportedTypes + (stamps : (int, SharedTypes.Type.t SharedTypes.declared) Hashtbl.t) prefix = + Hashtbl.fold + (fun _name stamp results -> + let t = Hashtbl.find stamps stamp in + match t.item.kind with + | Record fields -> + ( fields + |> List.filter (fun f -> Utils.startsWith f.fname.txt prefix) + |> List.map (fun f -> (f, t)) ) + @ results + | _ -> results) + exportedTypes [] + +let isCapitalized name = + if name = "" then false + else + let c = name.[0] in + match c with 'A' .. 'Z' -> true | _ -> false + +let determineCompletion items = + let rec loop offset items = + match items with + | [] -> assert false + | [one] -> `Normal (Tip one) + | [one; two] when not (isCapitalized one) -> `Attribute ([one], two) + | [one; two] -> `Normal (Nested (one, Tip two)) + | one :: rest -> ( + if isCapitalized one then + match loop (offset + String.length one + 1) rest with + | `Normal path -> `Normal (Nested (one, path)) + | x -> x + else + match loop (offset + String.length one + 1) rest with + | `Normal path -> `AbsAttribute path + | `Attribute (path, suffix) -> `Attribute (one :: path, suffix) + | x -> x ) + in + loop 0 items + +(* Note: This is a hack. It will be wrong some times if you have a local thing + that overrides an open. + + 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 + | 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 + | Some x -> Some x + | None -> loop rest ) + | [] -> ( + match path with + | Tip _ -> None + | Nested (top, path) -> ( + Log.log ("Getting module " ^ top); + match getModule top with + | None -> None + | Some file -> + Log.log "got it"; + let env = Query.fileEnv file in + Query.resolvePath ~env ~getModule ~path + |> Infix.logIfAbsent "Unable to resolve the path" ) ) + in + loop opens + +type k = + | Module of moduleKind + | Value of Types.type_expr + | Type of Type.t + | Constructor of constructor * Type.t declared + | Field of field * Type.t declared + | FileModule of string + +let kindToInt k = + match k with + | Module _ -> 9 + | FileModule _ -> 9 + | Constructor (_, _) -> 4 + | Field (_, _) -> 5 + | Type _ -> 22 + | Value _ -> 12 + +let detail name contents = + match contents with + | Type {decl} -> decl |> Shared.declToString name + | Value typ -> typ |> Shared.typeToString + | Module _ -> "module" + | FileModule _ -> "file module" + | Field ({typ}, t) -> + name ^ ": " + ^ (typ |> Shared.typeToString) + ^ "\n\n" + ^ (t.item.decl |> Shared.declToString t.name.txt) + | Constructor (c, t) -> + showConstructor c ^ "\n\n" ^ (t.item.decl |> Shared.declToString t.name.txt) + +let localValueCompletions ~pos ~(env : Query.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 -> + Module m) + @ ( completionForConstructors env.exported.types env.file.stamps.types + (* TODO declared thingsz *) + suffix + |> List.map (fun (c, t) -> + {(emptyDeclared c.cname.txt) with item = Constructor (c, t)}) ) + else results + in + let results = + if suffix = "" || not (isCapitalized suffix) then + results + @ completionForDeclareds ~pos env.file.stamps.values suffix (fun v -> + Value v) + @ completionForDeclareds ~pos env.file.stamps.types suffix (fun t -> + Type t) + @ ( completionForFields env.exported.types env.file.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)) + +let valueCompletions ~(env : Query.queryEnv) suffix = + Log.log (" - Completing in " ^ Uri2.toString env.file.uri); + let results = [] in + let results = + if suffix = "" || isCapitalized suffix then ( + (* Get rid of lowercase modules (#417) *) + env.exported.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 + 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 suffix + |> List.map (fun (c, t) -> + {(emptyDeclared c.cname.txt) with item = Constructor (c, t)}) ) ) + else results + in + let results = + 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 + (fun t -> Type t) + @ ( completionForFields env.exported.types env.file.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)) + +let attributeCompletions ~(env : Query.queryEnv) ~suffix = + let results = [] in + let results = + if suffix = "" || isCapitalized suffix then + results + @ completionForExporteds env.exported.modules env.file.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.exported.types, env.file.stamps.types, suffix, t => Type(t)) @ *) + @ ( completionForFields env.exported.types env.file.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)) + +(* TODO filter out things that are defined after the current position *) +let resolveRawOpens ~env ~getModule ~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 + in + opens + [@@ocaml.doc + "\n\nTODO filter out things that are defined after the current position\n\n"] + +let getItems ~full ~package ~rawOpens ~getModule ~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 packageOpens = "Pervasives" :: package.TopTypes.opens in + Log.log ("Package opens " ^ String.concat " " packageOpens); + let resolvedOpens = resolveRawOpens ~env ~getModule ~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)) ); + (* Last open takes priority *) + let opens = List.rev resolvedOpens in + match parts with + | [] -> [] + | [suffix] -> + let locallyDefinedValues = localValueCompletions ~pos ~env suffix in + let alreadyUsedIdentifiers = Hashtbl.create 10 in + let valuesFromOpens = + opens + |> List.fold_left + (fun results env -> + let completionsFromThisOpen = valueCompletions ~env suffix in + List.filter + (fun (_uri, declared) -> + if not (Hashtbl.mem alreadyUsedIdentifiers declared.name.txt) + then ( + Hashtbl.add alreadyUsedIdentifiers declared.name.txt true; + true ) + else false) + completionsFromThisOpen + @ results) + [] + in + (* TODO complete the namespaced name too *) + let localModuleNames = + allModules + |> Utils.filterMap (fun name -> + match + Utils.startsWith name suffix && not (String.contains name '-') + with + | true -> + Some + ( env.file.uri, + {(emptyDeclared name) with item = FileModule name} ) + | false -> None) + in + locallyDefinedValues @ valuesFromOpens @ localModuleNames + | multiple -> ( + Log.log ("Completing for " ^ String.concat "<.>" multiple); + match determineCompletion multiple with + | `Normal path -> ( + Log.log ("normal " ^ pathToString path); + match getEnvWithOpens ~pos ~env ~getModule ~opens path with + | Some (env, suffix) -> + Log.log "Got the env"; + valueCompletions ~env suffix + | None -> [] ) + | `Attribute (target, suffix) -> ( + Log.log ("suffix :" ^ suffix); + match target with + | [] -> [] + | first :: rest -> ( + Log.log ("-------------- Looking for " ^ first); + match Query.findInScope pos first env.file.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 + | None -> [] + | Some (env, typ) -> ( + match + rest + |> List.fold_left + (fun current name -> + match current with + | None -> None + | Some (env, typ) -> ( + match typ.item.SharedTypes.Type.kind with + | Record fields -> ( + match + fields + |> List.find_opt (fun f -> f.fname.txt = name) + with + | None -> None + | Some attr -> ( + Log.log ("Found attr " ^ name); + match attr.typ |> Shared.digConstructor with + | None -> None + | Some path -> + Hover.digConstructor ~env ~getModule path ) ) + | _ -> None )) + (Some (env, typ)) + with + | None -> [] + | Some (env, typ) -> ( + match typ.item.kind with + | Record fields -> + fields + |> Utils.filterMap (fun f -> + if Utils.startsWith f.fname.txt suffix then + Some + ( env.file.uri, + { + (emptyDeclared f.fname.txt) with + item = Field (f, typ); + } ) + else None) + | _ -> [] ) ) ) ) ) ) + | `AbsAttribute path -> ( + match getEnvWithOpens ~pos ~env ~getModule ~opens path with + | None -> [] + | Some (env, suffix) -> + attributeCompletions ~env ~suffix + @ List.concat + (opens |> List.map (fun env -> attributeCompletions ~env ~suffix)) ) + ) + +module J = JsonShort + +let mkItem ~name ~kind ~detail ~deprecated ~docstring ~uri ~pos_lnum = + let valueMessage = + (match deprecated with None -> "" | Some s -> "Deprecated: " ^ s ^ "\n\n") + ^ ( match docstring with + | [] -> "" + | _ :: _ -> (docstring |> String.concat "\n") ^ "\n\n" ) + ^ "\n" ^ Uri2.toString uri ^ ":" ^ string_of_int pos_lnum + in + let tags = match deprecated = None with true -> [] | false -> [J.i 1 (* deprecated *)] in + J.o + [ + ("label", J.s name); + ("kind", J.i kind); + ("tags", J.l tags); + ("detail", detail |> J.s); + ( "documentation", + J.o [("kind", J.s "markdown"); ("value", J.s valueMessage)] ); + ] + +let processCompletable ~findItems ~full ~package ~pos ~rawOpens + (completable : PartialParser.completable) = + match completable with + | Cjsx (componentPath, prefix) -> + let items = findItems ~exact:true (componentPath @ ["make"]) in + let labels = + match items with + | (_uri, {SharedTypes.item = Value typ}) :: _ -> + let rec getFields (texp : Types.type_expr) = + match texp.desc with + | Tfield (name, _, t1, t2) -> + let fields = t2 |> getFields in + (name, t1) :: fields + | Tlink te -> te |> getFields + | Tvar None -> [] + | _ -> [] + in + let rec getLabels (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 -> getLabels t1 + | Tarrow + ( Nolabel, + { + desc = + ( Tconstr (* Js.t *) (_, [{desc = Tobject (tObj, _)}], _) + | Tobject (tObj, _) ); + }, + _, + _ ) -> + getFields tObj + | _ -> [] + in + typ |> getLabels + | _ -> [] + in + let mkLabel_ name typString = + mkItem ~name ~kind:4 ~deprecated:None ~detail:typString ~docstring:[] + ~uri:full.file.uri ~pos_lnum:(fst pos) + in + let mkLabel (name, typ) = mkLabel_ name (typ |> Shared.typeToString) in + let keyLabel = mkLabel_ "key" "string" in + if labels = [] then [] + else + keyLabel + :: ( labels + |> List.filter (fun (name, _t) -> Utils.startsWith name prefix) + |> List.map mkLabel ) + | Cpath parts -> + let items = parts |> findItems ~exact:false in + (* TODO(#107): figure out why we're getting duplicates. *) + items |> Utils.dedup + |> List.map + (fun + ( uri, + { + SharedTypes.name = {txt = name; loc = {loc_start = {pos_lnum}}}; + deprecated; + docstring; + item; + } ) + -> + mkItem ~name ~kind:(kindToInt item) ~deprecated + ~detail:(detail name item) ~docstring ~uri ~pos_lnum) + | Cpipe s -> ( + let getLhsType ~lhs ~partialName = + match [lhs] |> findItems ~exact:true with + | (_uri, {SharedTypes.item = Value t}) :: _ -> Some (t, partialName) + | _ -> None + in + let lhsType = + match Str.split (Str.regexp_string "->") s with + | [lhs] -> getLhsType ~lhs ~partialName:"" + | [lhs; partialName] -> getLhsType ~lhs ~partialName + | _ -> + (* Only allow one -> *) + None + in + let removePackageOpens modulePath = + match modulePath with + | toplevel :: rest when package.TopTypes.opens |> List.mem toplevel -> + rest + | _ -> modulePath + in + let rec removeRawOpen rawOpen modulePath = + match (rawOpen, modulePath) with + | Tip _, _ -> Some modulePath + | Nested (s, inner), first :: restPath when s = first -> + removeRawOpen inner restPath + | _ -> None + in + let rec removeRawOpens rawOpens modulePath = + match rawOpens with + | rawOpen :: restOpens -> + let newModulePath = + match removeRawOpen rawOpen modulePath with + | None -> modulePath + | Some newModulePath -> newModulePath + in + removeRawOpens restOpens newModulePath + | [] -> modulePath + in + match lhsType with + | Some (t, partialName) -> ( + let getModulePath path = + let rec loop (path : Path.t) = + match path with + | Pident id -> [Ident.name id] + | Pdot (p, s, _) -> s :: loop p + | Papply _ -> [] + in + match loop path with _ :: rest -> List.rev rest | [] -> [] + in + let modulePath = + match t.desc with + | Tconstr (path, _, _) -> getModulePath path + | Tlink {desc = Tconstr (path, _, _)} -> getModulePath path + | _ -> [] + in + match modulePath with + | _ :: _ -> + let modulePathMinusOpens = + modulePath |> removePackageOpens |> removeRawOpens rawOpens + |> String.concat "." + in + let completionName name = + match modulePathMinusOpens = "" with + | true -> name + | false -> modulePathMinusOpens ^ "." ^ name + in + let parts = modulePath @ [partialName] in + let items = parts |> findItems ~exact:false in + items + |> List.filter (fun (_, {item}) -> + match item with Value _ -> true | _ -> false) + |> List.map + (fun + ( uri, + { + SharedTypes.name = + {txt = name; loc = {loc_start = {pos_lnum}}}; + deprecated; + docstring; + item; + } ) + -> + mkItem ~name:(completionName name) ~kind:(kindToInt item) + ~detail:(detail name item) ~deprecated ~docstring ~uri + ~pos_lnum) + | _ -> [] ) + | None -> [] ) + | Cdecorator prefix -> + let mkDecorator name = + mkItem ~name ~kind:4 ~deprecated:None ~detail:"" ~docstring:[] + ~uri:full.file.uri ~pos_lnum:(fst pos) + in + [ + "as"; + "deriving"; + "genType"; + "genType.as"; + "genType.import"; + "genType.opaque"; + "get"; + "get_index"; + "inline"; + "int"; + "meth"; + "module"; + "new"; + "obj"; + "react.component"; + "return"; + "scope"; + "send"; + "set"; + "set_index"; + "string"; + "this"; + "unboxed"; + "uncurry"; + "unwrap"; + "val"; + "variadic"; + ] + |> List.filter (fun decorator -> Utils.startsWith decorator prefix) + |> List.map mkDecorator + | Clabel (funPath, prefix) -> + let labels = + match funPath |> findItems ~exact:true with + | (_uri, {SharedTypes.item = Value typ}) :: _ -> + let rec getLabels (t : Types.type_expr) = + match t.desc with + | Tlink t1 | Tsubst t1 -> getLabels t1 + | Tarrow ((Labelled l | Optional l), tArg, tRet, _) -> + (l, tArg) :: getLabels tRet + | Tarrow (Nolabel, _, tRet, _) -> getLabels tRet + | _ -> [] + in + typ |> getLabels + | _ -> [] + in + let mkLabel (name, typ) = + mkItem ~name ~kind:4 ~deprecated:None + ~detail:(typ |> Shared.typeToString) + ~docstring:[] ~uri:full.file.uri ~pos_lnum:(fst pos) + in + labels + |> List.filter (fun (name, _t) -> Utils.startsWith name prefix) + |> List.map mkLabel + +let computeCompletions ~full ~maybeText ~package ~pos ~state = + let items = + match maybeText with + | None -> [] + | Some text -> ( + match PartialParser.positionToOffset text pos with + | None -> [] + | Some offset -> ( + match PartialParser.findCompletable text offset with + | None -> [] + | Some completable -> + let rawOpens = PartialParser.findOpens text offset in + let allModules = + package.TopTypes.localModules @ package.dependencyModules + in + let findItems ~exact parts = + let items = + getItems ~full ~package ~rawOpens + ~getModule:(State.fileForModule state ~package) + ~allModules ~pos ~parts + in + match parts |> List.rev with + | last :: _ when exact -> + items + |> List.filter (fun (_uri, {SharedTypes.name = {txt}}) -> + txt = last) + | _ -> items + in + completable + |> processCompletable ~findItems ~full ~package ~pos ~rawOpens ) ) + in + if items = [] then J.null else items |> J.l diff --git a/src/NewCompletions.re b/src/NewCompletions.re deleted file mode 100644 index 46932c54..00000000 --- a/src/NewCompletions.re +++ /dev/null @@ -1,963 +0,0 @@ -open SharedTypes; - -let showConstructor = ({cname: {txt}, args, res}) => { - open Infix; - txt - ++ ( - args == [] - ? "" - : "(" - ++ String.concat( - ", ", - args |> List.map(((typ, _)) => typ |> Shared.typeToString), - ) - ++ ")" - ) - ++ (res |?>> (typ => "\n" ++ (typ |> Shared.typeToString)) |? ""); -}; - -/* TODO local opens */ -let resolveOpens = (~env, ~previous, opens, ~getModule) => - List.fold_left( - (previous, path) => { - /** Finding an open, first trying to find it in previoulsly resolved opens */ - let rec loop = prev => - switch (prev) { - | [] => - switch (path) { - | Tip(_) => previous - | Nested(name, path) => - switch (getModule(name)) { - | None => - Log.log("Could not get module " ++ name); - previous; /* TODO warn? */ - | Some(file) => - switch ( - Query.resolvePath( - ~env=Query.fileEnv(file), - ~getModule, - ~path, - ) - ) { - | None => - Log.log("Could not resolve in " ++ name); - previous; - | Some((env, _placeholder)) => previous @ [env] - } - } - } - | [env, ...rest] => - switch (Query.resolvePath(~env, ~getModule, ~path)) { - | None => loop(rest) - | Some((env, _placeholder)) => previous @ [env] - } - }; - Log.log("resolving open " ++ pathToString(path)); - switch (Query.resolvePath(~env, ~getModule, ~path)) { - | None => - Log.log("Not local"); - loop(previous); - | Some((env, _)) => - Log.log("Was local"); - previous @ [env]; - }; - }, - /* loop(previous) */ - previous, - opens, - ); - -let completionForDeclareds = (~pos, declareds, prefix, transformContents) => - /* Log.log("complete for declares " ++ prefix); */ - Hashtbl.fold( - (_stamp, declared, results) => - if (Utils.startsWith(declared.name.txt, prefix) - && Utils.locationContainsFuzzy(declared.scopeLoc, pos)) { - [{...declared, item: transformContents(declared.item)}, ...results]; - } else { - /* Log.log("Nope doesn't count " ++ Utils.showLocation(declared.scopeLoc) ++ " " ++ m); */ - results; - }, - declareds, - [], - ); - -let completionForExporteds = - ( - exporteds, - stamps: Hashtbl.t(int, SharedTypes.declared('a)), - prefix, - transformContents, - ) => - Hashtbl.fold( - (name, stamp, results) => - /* Log.log("checking exported: " ++ name); */ - if (Utils.startsWith(name, prefix)) { - let declared = Hashtbl.find(stamps, stamp); - [{...declared, item: transformContents(declared.item)}, ...results]; - } else { - results; - }, - exporteds, - [], - ); - -let completionForConstructors = - ( - exportedTypes, - stamps: Hashtbl.t(int, SharedTypes.declared(SharedTypes.Type.t)), - prefix, - ) => { - Hashtbl.fold( - (_name, stamp, results) => { - let t = Hashtbl.find(stamps, stamp); - switch (t.item.kind) { - | SharedTypes.Type.Variant(constructors) => - { - constructors - |> List.filter(c => Utils.startsWith(c.cname.txt, prefix)) - |> List.map(c => (c, t)); - } - @ results - | _ => results - }; - }, - exportedTypes, - [], - ); -}; - -let completionForFields = - ( - exportedTypes, - stamps: Hashtbl.t(int, SharedTypes.declared(SharedTypes.Type.t)), - prefix, - ) => - Hashtbl.fold( - (_name, stamp, results) => { - let t = Hashtbl.find(stamps, stamp); - switch (t.item.kind) { - | Record(fields) => - ( - fields - |> List.filter(f => Utils.startsWith(f.fname.txt, prefix)) - |> List.map(f => (f, t)) - ) - @ results - | _ => results - }; - }, - exportedTypes, - [], - ); - -let isCapitalized = name => - if (name == "") { - false; - } else { - let c = name.[0]; - switch (c) { - | 'A'..'Z' => true - | _ => false - }; - }; - -let determineCompletion = items => { - let rec loop = (offset, items) => - switch (items) { - | [] => assert(false) - | [one] => `Normal(Tip(one)) - | [one, two] when !isCapitalized(one) => `Attribute(([one], two)) - | [one, two] => `Normal(Nested(one, Tip(two))) - | [one, ...rest] => - if (isCapitalized(one)) { - switch (loop(offset + String.length(one) + 1, rest)) { - | `Normal(path) => `Normal(Nested(one, path)) - | x => x - }; - } else { - switch (loop(offset + String.length(one) + 1, rest)) { - | `Normal(path) => `AbsAttribute(path) - | `Attribute(path, suffix) => `Attribute(([one, ...path], suffix)) - | x => x - }; - } - }; - loop(0, items); -}; - -/* Note: This is a hack. It will be wrong some times if you have a local thing - that overrides an open. - - 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: list(Query.queryEnv), - path, - ) => - /* Query.resolvePath(~env, ~path, ~getModule) */ - switch (Query.resolveFromStamps(~env, ~path, ~getModule, ~pos)) { - | Some(x) => Some(x) - | None => - let rec loop = opens => - switch (opens) { - | [env, ...rest] => - Log.log("Looking for env in " ++ Uri2.toString(env.Query.file.uri)); - switch (Query.resolvePath(~env, ~getModule, ~path)) { - | Some(x) => Some(x) - | None => loop(rest) - }; - | [] => - switch (path) { - | Tip(_) => None - | Nested(top, path) => - Log.log("Getting module " ++ top); - switch (getModule(top)) { - | None => None - | Some(file) => - Log.log("got it"); - let env = Query.fileEnv(file); - Query.resolvePath(~env, ~getModule, ~path) - |> Infix.logIfAbsent("Unable to resolve the path"); - }; - } - }; - loop(opens); - }; - -type k = - | Module(moduleKind) - | Value(Types.type_expr) - | Type(Type.t) - | Constructor(constructor, declared(Type.t)) - | Field(field, declared(Type.t)) - | FileModule(string); - -let kindToInt = k => - switch (k) { - | Module(_) => 9 - | FileModule(_) => 9 - | Constructor(_, _) => 4 - | Field(_, _) => 5 - | Type(_) => 22 - | Value(_) => 12 - }; - -let detail = (name, contents) => - switch (contents) { - | Type({decl}) => decl |> Shared.declToString(name) - | Value(typ) => typ |> Shared.typeToString - | Module(_) => "module" - | FileModule(_) => "file module" - | Field({typ}, t) => - name - ++ ": " - ++ (typ |> Shared.typeToString) - ++ "\n\n" - ++ (t.item.decl |> Shared.declToString(t.name.txt)) - | Constructor(c, t) => - showConstructor(c) - ++ "\n\n" - ++ (t.item.decl |> Shared.declToString(t.name.txt)) - }; - -let localValueCompletions = (~pos, ~env: Query.queryEnv, suffix) => { - let results = []; - Log.log("---------------- LOCAL VAL"); - let results = - if (suffix == "" || isCapitalized(suffix)) { - results - @ completionForDeclareds(~pos, env.file.stamps.modules, suffix, m => - Module(m) - ) - @ ( - /* TODO declared thingsz */ - completionForConstructors( - env.exported.types, - env.file.stamps.types, - suffix, - ) - |> List.map(((c, t)) => - {...emptyDeclared(c.cname.txt), item: Constructor(c, t)} - ) - ); - } else { - results; - }; - - let results = - if (suffix == "" || !isCapitalized(suffix)) { - results - @ completionForDeclareds(~pos, env.file.stamps.values, suffix, v => - Value(v) - ) - @ completionForDeclareds(~pos, env.file.stamps.types, suffix, t => - Type(t) - ) - @ ( - completionForFields(env.exported.types, env.file.stamps.types, suffix) - |> List.map(((f, t)) => - {...emptyDeclared(f.fname.txt), item: Field(f, t)} - ) - ); - } else { - results; - }; - - results |> List.map(x => (env.file.uri, x)); -}; - -let valueCompletions = (~env: Query.queryEnv, suffix) => { - Log.log(" - Completing in " ++ Uri2.toString(env.file.uri)); - let results = []; - let results = - if (suffix == "" || isCapitalized(suffix)) { - // Get rid of lowercase modules (#417) - env.exported.modules - |> Hashtbl.filter_map_inplace((name, key) => - isCapitalized(name) ? Some(key) : None - ); - - let moduleCompletions = - completionForExporteds( - env.exported.modules, env.file.stamps.modules, suffix, m => - Module(m) - ); - /* 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, - suffix, - ) - |> List.map(((c, t)) => - {...emptyDeclared(c.cname.txt), item: Constructor(c, t)} - ) - ); - } else { - results; - }; - - let results = - if (suffix == "" || !isCapitalized(suffix)) { - Log.log(" -- not capitalized"); - results - @ completionForExporteds( - env.exported.values, env.file.stamps.values, suffix, v => - Value(v) - ) - @ completionForExporteds( - env.exported.types, env.file.stamps.types, suffix, t => - Type(t) - ) - @ ( - completionForFields(env.exported.types, env.file.stamps.types, suffix) - |> List.map(((f, t)) => - {...emptyDeclared(f.fname.txt), item: Field(f, t)} - ) - ); - } else { - results; - }; - - /* Log.log("Getting value completions " ++ env.file.uri); - Log.log(String.concat(", ", results |. Belt.List.map(x => x.name.txt))); */ - - results |> List.map(x => (env.file.uri, x)); -}; - -let attributeCompletions = (~env: Query.queryEnv, ~suffix) => { - let results = []; - let results = - if (suffix == "" || isCapitalized(suffix)) { - results - @ completionForExporteds( - env.exported.modules, env.file.stamps.modules, suffix, m => - Module(m) - ); - } else { - results; - }; - - let results = - if (suffix == "" || !isCapitalized(suffix)) { - results - @ completionForExporteds( - env.exported.values, env.file.stamps.values, suffix, v => - Value(v) - ) - /* completionForExporteds(env.exported.types, env.file.stamps.types, suffix, t => Type(t)) @ */ - @ ( - completionForFields(env.exported.types, env.file.stamps.types, suffix) - |> List.map(((f, t)) => - {...emptyDeclared(f.fname.txt), item: Field(f, t)} - ) - ); - } else { - results; - }; - - results |> List.map(x => (env.file.uri, x)); -}; - -/** - -TODO filter out things that are defined after the current position - -*/ - -let resolveRawOpens = (~env, ~getModule, ~rawOpens, ~package) => { - // TODO Stdlib instead of Pervasives - let packageOpens = ["Pervasives", ...package.TopTypes.opens]; - Log.log("Package opens " ++ String.concat(" ", packageOpens)); - - let opens = - resolveOpens( - ~env, - ~previous= - List.map(Query.fileEnv, packageOpens |> Utils.filterMap(getModule)), - rawOpens, - ~getModule, - ); - - opens; -}; - -let getItems = - (~full, ~package, ~rawOpens, ~getModule, ~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); - - let packageOpens = ["Pervasives", ...package.TopTypes.opens]; - Log.log("Package opens " ++ String.concat(" ", packageOpens)); - - let resolvedOpens = resolveRawOpens(~env, ~getModule, ~rawOpens, ~package); - Log.log( - "Opens nows " - ++ string_of_int(List.length(resolvedOpens)) - ++ " " - ++ String.concat( - " ", - resolvedOpens |> List.map(e => Uri2.toString(e.Query.file.uri)), - ), - ); - - // Last open takes priority - let opens = List.rev(resolvedOpens); - - switch (parts) { - | [] => [] - | [suffix] => - let locallyDefinedValues = localValueCompletions(~pos, ~env, suffix); - let alreadyUsedIdentifiers = Hashtbl.create(10); - let valuesFromOpens = - opens - |> List.fold_left( - (results, env) => { - let completionsFromThisOpen = valueCompletions(~env, suffix); - List.filter( - ((_uri, declared)) => - if (!Hashtbl.mem(alreadyUsedIdentifiers, declared.name.txt)) { - Hashtbl.add( - alreadyUsedIdentifiers, - declared.name.txt, - true, - ); - true; - } else { - false; - }, - completionsFromThisOpen, - ) - @ results; - }, - [], - ); - /* TODO complete the namespaced name too */ - let localModuleNames = - allModules - |> Utils.filterMap(name => - Utils.startsWith(name, suffix) && !String.contains(name, '-') - ? Some(( - env.file.uri, - {...emptyDeclared(name), item: FileModule(name)}, - )) - : None - ); - locallyDefinedValues @ valuesFromOpens @ localModuleNames; - | multiple => - Log.log("Completing for " ++ String.concat("<.>", multiple)); - - switch (determineCompletion(multiple)) { - | `Normal(path) => - Log.log("normal " ++ pathToString(path)); - switch (getEnvWithOpens(~pos, ~env, ~getModule, ~opens, path)) { - | Some((env, suffix)) => - Log.log("Got the env"); - valueCompletions(~env, suffix); - | None => [] - }; - | `Attribute(target, suffix) => - { - Log.log("suffix :" ++ suffix); - switch (target) { - | [] => [] - | [first, ...rest] => - Log.log("-------------- Looking for " ++ first); - switch (Query.findInScope(pos, first, env.file.stamps.values)) { - | None => [] - | Some(declared) => - Log.log("Found it! " ++ declared.name.txt); - switch (declared.item |> Shared.digConstructor) { - | None => [] - | Some(path) => - switch (Hover.digConstructor(~env, ~getModule, path)) { - | None => [] - | Some((env, typ)) => - switch ( - rest - |> List.fold_left( (current, name) => - switch (current) { - | None => None - | Some((env, typ)) => - switch (typ.item.SharedTypes.Type.kind) { - | Record(fields) => - switch ( - fields - |> List.find_opt(f => f.fname.txt == name) - ) { - | None => None - | Some(attr) => - Log.log("Found attr " ++ name); - switch (attr.typ |> Shared.digConstructor) { - | None => None - | Some(path) => - Hover.digConstructor(~env, ~getModule, path) - }; - } - | _ => None - } - }, - Some((env, typ)), - ) - ) { - | None => [] - | Some((env, typ)) => - switch (typ.item.kind) { - | Record(fields) => - fields |> Utils.filterMap(f => - if (Utils.startsWith(f.fname.txt, suffix)) { - Some(( - env.file.uri, - {...emptyDeclared(f.fname.txt), item: Field(f, typ)}, - )); - } else { - None; - } - ) - | _ => [] - } - } - } - }; - }; - }; - } - | `AbsAttribute(path) => - switch (getEnvWithOpens(~pos, ~env, ~getModule, ~opens, path)) { - | None => [] - | Some((env, suffix)) => - attributeCompletions(~env, ~suffix) - @ List.concat( - opens |> List.map(env => attributeCompletions(~env, ~suffix)), - ) - } - }; - }; -}; - -module J = JsonShort; - -let mkItem = (~name, ~kind, ~detail, ~deprecated, ~docstring, ~uri, ~pos_lnum) => { - let valueMessage = - ( - switch (deprecated) { - | None => "" - | Some(s) => "Deprecated: " ++ s ++ "\n\n" - } - ) - ++ ( - switch (docstring) { - | [] => "" - | [_, ..._] => (docstring |> String.concat("\n")) ++ "\n\n" - } - ) - ++ "\n" - ++ Uri2.toString(uri) - ++ ":" - ++ string_of_int(pos_lnum); - let tags = deprecated == None ? [] : [J.i(1 /* deprecated */)]; - J.o([ - ("label", J.s(name)), - ("kind", J.i(kind)), - ("tags", J.l(tags)), - ("detail", detail |> J.s), - ( - "documentation", - J.o([("kind", J.s("markdown")), ("value", J.s(valueMessage))]), - ), - ]); -}; - -let processCompletable = - ( - ~findItems, - ~full, - ~package, - ~pos, - ~rawOpens, - completable: PartialParser.completable, - ) => - switch (completable) { - | Cjsx(componentPath, prefix) => - let items = findItems(~exact=true, componentPath @ ["make"]); - let labels = { - switch (items) { - | [(_uri, {SharedTypes.item: Value(typ)}), ..._] => - let rec getFields = (texp: Types.type_expr) => - switch (texp.desc) { - | Tfield(name, _, t1, t2) => - let fields = t2 |> getFields; - [(name, t1), ...fields]; - - | Tlink(te) => te |> getFields - | Tvar(None) => [] - | _ => [] - }; - let rec getLabels = (t: Types.type_expr) => - switch (t.desc) { - | Tlink(t1) - | Tsubst(t1) => getLabels(t1) - | Tarrow( - Nolabel, - { - desc: - Tconstr /* Js.t */(_, [{desc: Tobject(tObj, _)}], _) | - Tobject(tObj, _), - }, - _, - _, - ) => - getFields(tObj) - | _ => [] - }; - typ |> getLabels; - | _ => [] - }; - }; - - let mkLabel_ = (name, typString) => - mkItem( - ~name, - ~kind=4, - ~deprecated=None, - ~detail=typString, - ~docstring=[], - ~uri=full.file.uri, - ~pos_lnum=fst(pos), - ); - let mkLabel = ((name, typ)) => - mkLabel_(name, typ |> Shared.typeToString); - let keyLabel = mkLabel_("key", "string"); - - if (labels == []) { - []; - } else { - [ - keyLabel, - ...labels - |> List.filter(((name, _t)) => Utils.startsWith(name, prefix)) - |> List.map(mkLabel), - ]; - }; - - | Cpath(parts) => - let items = parts |> findItems(~exact=false); - /* TODO(#107): figure out why we're getting duplicates. */ - items - |> Utils.dedup - |> List.map( - ( - ( - uri, - { - SharedTypes.name: {txt: name, loc: {loc_start: {pos_lnum}}}, - deprecated, - docstring, - item, - }, - ), - ) => - mkItem( - ~name, - ~kind=kindToInt(item), - ~deprecated, - ~detail=detail(name, item), - ~docstring, - ~uri, - ~pos_lnum, - ) - ); - - | Cpipe(s) => - let getLhsType = (~lhs, ~partialName) => { - switch ([lhs] |> findItems(~exact=true)) { - | [(_uri, {SharedTypes.item: Value(t)}), ..._] => - Some((t, partialName)) - | _ => None - }; - }; - - let lhsType = - switch (Str.split(Str.regexp_string("->"), s)) { - | [lhs] => getLhsType(~lhs, ~partialName="") - | [lhs, partialName] => getLhsType(~lhs, ~partialName) - | _ => - // Only allow one -> - None - }; - - let removePackageOpens = modulePath => - switch (modulePath) { - | [toplevel, ...rest] when package.TopTypes.opens |> List.mem(toplevel) => rest - | _ => modulePath - }; - - let rec removeRawOpen = (rawOpen, modulePath) => - switch (rawOpen, modulePath) { - | (Tip(_), _) => Some(modulePath) - | (Nested(s, inner), [first, ...restPath]) when s == first => - removeRawOpen(inner, restPath) - | _ => None - }; - - let rec removeRawOpens = (rawOpens, modulePath) => - switch (rawOpens) { - | [rawOpen, ...restOpens] => - let newModulePath = - switch (removeRawOpen(rawOpen, modulePath)) { - | None => modulePath - | Some(newModulePath) => newModulePath - }; - removeRawOpens(restOpens, newModulePath); - | [] => modulePath - }; - - switch (lhsType) { - | Some((t, partialName)) => - let getModulePath = path => { - let rec loop = (path: Path.t) => - switch (path) { - | Pident(id) => [Ident.name(id)] - | Pdot(p, s, _) => [s, ...loop(p)] - | Papply(_) => [] - }; - switch (loop(path)) { - | [_, ...rest] => List.rev(rest) - | [] => [] - }; - }; - let modulePath = - switch (t.desc) { - | Tconstr(path, _, _) => getModulePath(path) - | Tlink({desc: Tconstr(path, _, _)}) => getModulePath(path) - | _ => [] - }; - switch (modulePath) { - | [_, ..._] => - let modulePathMinusOpens = - modulePath - |> removePackageOpens - |> removeRawOpens(rawOpens) - |> String.concat("."); - let completionName = name => - modulePathMinusOpens == "" - ? name : modulePathMinusOpens ++ "." ++ name; - let parts = modulePath @ [partialName]; - let items = parts |> findItems(~exact=false); - items - |> List.filter(((_, {item})) => - switch (item) { - | Value(_) => true - | _ => false - } - ) - |> List.map( - ( - ( - uri, - { - SharedTypes.name: { - txt: name, - loc: {loc_start: {pos_lnum}}, - }, - deprecated, - docstring, - item, - }, - ), - ) => - mkItem( - ~name=completionName(name), - ~kind=kindToInt(item), - ~detail=detail(name, item), - ~deprecated, - ~docstring, - ~uri, - ~pos_lnum, - ) - ); - - | _ => [] - }; - | None => [] - }; - - | Cdecorator(prefix) => - let mkDecorator = name => - mkItem( - ~name, - ~kind=4, - ~deprecated=None, - ~detail="", - ~docstring=[], - ~uri=full.file.uri, - ~pos_lnum=fst(pos), - ); - [ - "as", - "deriving", - "genType", - "genType.as", - "genType.import", - "genType.opaque", - "get", - "get_index", - "inline", - "int", - "meth", - "module", - "new", - "obj", - "react.component", - "return", - "scope", - "send", - "set", - "set_index", - "string", - "this", - "unboxed", - "uncurry", - "unwrap", - "val", - "variadic", - ] - |> List.filter(decorator => Utils.startsWith(decorator, prefix)) - |> List.map(mkDecorator); - - | Clabel(funPath, prefix) => - let labels = { - switch (funPath |> findItems(~exact=true)) { - | [(_uri, {SharedTypes.item: Value(typ)}), ..._] => - let rec getLabels = (t: Types.type_expr) => - switch (t.desc) { - | Tlink(t1) - | Tsubst(t1) => getLabels(t1) - | Tarrow(Labelled(l) | Optional(l), tArg, tRet, _) => [ - (l, tArg), - ...getLabels(tRet), - ] - | Tarrow(Nolabel, _, tRet, _) => getLabels(tRet) - | _ => [] - }; - typ |> getLabels; - | _ => [] - }; - }; - - let mkLabel = ((name, typ)) => - mkItem( - ~name, - ~kind=4, - ~deprecated=None, - ~detail=typ |> Shared.typeToString, - ~docstring=[], - ~uri=full.file.uri, - ~pos_lnum=fst(pos), - ); - - labels - |> List.filter(((name, _t)) => Utils.startsWith(name, prefix)) - |> List.map(mkLabel); - }; - -let computeCompletions = (~full, ~maybeText, ~package, ~pos, ~state) => { - let items = - switch (maybeText) { - | None => [] - | Some(text) => - switch (PartialParser.positionToOffset(text, pos)) { - | None => [] - | Some(offset) => - switch (PartialParser.findCompletable(text, offset)) { - | None => [] - | Some(completable) => - let rawOpens = PartialParser.findOpens(text, offset); - let allModules = - package.TopTypes.localModules @ package.dependencyModules; - let findItems = (~exact, parts) => { - let items = - getItems( - ~full, - ~package, - ~rawOpens, - ~getModule=State.fileForModule(state, ~package), - ~allModules, - ~pos, - ~parts, - ); - switch (parts |> List.rev) { - | [last, ..._] when exact => - items - |> List.filter(((_uri, {SharedTypes.name: {txt}})) => - txt == last - ) - | _ => items - }; - }; - completable - |> processCompletable(~findItems, ~full, ~package, ~pos, ~rawOpens); - } - } - }; - if (items == []) { - J.null; - } else { - items |> J.l; - }; -}; diff --git a/src/Packages.ml b/src/Packages.ml new file mode 100644 index 00000000..7ec1636d --- /dev/null +++ b/src/Packages.ml @@ -0,0 +1,153 @@ +open Infix +open TopTypes + +let escapePreprocessingFlags flag = + (* ppx escaping not supported on windows yet *) + if Sys.os_type = "Win32" then flag + else + let parts = Utils.split_on_char ' ' flag in + match parts with + | (("-ppx" | "-pp") as flag) :: rest -> + flag ^ " " ^ Utils.maybeQuoteFilename (String.concat " " rest) + | _ -> flag + +(* Creates the `pathsForModule` hashtbl, which maps a `moduleName` to it's `paths` (the ml/re, mli/rei, cmt, and cmti files) *) +let makePathsForModule (localModules : (string * SharedTypes.paths) list) + (dependencyModules : (string * SharedTypes.paths) list) = + let pathsForModule = Hashtbl.create 30 in + dependencyModules + |> List.iter (fun (modName, paths) -> Hashtbl.replace pathsForModule modName paths); + localModules + |> List.iter (fun (modName, paths) -> Hashtbl.replace pathsForModule modName paths); + pathsForModule + +let newBsPackage rootPath = + match Files.readFileResult (rootPath /+ "bsconfig.json") with + | Error e -> Error e + | Ok raw -> ( + let config = Json.parse raw in + Log.log {|📣 📣 NEW BSB PACKAGE 📣 📣|}; + (* failwith("Wat"); *) + Log.log ("- location: " ^ rootPath); + let compiledBase = BuildSystem.getCompiledBase rootPath in + match FindFiles.findDependencyFiles ~debug:true rootPath config with + | Error e -> Error e + | Ok (dependencyDirectories, dependencyModules) -> ( + match + compiledBase + |> RResult.orError + "You need to run bsb first so that reason-language-server can \ + access the compiled artifacts.\n\ + Once you've run bsb, restart the language server." + with + | Error e -> Error e + | Ok compiledBase -> + Ok + (let namespace = FindFiles.getNamespace config in + let localSourceDirs = + FindFiles.getSourceDirectories ~includeDev:true rootPath config + in + Log.log + ("Got source directories " ^ String.concat " - " localSourceDirs); + let localModules = + FindFiles.findProjectFiles ~debug:true namespace rootPath + localSourceDirs compiledBase + (* + |> List.map(((name, paths)) => (switch (namespace) { + | None => name + | Some(n) => name ++ "-" ++ n }, paths)); *) + in + Log.log + ( "-- All local modules found: " + ^ string_of_int (List.length localModules) ); + localModules + |> List.iter (fun (name, paths) -> + Log.log name; + match paths with + | SharedTypes.Impl (cmt, _) -> Log.log ("impl " ^ cmt) + | Intf (cmi, _) -> Log.log ("intf " ^ cmi) + | _ -> Log.log "Both"); + let pathsForModule = + makePathsForModule localModules dependencyModules + in + let opens = + match namespace with + | None -> [] + | Some namespace -> + let cmt = (compiledBase /+ namespace) ^ ".cmt" in + Log.log ("############ Namespaced as " ^ namespace ^ " at " ^ cmt); + Hashtbl.add pathsForModule namespace (Impl (cmt, None)); + [FindFiles.nameSpaceToName namespace] + in + Log.log ("Dependency dirs " ^ String.concat " " dependencyDirectories); + let opens = + let flags = + MerlinFile.getFlags rootPath + |> RResult.withDefault [""] + |> List.map escapePreprocessingFlags + in + let opens = + List.fold_left + (fun opens item -> + let parts = Utils.split_on_char ' ' item in + let rec loop items = + match items with + | "-open" :: name :: rest -> name :: loop rest + | _ :: rest -> loop rest + | [] -> [] + in + opens @ loop parts) + opens flags + in + opens + in + let interModuleDependencies = + Hashtbl.create (List.length localModules) + in + { + rootPath; + localModules = localModules |> List.map fst; + dependencyModules = dependencyModules |> List.map fst; + pathsForModule; + opens; + namespace; + interModuleDependencies; + }) ) ) + +let findRoot ~uri packagesByRoot = + let path = Uri2.toPath uri in + let rec loop path = + if path = "/" then None + else if Hashtbl.mem packagesByRoot path then Some (`Root path) + else if Files.exists (path /+ "bsconfig.json") then Some (`Bs path) + else loop (Filename.dirname path) + in + loop (Filename.dirname path) + +let getPackage ~uri state = + if Hashtbl.mem state.rootForUri uri then + Ok (Hashtbl.find state.packagesByRoot (Hashtbl.find state.rootForUri uri)) + else + match + findRoot ~uri state.packagesByRoot + |> RResult.orError "No root directory found" + with + | Error e -> Error e + | Ok root -> ( + match + match root with + | `Root rootPath -> + Hashtbl.replace state.rootForUri uri rootPath; + Ok + (Hashtbl.find state.packagesByRoot + (Hashtbl.find state.rootForUri uri)) + | `Bs rootPath -> ( + match newBsPackage rootPath with + | Error e -> Error e + | Ok package -> + Hashtbl.replace state.rootForUri uri package.rootPath; + Hashtbl.replace state.packagesByRoot package.rootPath package; + Ok package ) + with + | Error e -> Error e + | Ok package -> Ok package ) diff --git a/src/Packages.re b/src/Packages.re deleted file mode 100644 index 7f75eb62..00000000 --- a/src/Packages.re +++ /dev/null @@ -1,213 +0,0 @@ -open Infix; -open TopTypes; - -let escapePreprocessingFlags = flag => - /* ppx escaping not supported on windows yet */ - if (Sys.os_type == "Win32") { - flag; - } else { - let parts = Utils.split_on_char(' ', flag); - switch (parts) { - | [("-ppx" | "-pp") as flag, ...rest] => - flag ++ " " ++ Utils.maybeQuoteFilename(String.concat(" ", rest)) - | _ => flag - }; - }; - -/** - * Creates the `pathsForModule` hashtbl, which maps a `moduleName` to it's `paths` (the ml/re, mli/rei, cmt, and cmti files) - */ -let makePathsForModule = - ( - localModules: list((string, SharedTypes.paths)), - dependencyModules: list((string, SharedTypes.paths)), - ) => { - let pathsForModule = Hashtbl.create(30); - - dependencyModules - |> List.iter(((modName, paths)) => { - Hashtbl.replace(pathsForModule, modName, paths) - }); - - localModules - |> List.iter(((modName, paths)) => { - Hashtbl.replace(pathsForModule, modName, paths) - }); - - pathsForModule; -}; - -let newBsPackage = rootPath => - switch (Files.readFileResult(rootPath /+ "bsconfig.json")) { - | Error(e) => Error(e) - | Ok(raw) => - let config = Json.parse(raw); - - Log.log({|📣 📣 NEW BSB PACKAGE 📣 📣|}); - /* failwith("Wat"); */ - Log.log("- location: " ++ rootPath); - - let compiledBase = BuildSystem.getCompiledBase(rootPath); - switch (FindFiles.findDependencyFiles(~debug=true, rootPath, config)) { - | Error(e) => Error(e) - | Ok((dependencyDirectories, dependencyModules)) => - switch ( - compiledBase - |> RResult.orError( - "You need to run bsb first so that reason-language-server can access the compiled artifacts.\nOnce you've run bsb, restart the language server.", - ) - ) { - | Error(e) => Error(e) - | Ok(compiledBase) => - Ok( - { - let namespace = FindFiles.getNamespace(config); - let localSourceDirs = - FindFiles.getSourceDirectories( - ~includeDev=true, - rootPath, - config, - ); - Log.log( - "Got source directories " - ++ String.concat(" - ", localSourceDirs), - ); - let localModules = - FindFiles.findProjectFiles( - ~debug=true, - namespace, - rootPath, - localSourceDirs, - compiledBase, - ); - /* |> List.map(((name, paths)) => (switch (namespace) { - | None => name - | Some(n) => name ++ "-" ++ n }, paths)); */ - Log.log( - "-- All local modules found: " - ++ string_of_int(List.length(localModules)), - ); - localModules - |> List.iter(((name, paths)) => { - Log.log(name); - switch (paths) { - | SharedTypes.Impl(cmt, _) => Log.log("impl " ++ cmt) - | Intf(cmi, _) => Log.log("intf " ++ cmi) - | _ => Log.log("Both") - }; - }); - - let pathsForModule = - makePathsForModule(localModules, dependencyModules); - - let opens = - switch (namespace) { - | None => [] - | Some(namespace) => - let cmt = compiledBase /+ namespace ++ ".cmt"; - Log.log( - "############ Namespaced as " ++ namespace ++ " at " ++ cmt, - ); - Hashtbl.add(pathsForModule, namespace, Impl(cmt, None)); - [FindFiles.nameSpaceToName(namespace)]; - }; - Log.log( - "Dependency dirs " ++ String.concat(" ", dependencyDirectories), - ); - - let opens = { - let flags = - MerlinFile.getFlags(rootPath) - |> RResult.withDefault([""]) - |> List.map(escapePreprocessingFlags); - let opens = - List.fold_left( - (opens, item) => { - let parts = Utils.split_on_char(' ', item); - let rec loop = items => - switch (items) { - | ["-open", name, ...rest] => [name, ...loop(rest)] - | [_, ...rest] => loop(rest) - | [] => [] - }; - opens @ loop(parts); - }, - opens, - flags, - ); - opens; - }; - - let interModuleDependencies = - Hashtbl.create(List.length(localModules)); - - { - rootPath, - localModules: localModules |> List.map(fst), - dependencyModules: dependencyModules |> List.map(fst), - pathsForModule, - opens, - namespace, - interModuleDependencies, - }; - }, - ) - } - }; - }; - -let findRoot = (~uri, packagesByRoot) => { - let path = Uri2.toPath(uri); - let rec loop = path => - if (path == "/") { - None; - } else if (Hashtbl.mem(packagesByRoot, path)) { - Some(`Root(path)); - } else if (Files.exists(path /+ "bsconfig.json")) { - Some(`Bs(path)); - } else { - loop(Filename.dirname(path)); - }; - loop(Filename.dirname(path)); -}; - -let getPackage = (~uri, state) => - if (Hashtbl.mem(state.rootForUri, uri)) { - Ok( - Hashtbl.find( - state.packagesByRoot, - Hashtbl.find(state.rootForUri, uri), - ), - ); - } else { - switch ( - findRoot(~uri, state.packagesByRoot) - |> RResult.orError("No root directory found") - ) { - | Error(e) => Error(e) - | Ok(root) => - switch ( - switch (root) { - | `Root(rootPath) => - Hashtbl.replace(state.rootForUri, uri, rootPath); - Ok( - Hashtbl.find( - state.packagesByRoot, - Hashtbl.find(state.rootForUri, uri), - ), - ); - | `Bs(rootPath) => - switch (newBsPackage(rootPath)) { - | Error(e) => Error(e) - | Ok(package) => - Hashtbl.replace(state.rootForUri, uri, package.rootPath); - Hashtbl.replace(state.packagesByRoot, package.rootPath, package); - Ok(package); - } - } - ) { - | Error(e) => Error(e) - | Ok(package) => Ok(package) - } - }; - }; diff --git a/src/PartialParser.ml b/src/PartialParser.ml new file mode 100644 index 00000000..aeca63fa --- /dev/null +++ b/src/PartialParser.ml @@ -0,0 +1,245 @@ +let rec findBack text char i = + if i < 0 then i + else if text.[i] = char && (i = 0 || text.[i - 1] <> '/') then i - 1 + else findBack text char (i - 1) + +let rec findOpenComment text i = + if i < 1 then 0 + else if text.[i] = '*' && text.[i - 1] = '/' then i - 2 + else findOpenComment text (i - 1) + +let rec findBackSkippingCommentsAndStrings text char pair i level = + let loop = findBackSkippingCommentsAndStrings text char pair in + if i < 0 then 0 + else if text.[i] = char then + if level = 0 then i - 1 else loop (i - 1) (level - 1) + else if text.[i] = pair then loop (i - 1) (level + 1) + else + match text.[i] with + | '"' -> loop (findBack text '"' (i - 1)) level + | '/' when i >= 1 && text.[i - 1] = '*' -> + loop (findOpenComment text (i - 2)) level + | _ -> loop (i - 1) level + +let rec skipWhite text i = + if i < 0 then 0 + else + match text.[i] with ' ' | '\n' | '\t' -> skipWhite text (i - 1) | _ -> i + +let rec startOfLident text i = + if i < 0 then 0 + else + match text.[i] with + | 'a' .. 'z' | 'A' .. 'Z' | '.' | '_' | '0' .. '9' -> + startOfLident text (i - 1) + | _ -> i + 1 + +(* foo(... ~arg) from ~arg find foo *) +let findCallFromArgument text offset = + let rec loop ~i ~nClosed = + if i > 0 then + match text.[i] with + | '(' when nClosed > 0 -> loop ~i:(i - 1) ~nClosed:(nClosed - 1) + | '(' -> + let i1 = skipWhite text (i - 1) in + let i0 = startOfLident text i1 in + let funLident = String.sub text i0 (i1 - i0 + 1) in + Str.split (Str.regexp_string ".") funLident + | ')' -> loop ~i:(i - 1) ~nClosed:(nClosed + 1) + | _ -> loop ~i:(i - 1) ~nClosed + else [] + in + loop ~i:offset ~nClosed:0 + +(* Figure out whether id should be autocompleted as component prop. *) +(* Find JSX context ctx for component M to autocomplete id (already parsed) as a prop. *) +(* ctx ::= 0 then + match text.[i] with + | '}' -> ( + let i1 = findBackSkippingCommentsAndStrings text '{' '}' (i - 1) 0 in + match i1 > 0 with true -> beforeValue i1 | false -> None ) + | ')' -> ( + let i1 = findBackSkippingCommentsAndStrings text '(' ')' (i - 1) 0 in + match i1 > 0 with true -> beforeValue i1 | false -> None ) + | ']' -> ( + let i1 = findBackSkippingCommentsAndStrings text '[' ']' (i - 1) 0 in + match i1 > 0 with true -> beforeValue i1 | false -> None ) + | '"' -> ( + let i1 = findBack text '"' (i - 1) in + match i1 > 0 with true -> beforeValue i1 | false -> None ) + | _ -> + let i1 = startOfLident text i in + let ident = String.sub text i1 (i - i1 + 1) in + if i1 >= 1 && ident <> "" then + match ident.[0] with + | 'A' .. 'Z' when i1 >= 1 && text.[i1 - 1] = '<' -> Some ident + | _ -> beforeIdent (i1 - 1) + else None + else None + and beforeIdent i = + let i = skipWhite text i in + if i > 0 then + match text.[i] with + | '?' -> fromEquals (i - 1) + | '=' -> fromEquals i + | _ -> loop (i - 1) + else None + and beforeValue i = + let i = skipWhite text i in + if i > 0 then + match text.[i] with '?' -> fromEquals (i - 1) | _ -> fromEquals i + else None + and fromEquals i = + let i = skipWhite text i in + if i > 0 then + match text.[i] with + | '=' -> ( + let i = skipWhite text (i - 1) in + let i1 = startOfLident text i in + let ident = String.sub text i1 (i - i1 + 1) in + match ident = "" with true -> None | false -> loop (i1 - 1) ) + | _ -> None + else None + in + loop offset + +type completable = + | Cdecorator of string (* e.g. @module *) + | Clabel of string list * string (* e.g. (["M", "foo"], "label") for M.foo(...~label...) *) + | Cpath of string list (* e.g. ["M", "foo"] for M.foo *) + | Cjsx of string list * string (* E.g. (["M", "Comp"], "id") for foo" *) + +let findCompletable text offset = + let mkPath s = + let len = String.length s in + let pipeParts = Str.split (Str.regexp_string "->") s in + if + (len > 1 && s.[len - 2] = '-' && s.[len - 1] = '>') + || List.length pipeParts > 1 + then Cpipe s + else + let parts = Str.split (Str.regexp_string ".") s in + let parts = + match s.[len - 1] = '.' with true -> parts @ [""] | false -> parts + in + match parts with + | [id] when String.lowercase_ascii id = id -> ( + match findJsxContext text (offset - len - 1) with + | None -> Cpath parts + | Some componentName -> + Cjsx (Str.split (Str.regexp_string ".") componentName, id) ) + | _ -> Cpath parts + in + let rec loop i = + match i < 0 with + | true -> Some (mkPath (String.sub text (i + 1) (offset - (i + 1)))) + | false -> ( + match text.[i] with + | '>' when i > 0 && text.[i - 1] = '-' -> loop (i - 2) + | '~' -> + let labelPrefix = String.sub text (i + 1) (offset - (i + 1)) in + let funPath = findCallFromArgument text (i - 1) in + Some (Clabel (funPath, labelPrefix)) + | '@' -> Some (Cdecorator (String.sub text (i + 1) (offset - (i + 1)))) + | 'a' .. 'z' | 'A' .. 'Z' | '0' .. '9' | '.' | '_' -> loop (i - 1) + | _ -> ( + match i = offset - 1 with + | true -> None + | false -> Some (mkPath (String.sub text (i + 1) (offset - (i + 1)))) ) + ) + in + if offset > String.length text || offset = 0 then None else loop (offset - 1) + +(* Check if the position is inside a `//` comment *) +let rec insideLineComment text offset = + if offset <= 0 || text.[offset] = '\n' then false + else if offset > 0 && text.[offset] = '/' && text.[offset - 1] = '/' then true + else insideLineComment text (offset - 1) + +let findOpens text offset = + let opens = ref [] in + let pathOfModuleOpen o = + let rec loop items = + match items with + | [] -> SharedTypes.Tip "place holder" + | one :: rest -> Nested (one, loop rest) + in + loop (o |> Str.split (Str.regexp_string ".")) + in + let add o = opens := (o |> pathOfModuleOpen) :: !opens in + let maybeOpen i0 = + let rec loop i = + if i < 4 then 0 + else + match text.[i] with + | 'a' .. 'z' | 'A' .. 'Z' | '.' | '_' | '0' .. '9' -> loop (i - 1) + | ' ' | '!' -> + let at = skipWhite text (i - 1) in + let at = + if at >= 0 && text.[at] = '!' then + (* handle open! *) + skipWhite text (at - 1) + else at + in + if + at >= 3 + && text.[at - 3] = 'o' + && text.[at - 2] = 'p' + && text.[at - 1] = 'e' + && text.[at] = 'n' + && not (insideLineComment text (at - 4)) + then ( + add (String.sub text (i + 1) (i0 + 1 - (i + 1))); + at - 4 ) + else at + | _ -> i + in + loop (i0 - 1) + in + let rec loop i = + if i > 1 then + match text.[i] with + | '}' -> loop (findBackSkippingCommentsAndStrings text '{' '}' (i - 1) 0) + | ']' -> loop (findBackSkippingCommentsAndStrings text '[' ']' (i - 1) 0) + | ')' -> loop (findBackSkippingCommentsAndStrings text '(' ')' (i - 1) 0) + | '"' -> loop (findBack text '"' (i - 1)) + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> loop (maybeOpen i) + | '(' when text.[i - 1] = '.' -> ( + match text.[i - 2] with + | 'a' .. 'z' | 'A' .. 'Z' | '_' | '0' .. '9' -> + let i0 = startOfLident text (i - 3) in + add (String.sub text i0 (i - i0 - 1)) + | _ -> loop (i - 1) ) + | _ -> + if i > 1 && text.[i] = '/' && text.[i - 1] = '*' then + loop (findOpenComment text (i - 2)) + else loop (i - 1) + in + loop (offset - 1) |> ignore; + !opens + +let offsetOfLine text line = + let ln = String.length text in + let rec loop i lno = + match i >= ln with + | true -> None + | false -> ( + match text.[i] with + | '\n' -> ( + match lno = line - 1 with + | true -> Some (i + 1) + | false -> loop (i + 1) (lno + 1) ) + | _ -> loop (i + 1) lno ) + in + match line = 0 with true -> Some 0 | false -> loop 0 0 + +let positionToOffset text (line, character) = + let open Infix in + offsetOfLine text line |?>> fun bol -> bol + character diff --git a/src/PartialParser.re b/src/PartialParser.re deleted file mode 100644 index 194d0edc..00000000 --- a/src/PartialParser.re +++ /dev/null @@ -1,340 +0,0 @@ -let rec findBack = (text, char, i) => - if (i < 0) { - i; - } else if (text.[i] == char && (i == 0 || text.[i - 1] != '/')) { - i - 1; - } else { - findBack(text, char, i - 1); - }; - -let rec findOpenComment = (text, i) => - if (i < 1) { - 0; - } else if (text.[i] == '*' && text.[i - 1] == '/') { - i - 2; - } else { - findOpenComment(text, i - 1); - }; - -let rec findBackSkippingCommentsAndStrings = (text, char, pair, i, level) => { - let loop = findBackSkippingCommentsAndStrings(text, char, pair); - if (i < 0) { - 0; - } else if (text.[i] == char) { - if (level == 0) { - i - 1; - } else { - loop(i - 1, level - 1); - }; - } else if (text.[i] == pair) { - loop(i - 1, level + 1); - } else { - switch (text.[i]) { - | '"' => loop(findBack(text, '"', i - 1), level) - | '/' when i >= 1 && text.[i - 1] == '*' => - loop(findOpenComment(text, i - 2), level) - | _ => loop(i - 1, level) - }; - }; -}; - -let rec skipWhite = (text, i) => - if (i < 0) { - 0; - } else { - switch (text.[i]) { - | ' ' - | '\n' - | '\t' => skipWhite(text, i - 1) - | _ => i - }; - }; - -let rec startOfLident = (text, i) => - if (i < 0) { - 0; - } else { - switch (text.[i]) { - | 'a'..'z' - | 'A'..'Z' - | '.' - | '_' - | '0'..'9' => startOfLident(text, i - 1) - | _ => i + 1 - }; - }; - -// foo(... ~arg) from ~arg find foo -let findCallFromArgument = (text, offset) => { - let rec loop = (~i, ~nClosed) => - if (i > 0) { - switch (text.[i]) { - | '(' when nClosed > 0 => loop(~i=i - 1, ~nClosed=nClosed - 1) - - | '(' => - let i1 = skipWhite(text, i - 1); - let i0 = startOfLident(text, i1); - let funLident = String.sub(text, i0, i1 - i0 + 1); - Str.split(Str.regexp_string("."), funLident); - - | ')' => loop(~i=i - 1, ~nClosed=nClosed + 1) - - | _ => loop(~i=i - 1, ~nClosed) - }; - } else { - []; - }; - loop(~i=offset, ~nClosed=0); -}; - -// Figure out whether id should be autocompleted as component prop. -// Find JSX context ctx for component M to autocomplete id (already parsed) as a prop. -// ctx ::= { - let rec loop = i => { - let i = skipWhite(text, i); - if (i > 0) { - switch (text.[i]) { - | '}' => - let i1 = findBackSkippingCommentsAndStrings(text, '{', '}', i - 1, 0); - i1 > 0 ? beforeValue(i1) : None; - | ')' => - let i1 = findBackSkippingCommentsAndStrings(text, '(', ')', i - 1, 0); - i1 > 0 ? beforeValue(i1) : None; - | ']' => - let i1 = findBackSkippingCommentsAndStrings(text, '[', ']', i - 1, 0); - i1 > 0 ? beforeValue(i1) : None; - | '"' => - let i1 = findBack(text, '"', i - 1); - i1 > 0 ? beforeValue(i1) : None; - | _ => - let i1 = startOfLident(text, i); - let ident = String.sub(text, i1, i - i1 + 1); - if (i1 >= 1 && ident != "") { - switch (ident.[0]) { - | 'A'..'Z' when i1 >= 1 && text.[i1 - 1] == '<' => Some(ident) - | _ => beforeIdent(i1 - 1) - }; - } else { - None; - }; - }; - } else { - None; - }; - } - and beforeIdent = i => { - let i = skipWhite(text, i); - if (i > 0) { - switch (text.[i]) { - | '?' => fromEquals(i - 1) - | '=' => fromEquals(i) - | _ => loop(i - 1) - }; - } else { - None; - }; - } - and beforeValue = i => { - let i = skipWhite(text, i); - if (i > 0) { - switch (text.[i]) { - | '?' => fromEquals(i - 1) - | _ => fromEquals(i) - }; - } else { - None; - }; - } - and fromEquals = i => { - let i = skipWhite(text, i); - if (i > 0) { - switch (text.[i]) { - | '=' => - let i = skipWhite(text, i - 1); - let i1 = startOfLident(text, i); - let ident = String.sub(text, i1, i - i1 + 1); - ident == "" ? None : loop(i1 - 1); - | _ => None - }; - } else { - None; - }; - }; - loop(offset); -}; - -type completable = - | Cdecorator(string) // e.g. @module - | Clabel(list(string), string) // e.g. (["M", "foo"], "label") for M.foo(...~label...) - | Cpath(list(string)) // e.g. ["M", "foo"] for M.foo - | Cjsx(list(string), string) // E.g. (["M", "Comp"], "id") for foo" - -let findCompletable = (text, offset) => { - let mkPath = s => { - let len = String.length(s); - let pipeParts = Str.split(Str.regexp_string("->"), s); - if (len > 1 - && s.[len - 2] == '-' - && s.[len - 1] == '>' - || List.length(pipeParts) > 1) { - Cpipe(s); - } else { - let parts = Str.split(Str.regexp_string("."), s); - let parts = s.[len - 1] == '.' ? parts @ [""] : parts; - switch (parts) { - | [id] when String.lowercase_ascii(id) == id => - switch (findJsxContext(text, offset - len - 1)) { - | None => Cpath(parts) - | Some(componentName) => - Cjsx(Str.split(Str.regexp_string("."), componentName), id) - } - | _ => Cpath(parts) - }; - }; - }; - - let rec loop = i => { - i < 0 - ? Some(mkPath(String.sub(text, i + 1, offset - (i + 1)))) - : ( - switch (text.[i]) { - | '>' when i > 0 && text.[i - 1] == '-' => loop(i - 2) - | '~' => - let labelPrefix = String.sub(text, i + 1, offset - (i + 1)); - let funPath = findCallFromArgument(text, i - 1); - Some(Clabel(funPath, labelPrefix)); - | '@' => Some(Cdecorator(String.sub(text, i + 1, offset - (i + 1)))) - | 'a'..'z' - | 'A'..'Z' - | '0'..'9' - | '.' - | '_' => loop(i - 1) - | _ => - i == offset - 1 - ? None : Some(mkPath(String.sub(text, i + 1, offset - (i + 1)))) - } - ); - }; - if (offset > String.length(text) || offset == 0) { - None; - } else { - loop(offset - 1); - }; -}; - -// Check if the position is inside a `//` comment -let rec insideLineComment = (text, offset) => - if (offset <= 0 || text.[offset] == '\n') { - false; - } else if (offset > 0 && text.[offset] == '/' && text.[offset - 1] == '/') { - true; - } else { - insideLineComment(text, offset - 1); - }; - -let findOpens = (text, offset) => { - let opens = ref([]); - let pathOfModuleOpen = o => { - let rec loop = items => - switch (items) { - | [] => SharedTypes.Tip("place holder") - | [one, ...rest] => Nested(one, loop(rest)) - }; - loop(o |> Str.split(Str.regexp_string("."))); - }; - let add = o => opens := [o |> pathOfModuleOpen, ...opens^]; - let maybeOpen = i0 => { - let rec loop = i => - if (i < 4) { - 0; - } else { - switch (text.[i]) { - | 'a'..'z' - | 'A'..'Z' - | '.' - | '_' - | '0'..'9' => loop(i - 1) - | ' ' - | '!' => - let at = skipWhite(text, i - 1); - let at = - if (at >= 0 && text.[at] == '!') { - // handle open! - skipWhite(text, at - 1); - } else { - at; - }; - if (at >= 3 - && text.[at - 3] == 'o' - && text.[at - 2] == 'p' - && text.[at - 1] == 'e' - && text.[at] == 'n' - && !insideLineComment(text, at - 4)) { - add(String.sub(text, i + 1, i0 + 1 - (i + 1))); - at - 4; - } else { - at; - }; - | _ => i - }; - }; - loop(i0 - 1); - }; - - let rec loop = i => - if (i > 1) { - switch (text.[i]) { - | '}' => - loop(findBackSkippingCommentsAndStrings(text, '{', '}', i - 1, 0)) - | ']' => - loop(findBackSkippingCommentsAndStrings(text, '[', ']', i - 1, 0)) - | ')' => - loop(findBackSkippingCommentsAndStrings(text, '(', ')', i - 1, 0)) - | '"' => loop(findBack(text, '"', i - 1)) - | 'a'..'z' - | 'A'..'Z' - | '_' - | '0'..'9' => loop(maybeOpen(i)) - | '(' when text.[i - 1] == '.' => - switch (text.[i - 2]) { - | 'a'..'z' - | 'A'..'Z' - | '_' - | '0'..'9' => - let i0 = startOfLident(text, i - 3); - add(String.sub(text, i0, i - i0 - 1)); - | _ => loop(i - 1) - } - | _ => - if (i > 1 && text.[i] == '/' && text.[i - 1] == '*') { - loop(findOpenComment(text, i - 2)); - } else { - loop(i - 1); - } - }; - }; - loop(offset - 1) |> ignore; - opens^; -}; - -let offsetOfLine = (text, line) => { - let ln = String.length(text); - let rec loop = (i, lno) => - i >= ln - ? None - : ( - switch (text.[i]) { - | '\n' => lno == line - 1 ? Some(i + 1) : loop(i + 1, lno + 1) - | _ => loop(i + 1, lno) - } - ); - line == 0 ? Some(0) : loop(0, 0); -}; - -let positionToOffset = (text, (line, character)) => { - Infix.(offsetOfLine(text, line) |?>> (bol => bol + character)); -}; diff --git a/src/PrepareUtils.ml b/src/PrepareUtils.ml new file mode 100644 index 00000000..80da5040 --- /dev/null +++ b/src/PrepareUtils.ml @@ -0,0 +1,45 @@ +let findStars line = + let l = String.length line in + let rec loop i = + if i >= l - 1 then None + else if line.[i] = '*' && line.[i + 1] = ' ' then Some (i + 2) + else if line.[i] <> ' ' then None + else loop (i + 1) + in + loop 0 + +let combine one two = + match (one, two) with + | None, None -> None + | Some a, None -> Some a + | None, Some b -> Some b + | Some a, Some b -> ( match a = b with true -> Some a | false -> Some 0 ) + +let trimFirst num string = + let length = String.length string in + match length > num with + | true -> String.sub string num (length - num) + | false -> "" + +let cleanOffStars doc = + let lines = Str.split (Str.regexp_string "\n") doc in + let rec loop lines = + match lines with + | [] -> None + | [one] -> ( + match String.trim one = "" with true -> None | false -> findStars one ) + | one :: rest -> ( + match String.trim one = "" with + | true -> loop rest + | false -> combine (findStars one) (loop rest) ) + in + let num = loop lines in + match num with + | None | Some 0 -> doc + | Some num -> ( + match lines with + | [] | [_] -> doc + | one :: rest -> + (if findStars one <> None then trimFirst num one else String.trim one) + ^ "\n" + ^ String.concat "\n" (rest |> List.map (trimFirst num)) ) diff --git a/src/PrepareUtils.re b/src/PrepareUtils.re deleted file mode 100644 index ad566b2d..00000000 --- a/src/PrepareUtils.re +++ /dev/null @@ -1,60 +0,0 @@ -let findStars = line => { - let l = String.length(line); - let rec loop = i => - if (i >= l - 1) { - None; - } else if (line.[i] == '*' && line.[i + 1] == ' ') { - Some(i + 2); - } else if (line.[i] != ' ') { - None; - } else { - loop(i + 1); - }; - loop(0); -}; - -let combine = (one, two) => - switch (one, two) { - | (None, None) => None - | (Some(a), None) => Some(a) - | (None, Some(b)) => Some(b) - | (Some(a), Some(b)) => a == b ? Some(a) : Some(0) - }; - -let trimFirst = (num, string) => { - let length = String.length(string); - length > num ? String.sub(string, num, length - num) : ""; -}; - -let cleanOffStars = doc => { - let lines = Str.split(Str.regexp_string("\n"), doc); - let rec loop = lines => { - switch (lines) { - | [] => None - | [one] => String.trim(one) == "" ? None : findStars(one) - | [one, ...rest] => - String.trim(one) == "" - ? loop(rest) : combine(findStars(one), loop(rest)) - }; - }; - let num = loop(lines); - switch (num) { - | None - | Some(0) => doc - | Some(num) => - switch (lines) { - | [] - | [_] => doc - | [one, ...rest] => - ( - if (findStars(one) != None) { - trimFirst(num, one); - } else { - String.trim(one); - } - ) - ++ "\n" - ++ String.concat("\n", rest |> List.map(trimFirst(num))) - } - }; -}; diff --git a/src/PrintType.ml b/src/PrintType.ml new file mode 100644 index 00000000..b146430f --- /dev/null +++ b/src/PrintType.ml @@ -0,0 +1,10 @@ +let printExpr typ = + Printtyp.reset_names (); + Res_doc.toString ~width:60 + (Res_outcome_printer.printOutTypeDoc (Printtyp.tree_of_typexp false typ)) + +let printDecl ~recStatus name decl = + Printtyp.reset_names (); + Res_doc.toString ~width:60 + (Res_outcome_printer.printOutSigItemDoc + (Printtyp.tree_of_type_declaration (Ident.create name) decl recStatus)) diff --git a/src/PrintType.re b/src/PrintType.re deleted file mode 100644 index 4f84adce..00000000 --- a/src/PrintType.re +++ /dev/null @@ -1,17 +0,0 @@ -let printExpr = typ => { - Printtyp.reset_names(); - Res_doc.toString( - ~width=60, - Res_outcome_printer.printOutTypeDoc(Printtyp.tree_of_typexp(false, typ)), - ); -}; - -let printDecl = (~recStatus, name, decl) => { - Printtyp.reset_names(); - Res_doc.toString( - ~width=60, - Res_outcome_printer.printOutSigItemDoc( - Printtyp.tree_of_type_declaration(Ident.create(name), decl, recStatus), - ), - ); -}; diff --git a/src/ProcessAttributes.ml b/src/ProcessAttributes.ml new file mode 100644 index 00000000..ce177c02 --- /dev/null +++ b/src/ProcessAttributes.ml @@ -0,0 +1,54 @@ +open SharedTypes + +(* TODO should I hang on to location? *) +let rec findDocAttribute attributes = + let open Parsetree in + match attributes with + | [] -> None + | ( {Asttypes.txt = "ocaml.doc"}, + PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (doc, _))}, _); + }; + ] ) + :: _ -> + Some (PrepareUtils.cleanOffStars doc) + | _ :: rest -> findDocAttribute rest + +let rec findDeprecatedAttribute attributes = + let open Parsetree in + match attributes with + | [] -> None + | ( {Asttypes.txt = "deprecated"}, + PStr + [ + { + pstr_desc = + Pstr_eval ({pexp_desc = Pexp_constant (Pconst_string (msg, _))}, _); + }; + ] ) + :: _ -> + Some msg + | ({Asttypes.txt = "deprecated"}, _) :: _ -> Some "" + | _ :: rest -> findDeprecatedAttribute rest + +let newDeclared ~item ~scope ~extent ~name ~stamp ~modulePath ~processDoc + exported attributes = + { + name; + stamp; + extentLoc = extent; + scopeLoc = scope; + exported; + modulePath; + deprecated = findDeprecatedAttribute attributes; + docstring = + ( match findDocAttribute attributes with + | None -> [] + | Some d -> processDoc d ); + item; + (* scopeType = Let; *) + (* scopeStart = env.scopeStart; *) + } diff --git a/src/ProcessAttributes.re b/src/ProcessAttributes.re deleted file mode 100644 index a01035e3..00000000 --- a/src/ProcessAttributes.re +++ /dev/null @@ -1,84 +0,0 @@ -open SharedTypes; - -/* TODO should I hang on to location? */ -let rec findDocAttribute = attributes => { - Parsetree.( - switch (attributes) { - | [] => None - | [ - ( - {Asttypes.txt: "ocaml.doc"}, - PStr([ - { - pstr_desc: - Pstr_eval( - {pexp_desc: Pexp_constant(Pconst_string(doc, _))}, - _, - ), - }, - ]), - ), - ..._, - ] => - Some(PrepareUtils.cleanOffStars(doc)) - | [_, ...rest] => findDocAttribute(rest) - } - ); -}; - -let rec findDeprecatedAttribute = attributes => { - Parsetree.( - switch (attributes) { - | [] => None - | [ - ( - {Asttypes.txt: "deprecated"}, - PStr([ - { - pstr_desc: - Pstr_eval( - {pexp_desc: Pexp_constant(Pconst_string(msg, _))}, - _, - ), - }, - ]), - ), - ..._, - ] => - Some(msg) - | [({Asttypes.txt: "deprecated"}, _), ..._] => Some("") - | [_, ...rest] => findDeprecatedAttribute(rest) - } - ); -}; - -let newDeclared = - ( - ~item, - ~scope, - ~extent, - ~name, - ~stamp, - ~modulePath, - ~processDoc, - exported, - attributes, - ) => { - { - name, - stamp, - extentLoc: extent, - scopeLoc: scope, - exported, - modulePath, - deprecated: findDeprecatedAttribute(attributes), - docstring: - switch (findDocAttribute(attributes)) { - | None => [] - | Some(d) => processDoc(d) - }, - item, - /* scopeType: Let, */ - /* scopeStart: env.scopeStart, */ - }; -}; diff --git a/src/ProcessCmt.ml b/src/ProcessCmt.ml new file mode 100644 index 00000000..7226372c --- /dev/null +++ b/src/ProcessCmt.ml @@ -0,0 +1,525 @@ +open Typedtree +open SharedTypes +open Infix + +let itemsExtent items = + let open Typedtree in + match items = [] with + | true -> Location.none + | false -> + let first = List.hd items in + let last = List.nth items (List.length items - 1) in + let first, last = + match + first.str_loc.loc_start.pos_cnum < last.str_loc.loc_start.pos_cnum + with + | true -> (first, last) + | false -> (last, first) + in + { + loc_ghost = true; + loc_start = first.str_loc.loc_start; + loc_end = last.str_loc.loc_end; + } + +let sigItemsExtent items = + let open Typedtree in + match items = [] with + | true -> Location.none + | false -> + let first = List.hd items in + let last = List.nth items (List.length items - 1) in + { + Location.loc_ghost = true; + loc_start = first.sig_loc.loc_start; + loc_end = last.sig_loc.loc_end; + } + +type env = { + stamps : stamps; + processDoc : string -> string list; + modulePath : visibilityPath; + scope : Location.t; +} + +let addItem ~name ~extent ~stamp ~env ~item attributes exported stamps = + let declared = + ProcessAttributes.newDeclared ~item + ~scope: + { + Location.loc_start = extent.Location.loc_end; + loc_end = env.scope.loc_end; + loc_ghost = false; + } + ~extent ~name ~stamp ~modulePath:env.modulePath ~processDoc:env.processDoc + (not (Hashtbl.mem exported name.txt)) + attributes + in + if not (Hashtbl.mem exported name.txt) then + Hashtbl.add exported name.txt stamp; + Hashtbl.add stamps stamp declared; + declared + +let rec forSignatureTypeItem env (exported : SharedTypes.exported) item = + let open Types in + match item with + | Sig_value (ident, {val_type; val_attributes; val_loc = loc}) -> + let item = val_type in + let declared = + addItem + ~name:(Location.mknoloc (Ident.name ident)) + ~extent:loc ~stamp:(Ident.binding_time ident) ~env ~item val_attributes + exported.values env.stamps.values + in + [{declared with item = MValue declared.item}] + | Sig_type + ( ident, + ({type_loc; type_kind; type_manifest; type_attributes} as decl), + recStatus ) -> + let declared = + addItem ~extent:type_loc + ~item: + { + Type.decl; + kind = + ( match type_kind with + | Type_abstract -> ( + match type_manifest with + | Some {desc = Tconstr (path, args, _)} -> + Abstract (Some (path, args)) + | Some {desc = Ttuple items} -> Tuple items + (* TODO dig *) + | _ -> Abstract None ) + | Type_open -> Open + | Type_variant constructors -> + Variant + ( constructors + |> List.map + (fun {cd_loc; cd_id; cd_args; cd_res; cd_attributes} -> + let name = Ident.name cd_id in + let stamp = Ident.binding_time cd_id in + let item = + { + stamp; + cname = Location.mknoloc name; + args = + ( match cd_args with + | Cstr_tuple args -> args + (* TODO(406): constructor record args support *) + | Cstr_record _ -> [] ) + |> List.map (fun t -> (t, Location.none)); + res = cd_res; + } + in + let declared = + ProcessAttributes.newDeclared ~item ~extent:cd_loc + ~scope: + { + Location.loc_start = type_loc.Location.loc_end; + loc_end = env.scope.loc_end; + loc_ghost = false; + } + ~name:(Location.mknoloc name) + ~stamp + (* TODO maybe this needs another child *) + ~modulePath:env.modulePath + ~processDoc:env.processDoc true cd_attributes + in + Hashtbl.add env.stamps.constructors stamp declared; + item) ) + | Type_record (fields, _) -> + Record + ( fields + |> List.map (fun {ld_id; ld_type} -> + let astamp = Ident.binding_time ld_id in + let name = Ident.name ld_id in + { + stamp = astamp; + fname = Location.mknoloc name; + typ = ld_type; + }) ) ); + } + ~name:(Location.mknoloc (Ident.name ident)) + ~stamp:(Ident.binding_time ident) ~env type_attributes exported.types + env.stamps.types + in + [{declared with item = MType (declared.item, recStatus)}] + (* | Sig_module({stamp, name}, {md_type: Mty_ident(path) | Mty_alias(path), md_attributes, md_loc}, _) => + let declared = addItem(~contents=Module.Ident(path), ~name=Location.mknoloc(name), ~stamp, ~env, md_attributes, exported.modules, env.stamps.modules); + [{...declared, contents: Module.Module(declared.contents)}, ...items] *) + | Sig_module (ident, {md_type; md_attributes; md_loc}, _) -> + let declared = + addItem ~extent:md_loc + ~item:(forModuleType env md_type) + ~name:(Location.mknoloc (Ident.name ident)) + ~stamp:(Ident.binding_time ident) ~env md_attributes exported.modules + env.stamps.modules + in + [{declared with item = Module declared.item}] + | _ -> [] + +and forSignatureType env signature = + let exported = initExported () in + let topLevel = + List.fold_right + (fun item items -> forSignatureTypeItem env exported item @ items) + signature [] + in + {docstring = []; exported; topLevel} + +and forModuleType env moduleType = + match moduleType with + | Types.Mty_ident path -> Ident path + | Mty_alias (_ (* 402 *), path) -> Ident path + | Mty_signature signature -> Structure (forSignatureType env signature) + | Mty_functor (_argIdent, _argType, resultType) -> + forModuleType env resultType + +let getModuleTypePath mod_desc = + match mod_desc with + | Tmty_ident (path, _) | Tmty_alias (path, _) -> Some path + | Tmty_signature _ | Tmty_functor _ | Tmty_with _ | Tmty_typeof _ -> None + +let forTypeDeclaration ~env ~(exported : exported) + { + typ_id; + typ_loc; + typ_name = name; + typ_attributes; + typ_type; + typ_kind; + typ_manifest; + } ~recStatus = + let stamp = Ident.binding_time typ_id in + let declared = + addItem ~extent:typ_loc + ~item: + { + Type.decl = typ_type; + kind = + ( match typ_kind with + | Ttype_abstract -> ( + match typ_manifest with + | Some {ctyp_desc = Ttyp_constr (path, _lident, args)} -> + Abstract (Some (path, args |> List.map (fun t -> t.ctyp_type))) + | Some {ctyp_desc = Ttyp_tuple items} -> + Tuple (items |> List.map (fun t -> t.ctyp_type)) + (* TODO dig *) + | _ -> Abstract None ) + | Ttype_open -> Open + | Ttype_variant constructors -> + Variant + ( constructors + |> List.map (fun {cd_id; cd_name = cname; cd_args; cd_res} -> + let stamp = Ident.binding_time cd_id in + { + stamp; + cname; + args = + ( match cd_args with + | Cstr_tuple args -> args + (* TODO(406) *) + | Cstr_record _ -> [] ) + |> List.map (fun t -> (t.ctyp_type, t.ctyp_loc)); + res = (cd_res |?>> fun t -> t.ctyp_type); + }) ) + | Ttype_record fields -> + Record + ( fields + |> List.map + (fun {ld_id; ld_name = fname; ld_type = {ctyp_type}} -> + let fstamp = Ident.binding_time ld_id in + {stamp = fstamp; fname; typ = ctyp_type}) ) ); + } + ~name ~stamp ~env typ_attributes exported.types env.stamps.types + in + {declared with item = MType (declared.item, recStatus)} + +let forSignatureItem ~env ~(exported : exported) item = + match item.sig_desc with + | Tsig_value {val_id; val_loc; val_name = name; val_desc; val_attributes} -> + let declared = + addItem ~name + ~stamp:(Ident.binding_time val_id) + ~extent:val_loc ~item:val_desc.ctyp_type ~env val_attributes + exported.values env.stamps.values + in + [{declared with item = MValue declared.item}] + | Tsig_type (recFlag, decls) -> + decls + |> List.mapi (fun i decl -> + let recStatus = + match recFlag with + | Recursive when i = 0 -> Types.Trec_first + | Nonrecursive when i = 0 -> Types.Trec_not + | _ -> Types.Trec_next + in + decl |> forTypeDeclaration ~env ~exported ~recStatus) + | Tsig_module + {md_id; md_attributes; md_loc; md_name = name; md_type = {mty_type}} -> + let item = forModuleType env mty_type in + let declared = + addItem ~item ~name ~extent:md_loc ~stamp:(Ident.binding_time md_id) ~env + md_attributes exported.modules env.stamps.modules + in + [{declared with item = Module declared.item}] + | Tsig_include {incl_mod; incl_type} -> + let env = + match getModuleTypePath incl_mod.mty_desc with + | None -> env + | Some path -> + {env with modulePath = IncludedModule (path, env.modulePath)} + in + let topLevel = + List.fold_right + (fun item items -> forSignatureTypeItem env exported item @ items) + incl_type [] + in + topLevel + (* TODO: process other things here *) + | _ -> [] + +let forSignature ~env items = + let exported = initExported () in + let topLevel = + items |> List.map (forSignatureItem ~env ~exported) |> List.flatten + in + let attributes = + match items with + | {sig_desc = Tsig_attribute attribute} :: _ -> [attribute] + | _ -> [] + in + let docstring = + match ProcessAttributes.findDocAttribute attributes with + | None -> [] + | Some d -> env.processDoc d + in + {docstring; exported; topLevel} + +let forTreeModuleType ~env {mty_desc} = + match mty_desc with + | Tmty_ident _ -> None + | Tmty_signature {sig_items} -> + let contents = forSignature ~env sig_items in + Some (Structure contents) + | _ -> None + +let rec getModulePath mod_desc = + match mod_desc with + | Tmod_ident (path, _lident) -> Some path + | Tmod_structure _ -> None + | Tmod_functor (_ident, _argName, _maybeType, _resultExpr) -> None + | Tmod_apply (functor_, _arg, _coercion) -> getModulePath functor_.mod_desc + | Tmod_unpack (_expr, _moduleType) -> None + | Tmod_constraint (expr, _typ, _constraint, _coercion) -> + getModulePath expr.mod_desc + +let rec forItem ~env ~(exported : exported) item = + match item.str_desc with + | Tstr_value (_isRec, bindings) -> + optMap + (fun {vb_loc; vb_pat = {pat_desc; pat_type}; vb_attributes} -> + (* TODO get all the things out of the var. *) + match pat_desc with + | Tpat_var (ident, name) + | Tpat_alias ({pat_desc = Tpat_any}, ident, name) (* let x : t = ... *) -> + let item = pat_type in + let declared = + addItem ~name ~stamp:(Ident.binding_time ident) ~env ~extent:vb_loc + ~item vb_attributes exported.values env.stamps.values + in + Some {declared with item = MValue declared.item} + | _ -> None) + bindings + | Tstr_module + {mb_id; mb_attributes; mb_loc; mb_name = name; mb_expr = {mod_desc}} -> + let item = forModule env mod_desc name.txt in + let declared = + addItem ~item ~name ~extent:mb_loc ~stamp:(Ident.binding_time mb_id) ~env + mb_attributes exported.modules env.stamps.modules + in + [{declared with item = Module declared.item}] + | Tstr_include {incl_mod; incl_type} -> + let env = + match getModulePath incl_mod.mod_desc with + | None -> env + | Some path -> + {env with modulePath = IncludedModule (path, env.modulePath)} + in + let topLevel = + List.fold_right + (fun item items -> forSignatureTypeItem env exported item @ items) + incl_type [] + in + topLevel + | Tstr_primitive + {val_id; val_name = name; val_loc; val_attributes; val_val = {val_type}} + -> + let declared = + addItem ~extent:val_loc ~item:val_type ~name + ~stamp:(Ident.binding_time val_id) + ~env val_attributes exported.values env.stamps.values + in + [{declared with item = MValue declared.item}] + | Tstr_type (recFlag, decls) -> + decls + |> List.mapi (fun i decl -> + let recStatus = + match recFlag with + | Recursive when i = 0 -> Types.Trec_first + | Nonrecursive when i = 0 -> Types.Trec_not + | _ -> Types.Trec_next + in + decl |> forTypeDeclaration ~env ~exported ~recStatus) + | _ -> [] + +and forModule env mod_desc moduleName = + match mod_desc with + | Tmod_ident (path, _lident) -> Ident path + | Tmod_structure structure -> + let env = + { + env with + scope = itemsExtent structure.str_items; + modulePath = ExportedModule (moduleName, env.modulePath); + } + in + let contents = forStructure ~env structure.str_items in + Structure contents + | Tmod_functor (ident, argName, maybeType, resultExpr) -> + ( match maybeType with + | None -> () + | Some t -> ( + match forTreeModuleType ~env t with + | None -> () + | Some kind -> + let stamp = Ident.binding_time ident in + let declared = + ProcessAttributes.newDeclared ~item:kind ~name:argName + ~scope: + { + Location.loc_start = t.mty_loc.loc_end; + loc_end = env.scope.loc_end; + loc_ghost = false; + } + ~extent:t.Typedtree.mty_loc ~stamp ~modulePath:NotVisible + ~processDoc:env.processDoc false [] + in + Hashtbl.add env.stamps.modules stamp declared ) ); + forModule env resultExpr.mod_desc moduleName + | Tmod_apply (functor_, _arg, _coercion) -> + forModule env functor_.mod_desc moduleName + | Tmod_unpack (_expr, moduleType) -> + let env = + {env with modulePath = ExportedModule (moduleName, env.modulePath)} + in + forModuleType env moduleType + | Tmod_constraint (expr, _typ, Tmodtype_implicit, Tcoerce_structure _) -> + (* implicit contraint synthesized during typechecking *) + (* e.g. when the same id is defined twice (e.g. make with @react.component) *) + (* skip the constraint and use the original module definition *) + forModule env expr.mod_desc moduleName + | Tmod_constraint (_expr, typ, _constraint, _coercion) -> + (* TODO do this better I think *) + let env = + {env with modulePath = ExportedModule (moduleName, env.modulePath)} + in + forModuleType env typ + +and forStructure ~env items = + let exported = initExported () in + let topLevel = + List.fold_right + (fun item results -> forItem ~env ~exported item @ results) + items [] + in + let attributes = + match items with + | {str_desc = Tstr_attribute attribute} :: _ -> [attribute] + | _ -> [] + in + let docstring = + match ProcessAttributes.findDocAttribute attributes with + | None -> [] + | Some d -> env.processDoc d + in + {docstring; exported; topLevel} + +let forCmt ~moduleName ~uri processDoc + ({cmt_modname; cmt_annots} : Cmt_format.cmt_infos) = + match cmt_annots with + | Partial_implementation parts -> + let items = + parts |> Array.to_list + |> Utils.filterMap (fun p -> + match (p : Cmt_format.binary_part) with + | Partial_structure str -> Some str.str_items + | Partial_structure_item str -> Some [str] + | _ -> None) + |> List.concat + 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 + let env = + { + scope = extent; + stamps = initStamps (); + processDoc; + modulePath = File (uri, moduleName); + } + in + let contents = forStructure ~env items in + {uri; moduleName = cmt_modname; stamps = env.stamps; contents} + | Partial_interface parts -> + let items = + parts |> Array.to_list + |> Utils.filterMap (fun (p : Cmt_format.binary_part) -> + match p with + | Partial_signature str -> Some str.sig_items + | Partial_signature_item str -> Some [str] + | _ -> None) + |> List.concat + in + let env = + { + scope = sigItemsExtent items; + stamps = initStamps (); + processDoc; + modulePath = File (uri, moduleName); + } + in + let contents = forSignature ~env items in + {uri; moduleName = cmt_modname; stamps = env.stamps; contents} + | Implementation structure -> + let env = + { + scope = itemsExtent structure.str_items; + stamps = initStamps (); + processDoc; + modulePath = File (uri, moduleName); + } + in + let contents = forStructure ~env structure.str_items in + {uri; moduleName = cmt_modname; stamps = env.stamps; contents} + | Interface signature -> + let env = + { + scope = sigItemsExtent signature.sig_items; + stamps = initStamps (); + processDoc; + modulePath = File (uri, moduleName); + } + in + let contents = forSignature ~env signature.sig_items in + {uri; moduleName = cmt_modname; stamps = env.stamps; contents} + | _ -> SharedTypes.emptyFile moduleName uri diff --git a/src/ProcessCmt.re b/src/ProcessCmt.re deleted file mode 100644 index d2bcc0ac..00000000 --- a/src/ProcessCmt.re +++ /dev/null @@ -1,661 +0,0 @@ -open Typedtree; -open SharedTypes; -open Infix; - -let itemsExtent = items => { - Typedtree.( - items == [] - ? Location.none - : { - let first = List.hd(items); - let last = List.nth(items, List.length(items) - 1); - let (first, last) = - first.str_loc.loc_start.pos_cnum < last.str_loc.loc_start.pos_cnum - ? (first, last) : (last, first); - - { - loc_ghost: true, - loc_start: first.str_loc.loc_start, - loc_end: last.str_loc.loc_end, - }; - } - ); -}; - -let sigItemsExtent = items => { - Typedtree.( - items == [] - ? Location.none - : { - let first = List.hd(items); - let last = List.nth(items, List.length(items) - 1); - - { - Location.loc_ghost: true, - loc_start: first.sig_loc.loc_start, - loc_end: last.sig_loc.loc_end, - }; - } - ); -}; - -type env = { - stamps, - processDoc: string => list(string), - modulePath: visibilityPath, - scope: Location.t, -}; - -let addItem = - (~name, ~extent, ~stamp, ~env, ~item, attributes, exported, stamps) => { - let declared = - ProcessAttributes.newDeclared( - ~item, - ~scope={ - Location.loc_start: extent.Location.loc_end, - loc_end: env.scope.loc_end, - loc_ghost: false, - }, - ~extent, - ~name, - ~stamp, - ~modulePath=env.modulePath, - ~processDoc=env.processDoc, - !Hashtbl.mem(exported, name.txt), - attributes, - ); - if (!Hashtbl.mem(exported, name.txt)) { - Hashtbl.add(exported, name.txt, stamp); - }; - Hashtbl.add(stamps, stamp, declared); - declared; -}; - -let rec forSignatureTypeItem = (env, exported: SharedTypes.exported, item) => { - Types.( - switch (item) { - | Sig_value(ident, {val_type, val_attributes, val_loc: loc}) => - let item = val_type; - let declared = - addItem( - ~name=Location.mknoloc(Ident.name(ident)), - ~extent=loc, - ~stamp=Ident.binding_time(ident), - ~env, - ~item, - val_attributes, - exported.values, - env.stamps.values, - ); - [{...declared, item: MValue(declared.item)}]; - | Sig_type( - ident, - {type_loc, type_kind, type_manifest, type_attributes} as decl, - recStatus, - ) => - let declared = - addItem( - ~extent=type_loc, - ~item={ - Type.decl, - kind: - switch (type_kind) { - | Type_abstract => - switch (type_manifest) { - | Some({desc: Tconstr(path, args, _)}) => - Abstract(Some((path, args))) - | Some({desc: Ttuple(items)}) => Tuple(items) - /* TODO dig */ - | _ => Abstract(None) - } - | Type_open => Open - | Type_variant(constructors) => - Variant( - constructors - |> List.map( - ({cd_loc, cd_id, cd_args, cd_res, cd_attributes}) => { - let name = Ident.name(cd_id); - let stamp = Ident.binding_time(cd_id); - let item = { - stamp, - cname: Location.mknoloc(name), - args: - ( - switch (cd_args) { - | Cstr_tuple(args) => args - /* TODO(406): constructor record args support */ - | Cstr_record(_) => [] - } - ) - |> List.map(t => (t, Location.none)), - res: cd_res, - }; - let declared = - ProcessAttributes.newDeclared( - ~item, - ~extent=cd_loc, - ~scope={ - Location.loc_start: type_loc.Location.loc_end, - loc_end: env.scope.loc_end, - loc_ghost: false, - }, - ~name=Location.mknoloc(name), - ~stamp, - /* TODO maybe this needs another child */ - ~modulePath=env.modulePath, - ~processDoc=env.processDoc, - true, - cd_attributes, - ); - Hashtbl.add(env.stamps.constructors, stamp, declared); - item; - }), - ) - | Type_record(fields, _) => - Record( - fields - |> List.map(({ld_id, ld_type}) => { - let astamp = Ident.binding_time(ld_id); - let name = Ident.name(ld_id); - { - stamp: astamp, - fname: Location.mknoloc(name), - typ: ld_type, - }; - }), - ) - }, - }, - ~name=Location.mknoloc(Ident.name(ident)), - ~stamp=Ident.binding_time(ident), - ~env, - type_attributes, - exported.types, - env.stamps.types, - ); - [{...declared, item: MType(declared.item, recStatus)}]; - /* | Sig_module({stamp, name}, {md_type: Mty_ident(path) | Mty_alias(path), md_attributes, md_loc}, _) => - let declared = addItem(~contents=Module.Ident(path), ~name=Location.mknoloc(name), ~stamp, ~env, md_attributes, exported.modules, env.stamps.modules); - [{...declared, contents: Module.Module(declared.contents)}, ...items] */ - | Sig_module(ident, {md_type, md_attributes, md_loc}, _) => - let declared = - addItem( - ~extent=md_loc, - ~item=forModuleType(env, md_type), - ~name=Location.mknoloc(Ident.name(ident)), - ~stamp=Ident.binding_time(ident), - ~env, - md_attributes, - exported.modules, - env.stamps.modules, - ); - [{...declared, item: Module(declared.item)}]; - | _ => [] - } - ); -} - -and forSignatureType = (env, signature) => { - let exported = initExported(); - let topLevel = - List.fold_right( - (item, items) => forSignatureTypeItem(env, exported, item) @ items, - signature, - [], - ); - {docstring: [], exported, topLevel}; -} -and forModuleType = (env, moduleType) => - switch (moduleType) { - | Types.Mty_ident(path) => Ident(path) - | Mty_alias(_ /* 402*/, path) => Ident(path) - | Mty_signature(signature) => Structure(forSignatureType(env, signature)) - | Mty_functor(_argIdent, _argType, resultType) => - forModuleType(env, resultType) - }; - -let getModuleTypePath = mod_desc => - switch (mod_desc) { - | Tmty_ident(path, _) - | Tmty_alias(path, _) => Some(path) - | Tmty_signature(_) - | Tmty_functor(_) - | Tmty_with(_) - | Tmty_typeof(_) => None - }; - -let forTypeDeclaration = - ( - ~env, - ~exported: exported, - { - typ_id, - typ_loc, - typ_name: name, - typ_attributes, - typ_type, - typ_kind, - typ_manifest, - }, - ~recStatus, - ) => { - let stamp = Ident.binding_time(typ_id); - let declared = - addItem( - ~extent=typ_loc, - ~item={ - Type.decl: typ_type, - kind: - switch (typ_kind) { - | Ttype_abstract => - switch (typ_manifest) { - | Some({ctyp_desc: Ttyp_constr(path, _lident, args)}) => - Abstract(Some((path, args |> List.map(t => t.ctyp_type)))) - | Some({ctyp_desc: Ttyp_tuple(items)}) => - Tuple(items |> List.map(t => t.ctyp_type)) - /* TODO dig */ - | _ => Abstract(None) - } - | Ttype_open => Open - | Ttype_variant(constructors) => - Variant( - constructors - |> List.map(({cd_id, cd_name: cname, cd_args, cd_res}) => { - let stamp = Ident.binding_time(cd_id); - { - stamp, - cname, - args: - ( - switch (cd_args) { - | Cstr_tuple(args) => args - /* TODO(406) */ - | Cstr_record(_) => [] - } - ) - |> List.map(t => (t.ctyp_type, t.ctyp_loc)), - res: cd_res |?>> (t => t.ctyp_type), - }; - }), - ) - | Ttype_record(fields) => - Record( - fields - |> List.map(({ld_id, ld_name: fname, ld_type: {ctyp_type}}) => { - let fstamp = Ident.binding_time(ld_id); - {stamp: fstamp, fname, typ: ctyp_type}; - }), - ) - }, - }, - ~name, - ~stamp, - ~env, - typ_attributes, - exported.types, - env.stamps.types, - ); - {...declared, item: MType(declared.item, recStatus)}; -}; - -let forSignatureItem = (~env, ~exported: exported, item) => { - switch (item.sig_desc) { - | Tsig_value({val_id, val_loc, val_name: name, val_desc, val_attributes}) => - let declared = - addItem( - ~name, - ~stamp=Ident.binding_time(val_id), - ~extent=val_loc, - ~item=val_desc.ctyp_type, - ~env, - val_attributes, - exported.values, - env.stamps.values, - ); - [{...declared, item: MValue(declared.item)}]; - | Tsig_type(recFlag, decls) => - decls - |> List.mapi((i, decl) => { - let recStatus = - switch (recFlag) { - | Recursive when i == 0 => Types.Trec_first - | Nonrecursive when i == 0 => Types.Trec_not - | _ => Types.Trec_next - }; - decl |> forTypeDeclaration(~env, ~exported, ~recStatus); - }) - | Tsig_module({ - md_id, - md_attributes, - md_loc, - md_name: name, - md_type: {mty_type}, - }) => - let item = forModuleType(env, mty_type); - let declared = - addItem( - ~item, - ~name, - ~extent=md_loc, - ~stamp=Ident.binding_time(md_id), - ~env, - md_attributes, - exported.modules, - env.stamps.modules, - ); - [{...declared, item: Module(declared.item)}]; - | Tsig_include({incl_mod, incl_type}) => - let env = - switch (getModuleTypePath(incl_mod.mty_desc)) { - | None => env - | Some(path) => { - ...env, - modulePath: IncludedModule(path, env.modulePath), - } - }; - let topLevel = - List.fold_right( - (item, items) => forSignatureTypeItem(env, exported, item) @ items, - incl_type, - [], - ); - - topLevel; - /* TODO: process other things here */ - | _ => [] - }; -}; - -let forSignature = (~env, items) => { - let exported = initExported(); - let topLevel = - items |> List.map(forSignatureItem(~env, ~exported)) |> List.flatten; - let attributes = - switch (items) { - | [{sig_desc: Tsig_attribute(attribute)}, ..._] => [attribute] - | _ => [] - }; - let docstring = - switch (ProcessAttributes.findDocAttribute(attributes)) { - | None => [] - | Some(d) => env.processDoc(d) - }; - {docstring, exported, topLevel}; -}; - -let forTreeModuleType = (~env, {mty_desc}) => - switch (mty_desc) { - | Tmty_ident(_) => None - | Tmty_signature({sig_items}) => - let contents = forSignature(~env, sig_items); - Some(Structure(contents)); - | _ => None - }; - -let rec getModulePath = mod_desc => - switch (mod_desc) { - | Tmod_ident(path, _lident) => Some(path) - | Tmod_structure(_) => None - | Tmod_functor(_ident, _argName, _maybeType, _resultExpr) => None - | Tmod_apply(functor_, _arg, _coercion) => getModulePath(functor_.mod_desc) - | Tmod_unpack(_expr, _moduleType) => None - | Tmod_constraint(expr, _typ, _constraint, _coercion) => - getModulePath(expr.mod_desc) - }; - -let rec forItem = (~env, ~exported: exported, item) => - switch (item.str_desc) { - | Tstr_value(_isRec, bindings) => - optMap( - ({vb_loc, vb_pat: {pat_desc, pat_type}, vb_attributes}) => - /* TODO get all the things out of the var. */ - switch (pat_desc) { - | Tpat_var(ident, name) - | Tpat_alias({pat_desc: Tpat_any}, ident, name) /* let x : t = ... */ => - let item = pat_type; - let declared = - addItem( - ~name, - ~stamp=Ident.binding_time(ident), - ~env, - ~extent=vb_loc, - ~item, - vb_attributes, - exported.values, - env.stamps.values, - ); - Some({...declared, item: MValue(declared.item)}); - | _ => None - }, - bindings, - ) - | Tstr_module({ - mb_id, - mb_attributes, - mb_loc, - mb_name: name, - mb_expr: {mod_desc}, - }) => - let item = forModule(env, mod_desc, name.txt); - let declared = - addItem( - ~item, - ~name, - ~extent=mb_loc, - ~stamp=Ident.binding_time(mb_id), - ~env, - mb_attributes, - exported.modules, - env.stamps.modules, - ); - [{...declared, item: Module(declared.item)}]; - | Tstr_include({incl_mod, incl_type}) => - let env = - switch (getModulePath(incl_mod.mod_desc)) { - | None => env - | Some(path) => { - ...env, - modulePath: IncludedModule(path, env.modulePath), - } - }; - let topLevel = - List.fold_right( - (item, items) => forSignatureTypeItem(env, exported, item) @ items, - incl_type, - [], - ); - - topLevel; - - | Tstr_primitive({ - val_id, - val_name: name, - val_loc, - val_attributes, - val_val: {val_type}, - }) => - let declared = - addItem( - ~extent=val_loc, - ~item=val_type, - ~name, - ~stamp=Ident.binding_time(val_id), - ~env, - val_attributes, - exported.values, - env.stamps.values, - ); - [{...declared, item: MValue(declared.item)}]; - | Tstr_type(recFlag, decls) => - decls - |> List.mapi((i, decl) => { - let recStatus = - switch (recFlag) { - | Recursive when i == 0 => Types.Trec_first - | Nonrecursive when i == 0 => Types.Trec_not - | _ => Types.Trec_next - }; - decl |> forTypeDeclaration(~env, ~exported, ~recStatus); - }) - | _ => [] - } - -and forModule = (env, mod_desc, moduleName) => - switch (mod_desc) { - | Tmod_ident(path, _lident) => Ident(path) - | Tmod_structure(structure) => - let env = { - ...env, - scope: itemsExtent(structure.str_items), - modulePath: ExportedModule(moduleName, env.modulePath), - }; - let contents = forStructure(~env, structure.str_items); - Structure(contents); - | Tmod_functor(ident, argName, maybeType, resultExpr) => - switch (maybeType) { - | None => () - | Some(t) => - switch (forTreeModuleType(~env, t)) { - | None => () - | Some(kind) => - let stamp = Ident.binding_time(ident); - let declared = - ProcessAttributes.newDeclared( - ~item=kind, - ~name=argName, - ~scope={ - Location.loc_start: t.mty_loc.loc_end, - loc_end: env.scope.loc_end, - loc_ghost: false, - }, - ~extent=t.Typedtree.mty_loc, - ~stamp, - ~modulePath=NotVisible, - ~processDoc=env.processDoc, - false, - [], - ); - Hashtbl.add(env.stamps.modules, stamp, declared); - } - }; - forModule(env, resultExpr.mod_desc, moduleName); - | Tmod_apply(functor_, _arg, _coercion) => - forModule(env, functor_.mod_desc, moduleName) - | Tmod_unpack(_expr, moduleType) => - let env = { - ...env, - modulePath: ExportedModule(moduleName, env.modulePath), - }; - forModuleType(env, moduleType); - | Tmod_constraint(expr, _typ, Tmodtype_implicit, Tcoerce_structure(_)) => - // implicit contraint synthesized during typechecking - // e.g. when the same id is defined twice (e.g. make with @react.component) - // skip the constraint and use the original module definition - forModule(env, expr.mod_desc, moduleName) - | Tmod_constraint(_expr, typ, _constraint, _coercion) => - /* TODO do this better I think */ - let env = { - ...env, - modulePath: ExportedModule(moduleName, env.modulePath), - }; - forModuleType(env, typ); - } - -and forStructure = (~env, items) => { - let exported = initExported(); - let topLevel = - List.fold_right( - (item, results) => forItem(~env, ~exported, item) @ results, - items, - [], - ); - let attributes = - switch (items) { - | [{str_desc: Tstr_attribute(attribute)}, ..._] => [attribute] - | _ => [] - }; - let docstring = - switch (ProcessAttributes.findDocAttribute(attributes)) { - | None => [] - | Some(d) => env.processDoc(d) - }; - {docstring, exported, topLevel}; -}; - -let forCmt = - ( - ~moduleName, - ~uri, - processDoc, - {cmt_modname, cmt_annots}: Cmt_format.cmt_infos, - ) => - switch (cmt_annots) { - | Partial_implementation(parts) => - let items = - parts - |> Array.to_list - |> Utils.filterMap(p => - switch ((p: Cmt_format.binary_part)) { - | Partial_structure(str) => Some(str.str_items) - | Partial_structure_item(str) => Some([str]) - | _ => None - } - ) - |> List.concat; - let extent = itemsExtent(items); - let extent = { - ...extent, - loc_end: { - ...extent.loc_end, - pos_lnum: extent.loc_end.pos_lnum + 1000000, - pos_cnum: extent.loc_end.pos_cnum + 100000000, - }, - }; - let env = { - scope: extent, - stamps: initStamps(), - processDoc, - modulePath: File(uri, moduleName), - }; - let contents = forStructure(~env, items); - {uri, moduleName: cmt_modname, stamps: env.stamps, contents}; - | Partial_interface(parts) => - let items = - parts - |> Array.to_list - |> Utils.filterMap((p: Cmt_format.binary_part) => - switch (p) { - | Partial_signature(str) => Some(str.sig_items) - | Partial_signature_item(str) => Some([str]) - | _ => None - } - ) - |> List.concat; - let env = { - scope: sigItemsExtent(items), - stamps: initStamps(), - processDoc, - modulePath: File(uri, moduleName), - }; - let contents = forSignature(~env, items); - {uri, moduleName: cmt_modname, stamps: env.stamps, contents}; - | Implementation(structure) => - let env = { - scope: itemsExtent(structure.str_items), - stamps: initStamps(), - processDoc, - modulePath: File(uri, moduleName), - }; - let contents = forStructure(~env, structure.str_items); - {uri, moduleName: cmt_modname, stamps: env.stamps, contents}; - | Interface(signature) => - let env = { - scope: sigItemsExtent(signature.sig_items), - stamps: initStamps(), - processDoc, - modulePath: File(uri, moduleName), - }; - let contents = forSignature(~env, signature.sig_items); - {uri, moduleName: cmt_modname, stamps: env.stamps, contents}; - | _ => SharedTypes.emptyFile(moduleName, uri) - }; diff --git a/src/ProcessExtra.ml b/src/ProcessExtra.ml new file mode 100644 index 00000000..32449529 --- /dev/null +++ b/src/ProcessExtra.ml @@ -0,0 +1,549 @@ +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 + ~processDoc:(fun x -> [x]) + ~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 + ~processDoc:(fun x -> [x]) + ~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_apply({exp_desc: Pexp_ident(_, {txt: Ldot(Lident("ReasonReact"), "element")})}, [(_, {exp_desc: Pexp_apply({exp_desc: Pexp_ident(_, {txt})}, _)})]) => {} + *) + | 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/src/ProcessExtra.re b/src/ProcessExtra.re deleted file mode 100644 index ba466082..00000000 --- a/src/ProcessExtra.re +++ /dev/null @@ -1,673 +0,0 @@ -open Typedtree; -open SharedTypes; - -let handleConstructor = (path, txt) => { - let typeName = - switch (path) { - | Path.Pdot(_path, typename, _) => typename - | Pident(ident) => Ident.name(ident) - | _ => assert(false) - }; - Longident.( - switch (txt) { - | Longident.Lident(name) => (name, Lident(typeName)) - | Ldot(left, name) => (name, Ldot(left, typeName)) - | Lapply(_, _) => assert(false) - } - ); -}; - -let rec relative = (ident, path) => - switch (ident, path) { - | (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) => - switch (relative(ident, path)) { - | None => None - | Some(openNeedle) => - let matching = - Hashtbl.fold( - (_, op, res) => - if (Utils.locWithinLoc(loc, op.extent) - && Path.same(op.path, openNeedle)) { - [op, ...res]; - } else { - res; - }, - opens, - [], - ) - |> List.sort((a: SharedTypes.openTracker, b) => - b.loc.loc_start.pos_cnum - a.loc.loc_start.pos_cnum - ); - - switch (matching) { - | [] => None - | [first, ..._] => Some(first) - }; - }; - -let getTypeAtPath = (~env, path) => { - switch (Query.fromCompilerPath(~env, path)) { - | `GlobalMod(_) => `Not_found - | `Global(moduleName, path) => `Global((moduleName, path)) - | `Not_found => `Not_found - | `Exported(env, name) => - switch (Hashtbl.find_opt(env.exported.types, name)) { - | None => `Not_found - | Some(stamp) => - let declaredType = Hashtbl.find_opt(env.file.stamps.types, stamp); - switch (declaredType) { - | Some(declaredType) => `Local(declaredType) - | None => `Not_found - }; - } - | `Stamp(stamp) => - let declaredType = Hashtbl.find_opt(env.file.stamps.types, stamp); - switch (declaredType) { - | Some(declaredType) => `Local(declaredType) - | None => `Not_found - }; - }; -}; - -module F = - ( - Collector: { - let extra: extra; - let file: file; - let scopeExtent: ref(list(Location.t)); - }, - ) => { - let extra = Collector.extra; - - let maybeAddUse = (path, ident, loc, tip) => - switch (findClosestMatchingOpen(extra.opens, path, ident, loc)) { - | None => () - | Some(tracker) => - switch (Query.makeRelativePath(tracker.path, path)) { - | 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, - ...Hashtbl.mem(extra.internalReferences, stamp) - ? Hashtbl.find(extra.internalReferences, stamp) : [], - ], - ); - 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), - ...Hashtbl.mem(extra.externalReferences, moduleName) - ? Hashtbl.find(extra.externalReferences, moduleName) : [], - ], - ); - }; - 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); - let identLoc = Utils.endOfLocation(loc, String.length(identName)); - let locType = - switch (Query.fromCompilerPath(~env, path)) { - | `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) => - switch ( - Hashtbl.find_opt( - tip == Type ? env.exported.types : env.exported.values, - name, - ) - ) { - | Some(stamp) => - addReference(stamp, identLoc); - LocalReference(stamp, tip); - | None => NotFound - } - | `GlobalMod(_) => NotFound - }; - addLocation(loc, Typed(typ, locType)); - }; - - let addForPathParent = (path, loc) => { - let locType = - switch (Query.fromCompilerPath(~env, path)) { - | `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) => - switch (Hashtbl.find_opt(env.exported.modules, name)) { - | Some(stamp) => - addReference(stamp, loc); - LModule(LocalReference(stamp, Module)); - | None => LModule(NotFound) - } - }; - addLocation(loc, locType); - }; - - let addForField = (recordType, item, {Asttypes.txt, loc}) => { - switch (Shared.dig(recordType).desc) { - | Tconstr(path, _args, _memo) => - let t = getTypeAtPath(path); - let {Types.lbl_res} = item; - - let (name, typeLident) = handleConstructor(path, txt); - maybeAddUse(path, typeLident, loc, Field(name)); - - let nameLoc = Utils.endOfLocation(loc, String.length(name)); - let locType = - switch (t) { - | `Local({stamp, item: {kind: Record(fields)}}) => - switch (fields |> List.find_opt(f => f.fname.txt == name)) { - | 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 - }; - addLocation(nameLoc, Typed(lbl_res, locType)); - | _ => () - }; - }; - - let addForRecord = (recordType, items) => { - switch (Shared.dig(recordType).desc) { - | Tconstr(path, _args, _memo) => - let t = getTypeAtPath(path); - items - |> List.iter((({Asttypes.txt, loc}, {Types.lbl_res}, _)) => { - /* let name = Longident.last(txt); */ - - let (name, typeLident) = handleConstructor(path, txt); - maybeAddUse(path, typeLident, loc, Field(name)); - - let nameLoc = Utils.endOfLocation(loc, String.length(name)); - let locType = - switch (t) { - | `Local({stamp, item: {kind: Record(fields)}}) => - switch (fields |> List.find_opt(f => f.fname.txt == name)) { - | 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 - }; - addLocation(nameLoc, Typed(lbl_res, locType)); - }); - | _ => () - }; - }; - - let addForConstructor = - (constructorType, {Asttypes.txt, loc}, {Types.cstr_name}) => { - switch (Shared.dig(constructorType).desc) { - | Tconstr(path, _args, _memo) => - /* let name = Longident.last(txt); */ - - let (name, typeLident) = handleConstructor(path, txt); - maybeAddUse(path, typeLident, loc, Constructor(name)); - - let nameLoc = Utils.endOfLocation(loc, String.length(name)); - let t = getTypeAtPath(path); - let locType = - switch (t) { - | `Local({stamp, item: {kind: Variant(constructors)}}) => - switch (constructors |> List.find_opt(c => c.cname.txt == cstr_name)) { - | 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 - }; - addLocation(nameLoc, Typed(constructorType, locType)); - | _ => () - }; - }; - - let currentScopeExtent = () => - if (Collector.scopeExtent^ == []) { - Location.none; - } else { - List.hd(Collector.scopeExtent^); - }; - let addScopeExtent = loc => - Collector.scopeExtent := [loc, ...Collector.scopeExtent^]; - let popScopeExtent = () => - if (List.length(Collector.scopeExtent^) > 1) { - Collector.scopeExtent := List.tl(Collector.scopeExtent^); - }; - - let rec addForLongident = (top, path: Path.t, txt: Longident.t, loc) => - if (!loc.Location.loc_ghost) { - let idLength = - String.length(String.concat(".", Longident.flatten(txt))); - let reportedLength = loc.loc_end.pos_cnum - loc.loc_start.pos_cnum; - let isPpx = idLength != reportedLength; - if (isPpx) { - switch (top) { - | Some((t, tip)) => addForPath(path, txt, loc, t, tip) - | None => addForPathParent(path, loc) - }; - } else { - let l = - Utils.endOfLocation(loc, String.length(Longident.last(txt))); - switch (top) { - | Some((t, tip)) => addForPath(path, txt, l, t, tip) - | None => addForPathParent(path, l) - }; - switch (path, txt) { - | (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 => - switch (expr) { - | 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 => - switch (item.str_desc) { - | 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, - }, - }; - addForLongident(None, open_path, txt, loc); - Hashtbl.replace(Collector.extra.opens, loc, tracker); - | _ => () - }; - - let enter_structure = ({str_items}) => - if (str_items != []) { - let first = List.hd(str_items); - let last = List.nth(str_items, List.length(str_items) - 1); - - let extent = { - Location.loc_ghost: true, - loc_start: first.str_loc.loc_start, - loc_end: last.str_loc.loc_end, - }; - - addScopeExtent(extent); - }; - - let leave_structure = str => - if (str.str_items != []) { - popScopeExtent(); - }; - - let enter_signature_item = item => - switch (item.sig_desc) { - | Tsig_value({val_id, val_loc, val_name: name, val_desc, val_attributes}) => - let stamp = Ident.binding_time(val_id); - if (!Hashtbl.mem(Collector.file.stamps.values, stamp)) { - 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, - ~processDoc=x => [x], - ~item=val_desc.ctyp_type, - false, - val_attributes, - ); - 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}) => { - switch (ctyp_desc) { - | 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 (!Hashtbl.mem(Collector.file.stamps.values, stamp)) { - 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, - ~processDoc=x => [x], - ~item=pat_type, - false, - pat_attributes, - ); - Hashtbl.add(Collector.file.stamps.values, stamp, declared); - addReference(stamp, name.loc); - addLocation(name.loc, Typed(pat_type, Definition(stamp, Value))); - }; - /* Log.log("Entering pattern " ++ Utils.showLocation(pat_loc)); */ - switch (pat_desc) { - | 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); - addForPattern(stamp, name); - | Tpat_var(ident, name) => - /* Log.log("Pattern " ++ name.txt); */ - let stamp = Ident.binding_time(ident); - addForPattern(stamp, name); - | _ => () - }; - }; - - let enter_expression = expression => { - expression.exp_extra - |> List.iter(((e, eloc, _)) => - switch (e) { - | Texp_open(_, path, _ident, _) => - Hashtbl.add( - extra.opens, - eloc, - {path, loc: eloc, extent: expression.exp_loc, used: []}, - ) - | _ => () - } - ); - switch (expression.exp_desc) { - /* | Texp_apply({exp_desc: Pexp_ident(_, {txt: Ldot(Lident("ReasonReact"), "element")})}, [(_, {exp_desc: Pexp_apply({exp_desc: Pexp_ident(_, {txt})}, _)})]) =>{ - - } */ - | 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(((desc, item)) => - switch (item) { - | 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(_, _, _) => - addScopeExtent( - expression.exp_loc, - /* TODO this scope tracking won't work for recursive */ - ) - | Texp_function({cases}) => - switch (cases) { - | [{c_rhs}] => addScopeExtent(c_rhs.exp_loc) - | _ => () - } - | _ => () - }; - }; - - let leave_expression = expression => { - switch (expression.exp_desc) { - | Texp_let(_isrec, _bindings, _expr) => popScopeExtent() - | Texp_function({cases}) => - switch (cases) { - | [_] => popScopeExtent() - | _ => () - } - | _ => () - }; - }; -}; - -let forFile = (~file) => { - let extra = initExtra(); - let addLocation = (loc, ident) => - extra.locations = [(loc, ident), ...extra.locations]; - let addReference = (stamp, loc) => - Hashtbl.replace( - extra.internalReferences, - stamp, - [ - loc, - ...Hashtbl.mem(extra.internalReferences, stamp) - ? Hashtbl.find(extra.internalReferences, stamp) : [], - ], - ); - file.stamps.modules - |> Hashtbl.iter((stamp, d) => { - addLocation(d.name.loc, LModule(Definition(stamp, Module))); - addReference(stamp, d.name.loc); - }); - file.stamps.values - |> Hashtbl.iter((stamp, d) => { - addLocation(d.name.loc, Typed(d.item, Definition(stamp, Value))); - addReference(stamp, d.name.loc); - }); - file.stamps.types - |> Hashtbl.iter((stamp, d) => { - addLocation( - d.name.loc, - TypeDefinition(d.name.txt, d.item.Type.decl, stamp), - ); - addReference(stamp, d.name.loc); - switch (d.item.Type.kind) { - | Record(labels) => - labels - |> List.iter(({stamp, fname, typ}) => { - addReference(stamp, fname.loc); - addLocation( - fname.loc, - Typed(typ, Definition(d.stamp, Field(fname.txt))), - ); - }) - | Variant(constructos) => - constructos - |> List.iter(({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), - ), - }; - addLocation( - cname.loc, - Typed(t, Definition(d.stamp, Constructor(cname.txt))), - ); - }) - | _ => () - }; - }); - - extra; -}; - -let forItems = (~file, items, parts) => { - let extra = forFile(~file); - - let extent = ProcessCmt.itemsExtent(items); - let extent = { - ...extent, - loc_end: { - ...extent.loc_end, - pos_lnum: extent.loc_end.pos_lnum + 1000000, - pos_cnum: extent.loc_end.pos_cnum + 100000000, - }, - }; - - /* TODO look through parts and extend the extent */ - - module Iter = - TypedtreeIter.MakeIterator( - ( - F({ - let scopeExtent = ref([extent]); - let extra = extra; - let file = file; - }) - ), - ); - - List.iter(Iter.iter_structure_item, items); - /* Log.log("Parts " ++ string_of_int(Array.length(parts))); */ - - parts - |> Array.iter(part => - switch (part) { - | 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) => - switch (cmt_annots) { - | Partial_implementation(parts) => - let items = - parts - |> Array.to_list - |> Utils.filterMap((p: Cmt_format.binary_part) => - switch (p) { - | Partial_structure(str) => Some(str.str_items) - | Partial_structure_item(str) => Some([str]) - /* | Partial_expression(exp) => Some([ str]) */ - | _ => None - } - ) - |> List.concat; - 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/src/Process_406.ml b/src/Process_406.ml new file mode 100644 index 00000000..d8821d59 --- /dev/null +++ b/src/Process_406.ml @@ -0,0 +1,16 @@ +open SharedTypes + +let fileForCmt ~moduleName ~uri cmt processDoc = + match Shared.tryReadCmt cmt with + | Error e -> Error e + | Ok infos -> Ok (ProcessCmt.forCmt ~moduleName ~uri processDoc infos) + +let fullForCmt ~moduleName ~uri cmt processDoc = + match Shared.tryReadCmt cmt with + | Error e -> Error e + | Ok infos -> + let file = ProcessCmt.forCmt ~moduleName ~uri processDoc infos in + let extra = ProcessExtra.forCmt ~file infos in + Ok {file; extra} + +module PrintType = PrintType diff --git a/src/Process_406.mli b/src/Process_406.mli new file mode 100644 index 00000000..075aacc4 --- /dev/null +++ b/src/Process_406.mli @@ -0,0 +1,13 @@ +val fileForCmt : + moduleName:string -> + uri:Uri2.t -> + string -> + (string -> string list) -> + (SharedTypes.file, string) result + +val fullForCmt : + moduleName:string -> + uri:Uri2.t -> + string -> + (string -> string list) -> + (SharedTypes.full, string) result diff --git a/src/Process_406.re b/src/Process_406.re deleted file mode 100644 index 673000a3..00000000 --- a/src/Process_406.re +++ /dev/null @@ -1,18 +0,0 @@ -open SharedTypes; - -let fileForCmt = (~moduleName, ~uri, cmt, processDoc) => - switch (Shared.tryReadCmt(cmt)) { - | Error(e) => Error(e) - | Ok(infos) => Ok(ProcessCmt.forCmt(~moduleName, ~uri, processDoc, infos)) - }; - -let fullForCmt = (~moduleName, ~uri, cmt, processDoc) => - switch (Shared.tryReadCmt(cmt)) { - | Error(e) => Error(e) - | Ok(infos) => - let file = ProcessCmt.forCmt(~moduleName, ~uri, processDoc, infos); - let extra = ProcessExtra.forCmt(~file, infos); - Ok({file, extra}); - }; - -module PrintType = PrintType; diff --git a/src/Process_406.rei b/src/Process_406.rei deleted file mode 100644 index 6177c70c..00000000 --- a/src/Process_406.rei +++ /dev/null @@ -1,7 +0,0 @@ -let fileForCmt: - (~moduleName: string, ~uri: Uri2.t, string, string => list(string)) => - result(SharedTypes.file, string); - -let fullForCmt: - (~moduleName: string, ~uri: Uri2.t, string, string => list(string)) => - result(SharedTypes.full, string); diff --git a/src/Protocol.ml b/src/Protocol.ml new file mode 100644 index 00000000..df3418d4 --- /dev/null +++ b/src/Protocol.ml @@ -0,0 +1,7 @@ +module J = JsonShort + +let posOfLexing {Lexing.pos_lnum; pos_cnum; pos_bol} = + J.o [("line", J.i (pos_lnum - 1)); ("character", J.i (pos_cnum - pos_bol))] + +let rangeOfLoc {Location.loc_start; loc_end} = + J.o [("start", posOfLexing loc_start); ("end", posOfLexing loc_end)] diff --git a/src/Protocol.re b/src/Protocol.re deleted file mode 100644 index 62cb8078..00000000 --- a/src/Protocol.re +++ /dev/null @@ -1,10 +0,0 @@ -module J = JsonShort; - -let posOfLexing = ({Lexing.pos_lnum, pos_cnum, pos_bol}) => - J.o([ - ("line", J.i(pos_lnum - 1)), - ("character", J.i(pos_cnum - pos_bol)), - ]); - -let rangeOfLoc = ({Location.loc_start, loc_end}) => - J.o([("start", posOfLexing(loc_start)), ("end", posOfLexing(loc_end))]); diff --git a/src/Query.ml b/src/Query.ml new file mode 100644 index 00000000..e3e4f705 --- /dev/null +++ b/src/Query.ml @@ -0,0 +1,245 @@ +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/src/Query.re b/src/Query.re deleted file mode 100644 index 37b59356..00000000 --- a/src/Query.re +++ /dev/null @@ -1,326 +0,0 @@ -open SharedTypes; - -type queryEnv = { - file, - 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( - (_stamp, declared, result) => - if (declared.name.txt == name) { - /* Log.log("a stamp " ++ Utils.showLocation(declared.scopeLoc) ++ " " ++ string_of_int(l) ++ "," ++ string_of_int(c)); */ - if (locationIsBefore(declared.scopeLoc, pos)) { - switch (result) { - | None => Some(declared) - | Some(current) => - if (current.name.loc.loc_start.pos_cnum - < declared.name.loc.loc_start.pos_cnum) { - Some(declared); - } else { - result; - } - }; - } else { - result; - }; - } else { - /* Log.log("wrong name " ++ declared.name.txt); */ - result; - }, - stamps, - None, - ); -}; - -let rec joinPaths = (modulePath, path) => { - switch (modulePath) { - | 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 => { - switch (modulePath) { - | 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)) { - Some(tip); - } else { - switch (other) { - | Pdot(inner, name, _) => loop(basePath, inner, Nested(name, tip)) - | _ => None - }; - }; - switch (otherPath) { - | Path.Pdot(inner, name, _) => loop(basePath, inner, Tip(name)) - | _ => None - }; -}; - -let rec resolvePathInner = (~env, ~path) => { - switch (path) { - | Tip(name) => Some(`Local((env, name))) - | Nested(subName, subPath) => - switch (Hashtbl.find_opt(env.exported.modules, subName)) { - | None => None - | Some(stamp) => - switch (Hashtbl.find_opt(env.file.stamps.modules, stamp)) { - | None => None - | Some({item: kind}) => findInModule(~env, kind, subPath) - } - } - } -} -and findInModule = (~env, kind, path) => { - switch (kind) { - | Structure({exported}) => - resolvePathInner(~env={...env, exported}, ~path) - | Ident(modulePath) => - let (stamp, moduleName, fullPath) = joinPaths(modulePath, path); - if (stamp == 0) { - Some(`Global((moduleName, fullPath))); - } else { - switch (Hashtbl.find_opt(env.file.stamps.modules, stamp)) { - | None => None - | Some({item: kind}) => findInModule(~env, kind, fullPath) - }; - }; - }; -}; - -/* let rec findSubModule = (~env, ~getModule) */ - -let rec resolvePath = (~env, ~path, ~getModule) => { - switch (resolvePathInner(~env, ~path)) { - | None => None - | Some(result) => - switch (result) { - | `Local(env, name) => Some((env, name)) - | `Global(moduleName, fullPath) => - switch (getModule(moduleName)) { - | None => None - | Some(file) => - resolvePath(~env=fileEnv(file), ~path=fullPath, ~getModule) - } - } - }; -}; - -let resolveFromStamps = (~env, ~path, ~getModule, ~pos) => { - switch (path) { - | Tip(name) => Some((env, name)) - | Nested(name, inner) => - /* Log.log("Finding from stamps " ++ name); */ - switch (findInScope(pos, name, env.file.stamps.modules)) { - | None => None - | Some(declared) => - /* Log.log("found it"); */ - switch (findInModule(~env, declared.item, inner)) { - | None => None - | Some(res) => - switch (res) { - | `Local(env, name) => Some((env, name)) - | `Global(moduleName, fullPath) => - switch (getModule(moduleName)) { - | None => None - | Some(file) => - resolvePath(~env=fileEnv(file), ~path=fullPath, ~getModule) - } - } - } - } - }; -}; - -open Infix; - -let fromCompilerPath = (~env, path) => { - switch (makePath(path)) { - | `Stamp(stamp) => `Stamp(stamp) - | `Path(0, moduleName, path) => `Global((moduleName, path)) - | `GlobalMod(name) => `GlobalMod(name) - | `Path(stamp, _moduleName, path) => - let res = - switch (Hashtbl.find_opt(env.file.stamps.modules, stamp)) { - | None => None - | Some({item: kind}) => findInModule(~env, kind, path) - }; - switch (res) { - | None => `Not_found - | Some(`Local(env, name)) => `Exported((env, name)) - | Some(`Global(moduleName, fullPath)) => `Global((moduleName, fullPath)) - }; - }; -}; - -let resolveModuleFromCompilerPath = (~env, ~getModule, path) => { - switch (fromCompilerPath(~env, path)) { - | `Global(moduleName, path) => - switch (getModule(moduleName)) { - | None => None - | Some(file) => - let env = fileEnv(file); - switch (resolvePath(~env, ~getModule, ~path)) { - | None => None - | Some((env, name)) => - switch (Hashtbl.find_opt(env.exported.modules, name)) { - | None => None - | Some(stamp) => - switch (Hashtbl.find_opt(env.file.stamps.modules, stamp)) { - | None => None - | Some(declared) => Some((env, Some(declared))) - } - } - }; - } - | `Stamp(stamp) => - switch (Hashtbl.find_opt(env.file.stamps.modules, stamp)) { - | None => None - | Some(declared) => Some((env, Some(declared))) - } - | `GlobalMod(moduleName) => - switch (getModule(moduleName)) { - | None => None - | Some(file) => - let env = fileEnv(file); - Some((env, None)); - } - | `Not_found => None - | `Exported(env, name) => - switch (Hashtbl.find_opt(env.exported.modules, name)) { - | None => None - | Some(stamp) => - switch (Hashtbl.find_opt(env.file.stamps.modules, stamp)) { - | None => None - | Some(declared) => Some((env, Some(declared))) - } - } - }; -}; - -let resolveFromCompilerPath = (~env, ~getModule, path) => { - switch (fromCompilerPath(~env, path)) { - | `Global(moduleName, path) => - let res = - switch (getModule(moduleName)) { - | None => None - | Some(file) => - let env = fileEnv(file); - resolvePath(~env, ~getModule, ~path); - }; - switch (res) { - | 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) => - switch (tip) { - | Value => - Hashtbl.find_opt(exported.values, name) - |?> ( - stamp => - Hashtbl.find_opt(stamps.values, stamp) |?>> (x => {...x, item: ()}) - ) - | Field(_) - | Constructor(_) - | Type => - Hashtbl.find_opt(exported.types, name) - |?> ( - stamp => - Hashtbl.find_opt(stamps.types, stamp) |?>> (x => {...x, item: ()}) - ) - | Module => - Hashtbl.find_opt(exported.modules, name) - |?> ( - stamp => - Hashtbl.find_opt(stamps.modules, stamp) |?>> (x => {...x, item: ()}) - ) - }; - -let declaredForTip = (~stamps, stamp, tip) => - switch (tip) { - | Value => - Hashtbl.find_opt(stamps.values, stamp) |?>> (x => {...x, item: ()}) - | Field(_) - | Constructor(_) - | Type => - Hashtbl.find_opt(stamps.types, stamp) |?>> (x => {...x, item: ()}) - | Module => - Hashtbl.find_opt(stamps.modules, stamp) |?>> (x => {...x, item: ()}) - }; - -let getField = (file, stamp, name) => { - switch (Hashtbl.find_opt(file.stamps.types, stamp)) { - | None => None - | Some({item: {kind}}) => - switch (kind) { - | Record(fields) => fields |> List.find_opt(f => f.fname.txt == name) - | _ => None - } - }; -}; - -let getConstructor = (file, stamp, name) => { - switch (Hashtbl.find_opt(file.stamps.types, stamp)) { - | None => None - | Some({item: {kind}}) => - switch (kind) { - | Variant(constructors) => - switch (constructors |> List.find_opt(const => const.cname.txt == name)) { - | None => None - | Some(const) => Some(const) - } - | _ => None - } - }; -}; - -let exportedForTip = (~env, name, tip) => - switch (tip) { - | 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) => - switch (path) { - | File(uri, _moduleName) => uri - | NotVisible => env.file.uri - | IncludedModule(path, inner) => - Log.log("INCLUDED MODULE"); - switch (resolveModuleFromCompilerPath(~env, ~getModule, path)) { - | None => - Log.log("NOT FOUND"); - getSourceUri(~env, ~getModule, inner); - | Some((env, _declared)) => env.file.uri - }; - | ExportedModule(_, inner) => getSourceUri(~env, ~getModule, inner) - }; diff --git a/src/RResult.ml b/src/RResult.ml new file mode 100644 index 00000000..27a5d2de --- /dev/null +++ b/src/RResult.ml @@ -0,0 +1,20 @@ +let resultOfOption err v = match v with Some v -> Ok v | None -> Error err + +let orError = resultOfOption + +let toOptionAndLog err = + match err with + | Error e -> + Log.log e; + None + | Ok v -> Some v + +module InfixResult = struct + let ( |?>> ) a fn = match a with Ok a -> Ok (fn a) | Error e -> Error e + + let ( |? ) a default = match a with Ok a -> a | Error _ -> default +end + +open InfixResult + +let withDefault d v = v |? d diff --git a/src/RResult.re b/src/RResult.re deleted file mode 100644 index 8e50d3d4..00000000 --- a/src/RResult.re +++ /dev/null @@ -1,29 +0,0 @@ -let resultOfOption = (err, v) => - switch (v) { - | Some(v) => Ok(v) - | None => Error(err) - }; -let orError = resultOfOption; - -let toOptionAndLog = err => - switch (err) { - | Error(e) => - Log.log(e); - None; - | Ok(v) => Some(v) - }; - -module InfixResult = { - let (|?>>) = (a, fn) => - switch (a) { - | Ok(a) => Ok(fn(a)) - | Error(e) => Error(e) - }; - let (|?) = (a, default) => - switch (a) { - | Ok(a) => a - | Error(_) => default - }; -}; -open InfixResult; -let withDefault = (d, v) => v |? d; diff --git a/src/References.ml b/src/References.ml new file mode 100644 index 00000000..a4b7b9f0 --- /dev/null +++ b/src/References.ml @@ -0,0 +1,291 @@ +open SharedTypes + +let debugReferences = ref true + +let maybeLog m = if !debugReferences then Log.log ("[ref] " ^ m) + +let checkPos (line, char) + {Location.loc_start = {pos_lnum; pos_bol; pos_cnum}; loc_end} = + if line < pos_lnum || (line = pos_lnum && char < pos_cnum - pos_bol) then + false + else if + line > loc_end.pos_lnum + || (line = loc_end.pos_lnum && char > loc_end.pos_cnum - loc_end.pos_bol) + then false + else true + +let locsForPos ~extra pos = + extra.locations |> List.filter (fun (loc, _l) -> checkPos pos loc) + +let locForPos ~extra pos = + match locsForPos ~extra pos with + | [ + (loc1, Typed (_, LocalReference _)); + (loc2, Typed (_, GlobalReference ("Js_OO", Tip "unsafe_downgrade", _))); + ((loc3, _) as l3); + ] + when loc1 = loc2 && loc2 = loc3 -> + (* JSX and compiler combined: *) + (* ~x becomes Js_OO.unsafe_downgrade(Props)#x *) + (* heuristic for: [Props, unsafe_downgrade, x], give loc of `x` *) + Some l3 + | [(loc1, _); ((loc2, _) as l); (loc3, _)] when loc1 = loc2 && loc2 = loc3 -> + (* JSX with at most one child *) + (* heuristic for: [makeProps, make, createElement], give the loc of `make` *) + Some l + | [(loc1, _); (loc2, _); ((loc3, _) as l); (loc4, _)] + when loc1 = loc2 && loc2 = loc3 && loc3 = loc4 -> + (* JSX variadic, e.g. {x} {y} *) + (* heuristic for: [makeProps, React.null, make, createElementVariadic], give the loc of `make` *) + Some l + | l :: _ -> Some l + | _ -> None + +let definedForLoc ~file ~getModule locKind = + let inner ~file stamp tip = + match tip with + | Constructor name -> ( + match Query.getConstructor file stamp name with + | None -> None + | Some constructor -> Some ([], `Constructor constructor) ) + | Field name -> ( + match Query.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 + | None -> None + | Some declared -> Some (declared.docstring, `Declared) ) + in + match locKind with + | NotFound -> None + | LocalReference (stamp, tip) | Definition (stamp, tip) -> + inner ~file stamp tip + | GlobalReference (moduleName, path, tip) -> + ( maybeLog ("Getting global " ^ moduleName); + match + getModule moduleName + |> RResult.orError ("Cannot get module " ^ moduleName) + with + | Error e -> Error e + | Ok file -> ( + let env = Query.fileEnv file in + match + Query.resolvePath ~env ~path ~getModule + |> RResult.orError ("Cannot resolve path " ^ pathToString path) + with + | Error e -> Error e + | Ok (env, name) -> ( + match + Query.exportedForTip ~env name tip + |> RResult.orError + ("Exported not found for tip " ^ name ^ " > " ^ tipToString tip) + with + | Error e -> Error e + | Ok stamp -> ( + maybeLog ("Getting for " ^ string_of_int stamp ^ " in " ^ name); + match + inner ~file:env.file stamp tip + |> RResult.orError "could not get defined" + with + | Error e -> Error e + | Ok res -> + maybeLog "Yes!! got it"; + Ok res ) ) ) ) + |> RResult.toOptionAndLog + +let alternateDeclared ~file ~pathsForModule ~getUri declared tip = + match Hashtbl.find_opt pathsForModule file.moduleName with + | None -> None + | Some paths -> ( + maybeLog ("paths for " ^ file.moduleName); + match paths with + | IntfAndImpl (_, intf, _, impl) -> ( + maybeLog "Have both!!"; + let intfUri = Uri2.fromPath intf in + let implUri = Uri2.fromPath impl in + if intfUri = file.uri then + match getUri implUri |> RResult.toOptionAndLog with + | None -> None + | Some (file, extra) -> ( + match + Query.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 |> RResult.toOptionAndLog with + | None -> None + | Some (file, extra) -> ( + match + Query.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) = + match declared.item with + | Structure _ -> Some (file, Some declared) + | Ident path -> ( + let env = Query.fileEnv file in + match Query.fromCompilerPath ~env path with + | `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 md -> + Some (env.file, Some md) + (* Some((env.file.uri, validateLoc(md.name.loc, md.extentLoc))) *) + ) + ) + | `Global (moduleName, path) -> ( + match getModule moduleName with + | None -> None + | Some file -> ( + let env = Query.fileEnv file in + match Query.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 md -> + Some (env.file, Some md) + (* Some((env.file.uri, validateLoc(md.name.loc, md.extentLoc))) *) + ) + ) + ) + ) + | `Stamp stamp -> ( + match Hashtbl.find_opt file.stamps.modules stamp with + | None -> None + | Some md -> + Some (file, Some md) + (* Some((file.uri, validateLoc(md.name.loc, md.extentLoc))) *) + ) + | `GlobalMod name -> ( + match getModule name with + | None -> None + | Some file -> + (* maybeLog("Congrats, found a global mod"); *) + Some (file, None) + ) + | _ -> None ) + +let validateLoc (loc : Location.t) (backup : Location.t) = + if loc.loc_start.pos_cnum = -1 then + if backup.loc_start.pos_cnum = -1 then + { + Location.loc_ghost = true; + loc_start = {pos_cnum = 0; pos_lnum = 1; pos_bol = 0; pos_fname = ""}; + loc_end = {pos_cnum = 0; pos_lnum = 1; pos_bol = 0; pos_fname = ""}; + } + else backup + else loc + +let resolveModuleDefinition ~file ~getModule stamp = + match Hashtbl.find_opt file.stamps.modules stamp with + | None -> None + | Some md -> ( + match resolveModuleReference ~file ~getModule md with + | None -> None + | Some (file, declared) -> + let loc = + match declared with + | None -> Utils.topLoc (Uri2.toPath file.uri) + | Some declared -> validateLoc declared.name.loc declared.extentLoc + in + Some (file.uri, loc) ) + +let definition ~file ~getModule stamp tip = + match tip with + | Constructor name -> ( + match Query.getConstructor file stamp name with + | None -> None + | Some constructor -> Some (file.uri, constructor.cname.loc) ) + | Field name -> ( + match Query.getField file stamp name with + | None -> None + | Some field -> Some (file.uri, field.fname.loc) ) + | Module -> resolveModuleDefinition ~file ~getModule stamp + | _ -> ( + match Query.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 + maybeLog ("Inner uri " ^ Uri2.toString uri); + Some (uri, loc) ) + +let orLog message v = + match v with + | None -> + maybeLog message; + None + | _ -> v + +let definitionForLoc ~pathsForModule ~file ~getUri ~getModule 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 + | 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 + | None -> None + | Some (file, _extra, declared) -> + let loc = validateLoc declared.name.loc declared.extentLoc in + Some (file.uri, loc) ) + else None ) + | Explanation _ + | Typed (_, NotFound) + | LModule (NotFound | Definition (_, _)) + | TypeDefinition (_, _, _) + | Constant _ -> + None + | TopLevelModule name -> ( + maybeLog ("Toplevel " ^ name); + let open Infix in + match + Hashtbl.find_opt pathsForModule name + |> orLog "No paths found" |?> getSrc |> orLog "No src found" + with + | None -> None + | Some src -> Some (Uri2.fromPath src, Utils.topLoc src) ) + | LModule (LocalReference (stamp, tip)) + | Typed (_, LocalReference (stamp, tip)) -> + maybeLog ("Local defn " ^ tipToString tip); + definition ~file ~getModule stamp tip + | LModule (GlobalReference (moduleName, path, tip)) + | Typed (_, GlobalReference (moduleName, path, tip)) -> ( + maybeLog + ( "Global defn " ^ moduleName ^ " " ^ pathToString path ^ " : " + ^ tipToString tip ); + match getModule moduleName with + | None -> None + | Some file -> ( + let env = Query.fileEnv file in + match Query.resolvePath ~env ~path ~getModule with + | None -> None + | Some (env, name) -> ( + match Query.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 ) ) ) diff --git a/src/References.re b/src/References.re deleted file mode 100644 index 64ba7a28..00000000 --- a/src/References.re +++ /dev/null @@ -1,391 +0,0 @@ -open SharedTypes; - -let debugReferences = ref(true); - -let maybeLog = m => - if (debugReferences^) { - Log.log("[ref] " ++ m); - }; - -let checkPos = - ( - (line, char), - {Location.loc_start: {pos_lnum, pos_bol, pos_cnum}, loc_end}, - ) => - if (line < pos_lnum || line == pos_lnum && char < pos_cnum - pos_bol) { - false; - } else if (line > loc_end.pos_lnum - || line == loc_end.pos_lnum - && char > loc_end.pos_cnum - - loc_end.pos_bol) { - false; - } else { - true; - }; - -let locsForPos = (~extra, pos) => { - extra.locations |> List.filter(((loc, _l)) => checkPos(pos, loc)); -}; - -let locForPos = (~extra, pos) => { - switch (locsForPos(~extra, pos)) { - | [ - (loc1, Typed(_, LocalReference(_))), - ( - loc2, - Typed(_, GlobalReference("Js_OO", Tip("unsafe_downgrade"), _)), - ), - (loc3, _) as l3, - ] - when loc1 == loc2 && loc2 == loc3 => - // JSX and compiler combined: - // ~x becomes Js_OO.unsafe_downgrade(Props)#x - // heuristic for: [Props, unsafe_downgrade, x], give loc of `x` - Some(l3) - | [(loc1, _), (loc2, _) as l, (loc3, _)] - when loc1 == loc2 && loc2 == loc3 => - // JSX with at most one child - // heuristic for: [makeProps, make, createElement], give the loc of `make` - Some(l) - | [(loc1, _), (loc2, _), (loc3, _) as l, (loc4, _)] - when loc1 == loc2 && loc2 == loc3 && loc3 == loc4 => - // JSX variadic, e.g. {x} {y} - // heuristic for: [makeProps, React.null, make, createElementVariadic], give the loc of `make` - Some(l) - | [l, ..._] => Some(l) - | _ => None - }; -}; - -let definedForLoc = (~file, ~getModule, locKind) => { - let inner = (~file, stamp, tip) => { - switch (tip) { - | Constructor(name) => - switch (Query.getConstructor(file, stamp, name)) { - | None => None - | Some(constructor) => Some(([], `Constructor(constructor))) - } - | Field(name) => - switch (Query.getField(file, stamp, name)) { - | None => None - | Some(field) => Some(([], `Field(field))) - } - | _ => - maybeLog( - "Trying for declared " - ++ tipToString(tip) - ++ " " - ++ string_of_int(stamp) - ++ " in file " - ++ Uri2.toString(file.uri), - ); - switch (Query.declaredForTip(~stamps=file.stamps, stamp, tip)) { - | None => None - | Some(declared) => Some((declared.docstring, `Declared)) - }; - }; - }; - - switch (locKind) { - | NotFound => None - | LocalReference(stamp, tip) - | Definition(stamp, tip) => inner(~file, stamp, tip) - | GlobalReference(moduleName, path, tip) => - { - maybeLog("Getting global " ++ moduleName); - switch ( - getModule(moduleName) - |> RResult.orError("Cannot get module " ++ moduleName) - ) { - | Error(e) => Error(e) - | Ok(file) => - let env = Query.fileEnv(file); - switch ( - Query.resolvePath(~env, ~path, ~getModule) - |> RResult.orError("Cannot resolve path " ++ pathToString(path)) - ) { - | Error(e) => Error(e) - | Ok((env, name)) => - switch ( - Query.exportedForTip(~env, name, tip) - |> RResult.orError( - "Exported not found for tip " - ++ name - ++ " > " - ++ tipToString(tip), - ) - ) { - | Error(e) => Error(e) - | Ok(stamp) => - maybeLog( - "Getting for " ++ string_of_int(stamp) ++ " in " ++ name, - ); - switch ( - inner(~file=env.file, stamp, tip) - |> RResult.orError("could not get defined") - ) { - | Error(e) => Error(e) - | Ok(res) => - maybeLog("Yes!! got it"); - Ok(res); - }; - } - }; - }; - } - |> RResult.toOptionAndLog - }; -}; - -let alternateDeclared = (~file, ~pathsForModule, ~getUri, declared, tip) => { - switch (Hashtbl.find_opt(pathsForModule, file.moduleName)) { - | None => None - | Some(paths) => - maybeLog("paths for " ++ file.moduleName); - switch (paths) { - | IntfAndImpl(_, intf, _, impl) => - maybeLog("Have both!!"); - let intfUri = Uri2.fromPath(intf); - let implUri = Uri2.fromPath(impl); - if (intfUri == file.uri) { - switch (getUri(implUri) |> RResult.toOptionAndLog) { - | None => None - | Some((file, extra)) => - switch ( - Query.declaredForExportedTip( - ~stamps=file.stamps, - ~exported=file.contents.exported, - declared.name.txt, - tip, - ) - ) { - | None => None - | Some(declared) => Some((file, extra, declared)) - } - }; - } else { - switch (getUri(intfUri) |> RResult.toOptionAndLog) { - | None => None - | Some((file, extra)) => - switch ( - Query.declaredForExportedTip( - ~stamps=file.stamps, - ~exported=file.contents.exported, - declared.name.txt, - tip, - ) - ) { - | None => None - | Some(declared) => Some((file, extra, declared)) - } - }; - }; - | _ => None - }; - }; -}; - -let resolveModuleReference = - (~file, ~getModule, declared: declared(moduleKind)) => { - switch (declared.item) { - | Structure(_) => Some((file, Some(declared))) - | Ident(path) => - let env = Query.fileEnv(file); - switch (Query.fromCompilerPath(~env, path)) { - | `Not_found => None - | `Exported(env, name) => - switch (Hashtbl.find_opt(env.exported.modules, name)) { - | None => None - | Some(stamp) => - switch (Hashtbl.find_opt(env.file.stamps.modules, stamp)) { - | None => None - | Some(md) => Some((env.file, Some(md))) - /* Some((env.file.uri, validateLoc(md.name.loc, md.extentLoc))) */ - } - } - | `Global(moduleName, path) => - switch (getModule(moduleName)) { - | None => None - | Some(file) => - let env = Query.fileEnv(file); - switch (Query.resolvePath(~env, ~getModule, ~path)) { - | None => None - | Some((env, name)) => - switch (Hashtbl.find_opt(env.exported.modules, name)) { - | None => None - | Some(stamp) => - switch (Hashtbl.find_opt(env.file.stamps.modules, stamp)) { - | None => None - | Some(md) => Some((env.file, Some(md))) - /* Some((env.file.uri, validateLoc(md.name.loc, md.extentLoc))) */ - } - } - }; - } - | `Stamp(stamp) => - switch (Hashtbl.find_opt(file.stamps.modules, stamp)) { - | None => None - | Some(md) => Some((file, Some(md))) - /* Some((file.uri, validateLoc(md.name.loc, md.extentLoc))) */ - } - | `GlobalMod(name) => - switch (getModule(name)) { - | None => None - | Some(file) => - /* maybeLog("Congrats, found a global mod"); */ - Some((file, None)) - } - | _ => None - }; - }; -}; - -let validateLoc = (loc: Location.t, backup: Location.t) => - if (loc.loc_start.pos_cnum == (-1)) { - if (backup.loc_start.pos_cnum == (-1)) { - { - Location.loc_ghost: true, - loc_start: { - pos_cnum: 0, - pos_lnum: 1, - pos_bol: 0, - pos_fname: "", - }, - loc_end: { - pos_cnum: 0, - pos_lnum: 1, - pos_bol: 0, - pos_fname: "", - }, - }; - } else { - backup; - }; - } else { - loc; - }; - -let resolveModuleDefinition = (~file, ~getModule, stamp) => { - switch (Hashtbl.find_opt(file.stamps.modules, stamp)) { - | None => None - | Some(md) => - switch (resolveModuleReference(~file, ~getModule, md)) { - | None => None - | Some((file, declared)) => - let loc = - switch (declared) { - | None => Utils.topLoc(Uri2.toPath(file.uri)) - | Some(declared) => - validateLoc(declared.name.loc, declared.extentLoc) - }; - Some((file.uri, loc)); - } - }; -}; - -let definition = (~file, ~getModule, stamp, tip) => { - switch (tip) { - | Constructor(name) => - switch (Query.getConstructor(file, stamp, name)) { - | None => None - | Some(constructor) => Some((file.uri, constructor.cname.loc)) - } - | Field(name) => - switch (Query.getField(file, stamp, name)) { - | None => None - | Some(field) => Some((file.uri, field.fname.loc)) - } - | Module => resolveModuleDefinition(~file, ~getModule, stamp) - | _ => - switch (Query.declaredForTip(~stamps=file.stamps, stamp, tip)) { - | None => None - | Some(declared) => - let loc = validateLoc(declared.name.loc, declared.extentLoc); - let env = Query.fileEnv(file); - let uri = Query.getSourceUri(~env, ~getModule, declared.modulePath); - maybeLog("Inner uri " ++ Uri2.toString(uri)); - Some((uri, loc)); - } - }; -}; - -let orLog = (message, v) => - switch (v) { - | None => - maybeLog(message); - None; - | _ => v - }; - -let definitionForLoc = (~pathsForModule, ~file, ~getUri, ~getModule, loc) => { - switch (loc) { - | Typed(_, Definition(stamp, tip)) => - maybeLog("Trying to find a defintion for a definition"); - switch (Query.declaredForTip(~stamps=file.stamps, stamp, tip)) { - | None => None - | Some(declared) => - maybeLog("Declared"); - if (declared.exported) { - maybeLog("exported, looking for alternate " ++ file.moduleName); - switch ( - alternateDeclared(~pathsForModule, ~file, ~getUri, declared, tip) - ) { - | None => None - | Some((file, _extra, declared)) => - let loc = validateLoc(declared.name.loc, declared.extentLoc); - Some((file.uri, loc)); - }; - } else { - None; - }; - }; - | Explanation(_) - | Typed(_, NotFound) - | LModule(NotFound | Definition(_, _)) - | TypeDefinition(_, _, _) - | Constant(_) => None - | TopLevelModule(name) => - maybeLog("Toplevel " ++ name); - Infix.( - switch ( - Hashtbl.find_opt(pathsForModule, name) - |> orLog("No paths found") - |?> getSrc - |> orLog("No src found") - ) { - | None => None - | Some(src) => Some((Uri2.fromPath(src), Utils.topLoc(src))) - } - ); - | LModule(LocalReference(stamp, tip)) - | Typed(_, LocalReference(stamp, tip)) => - maybeLog("Local defn " ++ tipToString(tip)); - definition(~file, ~getModule, stamp, tip); - | LModule(GlobalReference(moduleName, path, tip)) - | Typed(_, GlobalReference(moduleName, path, tip)) => - maybeLog( - "Global defn " - ++ moduleName - ++ " " - ++ pathToString(path) - ++ " : " - ++ tipToString(tip), - ); - switch (getModule(moduleName)) { - | None => None - | Some(file) => - let env = Query.fileEnv(file); - switch (Query.resolvePath(~env, ~path, ~getModule)) { - | None => None - | Some((env, name)) => - switch (Query.exportedForTip(~env, name, tip)) { - | 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); - } - }; - }; - }; -}; diff --git a/src/RescriptEditorSupport.ml b/src/RescriptEditorSupport.ml new file mode 100644 index 00000000..bae082bb --- /dev/null +++ b/src/RescriptEditorSupport.ml @@ -0,0 +1,51 @@ +module J = JsonShort +module StringSet = Set.Make (String) + +let parseArgs args = + match args with + | [] -> assert false + | _ :: args -> + let opts, pos = + args |> List.rev + |> List.fold_left + (fun (set, pos) arg -> + if arg <> "" && arg.[0] = '-' then (set |> StringSet.add arg, pos) + else (set, arg :: pos)) + (StringSet.empty, []) + in + (opts, pos) + +let hasOpt opts name = opts |> StringSet.mem name + +let hasOpts opts names = names |> List.exists (opts |> hasOpt) + +let help = + {| +Commands for Rescript Language Server + +-dump: compute definition and hover for Foo.res at line 0 and column 4: + +rescript-editor-support.exe dump src/Foo.res:0:4 + +-complete: compute autocomplete for Foo.res at line 0 and column 4, + where Foo.res is being edited and the editor content is in file current.res. + +rescript-editor-support.exe complete src/Foo.res:0:4 current.res + +The dump command can also omit `:line:column`, to show results for every position in the file. Several files can be specified on the command line. +|} + +let showHelp () = prerr_endline help + +let main () = + match parseArgs (Sys.argv |> Array.to_list) with + | opts, _ when hasOpts opts ["-h"; "--help"] -> showHelp () + | _opts, "dump" :: files -> EditorSupportCommands.dump files + | _opts, ["complete"; pathWithPos; currentFile] -> + EditorSupportCommands.complete ~pathWithPos ~currentFile + | _ -> + showHelp (); + exit 1 +;; + +main () diff --git a/src/RescriptEditorSupport.re b/src/RescriptEditorSupport.re deleted file mode 100644 index 3821feb8..00000000 --- a/src/RescriptEditorSupport.re +++ /dev/null @@ -1,59 +0,0 @@ -module J = JsonShort; -module StringSet = Set.Make(String); - -let parseArgs = args => { - switch (args) { - | [] => assert(false) - | [_, ...args] => - let (opts, pos) = - args - |> List.rev - |> List.fold_left( - ((set, pos), arg) => - if (arg != "" && arg.[0] == '-') { - (set |> StringSet.add(arg), pos); - } else { - (set, [arg, ...pos]); - }, - (StringSet.empty, []), - ); - (opts, pos); - }; -}; - -let hasOpt = (opts, name) => opts |> StringSet.mem(name); - -let hasOpts = (opts, names) => names |> List.exists(opts |> hasOpt); - -let help = {| -Commands for Rescript Language Server - --dump: compute definition and hover for Foo.res at line 0 and column 4: - -rescript-editor-support.exe dump src/Foo.res:0:4 - --complete: compute autocomplete for Foo.res at line 0 and column 4, - where Foo.res is being edited and the editor content is in file current.res. - -rescript-editor-support.exe complete src/Foo.res:0:4 current.res - -The dump command can also omit `:line:column`, to show results for every position in the file. Several files can be specified on the command line. -|}; - -let showHelp = () => { - prerr_endline(help); -}; - -let main = () => { - switch (parseArgs(Sys.argv |> Array.to_list)) { - | (opts, _) when hasOpts(opts, ["-h", "--help"]) => showHelp() - | (_opts, ["dump", ...files]) => EditorSupportCommands.dump(files) - | (_opts, ["complete", pathWithPos, currentFile]) => - EditorSupportCommands.complete(~pathWithPos, ~currentFile) - | _ => - showHelp(); - exit(1); - }; -}; - -main(); diff --git a/src/Shared.ml b/src/Shared.ml new file mode 100644 index 00000000..b9fee0cc --- /dev/null +++ b/src/Shared.ml @@ -0,0 +1,50 @@ +let tryReadCmt cmt = + if not (Files.exists cmt) then Error ("Cmt file does not exist " ^ cmt) + else + match Cmt_format.read_cmt cmt with + | exception Cmi_format.Error err -> + Error + ( "Failed to load " ^ cmt ^ " as a cmt w/ ocaml version " ^ "406" + ^ ", error: " + ^ + ( Cmi_format.report_error Format.str_formatter err; + Format.flush_str_formatter () ) ) + | exception err -> + Error + ( "Invalid cmt format " ^ cmt + ^ " - probably wrong ocaml version, expected " ^ Config.version ^ " : " + ^ Printexc.to_string err ) + | x -> Ok x + +(** TODO move to the Process_ stuff *) +let rec dig typ = + match typ.Types.desc with + | Types.Tlink inner -> dig inner + | Types.Tsubst inner -> dig inner + | Types.Tpoly (inner, _) -> dig inner + | _ -> typ + +let digConstructor expr = + let expr = dig expr in + match expr.desc with + | Tconstr (path, _args, _memo) -> Some path + | _ -> None + +let declToString ?(recStatus = Types.Trec_not) name t = + PrintType.printDecl ~recStatus name t + +let cacheTypeToString = ref false + +let typeTbl = Hashtbl.create 1 + +let typeToString (t : Types.type_expr) = + match + match !cacheTypeToString with + | true -> Hashtbl.find_opt typeTbl (t.id, t) + | false -> None + with + | None -> + let s = PrintType.printExpr t in + Hashtbl.replace typeTbl (t.id, t) s; + s + | Some s -> s diff --git a/src/Shared.re b/src/Shared.re deleted file mode 100644 index 5be917fc..00000000 --- a/src/Shared.re +++ /dev/null @@ -1,62 +0,0 @@ -let tryReadCmt = cmt => - if (!Files.exists(cmt)) { - Error("Cmt file does not exist " ++ cmt); - } else { - switch (Cmt_format.read_cmt(cmt)) { - | exception (Cmi_format.Error(err)) => - Error( - "Failed to load " - ++ cmt - ++ " as a cmt w/ ocaml version " - ++ "406" - ++ ", error: " - ++ { - Cmi_format.report_error(Format.str_formatter, err); - Format.flush_str_formatter(); - }, - ) - | exception err => - Error( - "Invalid cmt format " - ++ cmt - ++ " - probably wrong ocaml version, expected " - ++ Config.version - ++ " : " - ++ Printexc.to_string(err), - ) - | x => Ok(x) - }; - }; - -/** TODO move to the Process_ stuff */ -let rec dig = typ => - switch (typ.Types.desc) { - | Types.Tlink(inner) => dig(inner) - | Types.Tsubst(inner) => dig(inner) - | Types.Tpoly(inner, _) => dig(inner) - | _ => typ - }; - -let digConstructor = expr => { - let expr = dig(expr); - switch (expr.desc) { - | Tconstr(path, _args, _memo) => Some(path) - | _ => None - }; -}; - -let declToString = (~recStatus=Types.Trec_not, name, t) => - PrintType.printDecl(~recStatus, name, t); - -let cacheTypeToString = ref(false); -let typeTbl = Hashtbl.create(1); - -let typeToString = (t: Types.type_expr) => { - switch (cacheTypeToString^ ? Hashtbl.find_opt(typeTbl, (t.id, t)) : None) { - | None => - let s = PrintType.printExpr(t); - Hashtbl.replace(typeTbl, (t.id, t), s); - s; - | Some(s) => s - }; -}; diff --git a/src/SharedTypes.ml b/src/SharedTypes.ml new file mode 100644 index 00000000..a9ff44d4 --- /dev/null +++ b/src/SharedTypes.ml @@ -0,0 +1,217 @@ +type filePath = string + +type paths = + | Impl of filePath * filePath option + | Intf of filePath * filePath + (* .cm(t)i, .mli, .cmt, .rei *) + | IntfAndImpl of filePath * filePath * filePath * filePath + +open Infix + +let showPaths paths = + match paths with + | Impl (cmt, src) -> Printf.sprintf "Impl(%s, %s)" cmt (src |? "nil") + | Intf (cmti, src) -> Printf.sprintf "Intf(%s, %s)" cmti src + | IntfAndImpl (cmti, srci, cmt, src) -> + Printf.sprintf "IntfAndImpl(%s, %s, %s, %s)" cmti srci cmt src + +let getSrc p = + match p with + | Impl (_, s) -> s + | Intf (_, s) | IntfAndImpl (_, s, _, _) -> Some s + +let getCmt ?(interface = true) p = + match p with + | Impl (c, _) | Intf (c, _) -> c + | IntfAndImpl (cint, _, cimpl, _) -> ( + match interface with true -> cint | false -> cimpl ) + +type visibilityPath = + | File of Uri2.t * string + | NotVisible + | IncludedModule of Path.t * visibilityPath + | ExportedModule of string * visibilityPath + +type 't declared = { + name : string Location.loc; + extentLoc : Location.t; + scopeLoc : Location.t; + stamp : int; + modulePath : visibilityPath; + exported : bool; + deprecated : string option; + docstring : string list; + item : 't; + (* TODO: maybe add a uri? *) + (* scopeType: scope, *) + (* scopeStart: (int, int), *) +} + +let emptyDeclared name = + { + name = Location.mknoloc name; + extentLoc = Location.none; + scopeLoc = Location.none; + stamp = 0; + modulePath = NotVisible; + exported = false; + deprecated = None; + docstring = []; + item = (); + } + +type field = {stamp : int; fname : string Location.loc; typ : Types.type_expr} + +type constructor = { + stamp : int; + cname : string Location.loc; + args : (Types.type_expr * Location.t) list; + res : Types.type_expr option; +} + +module Type = struct + type kind = + | Abstract of (Path.t * Types.type_expr list) option + | Open + | Tuple of Types.type_expr list + | Record of field list + | Variant of constructor list + + type t = {kind : kind; decl : Types.type_declaration} +end + +(* type scope = + | File + | Switch + | Module + | Let + | LetRec; *) + +type 't namedMap = (string, 't) Hashtbl.t + +type namedStampMap = int namedMap + +type exported = { + types : namedStampMap; + values : namedStampMap; + modules : namedStampMap; + (* constructors: namedStampMap, *) + (* classes: namedStampMap, + classTypes: namedStampMap, *) +} + +let initExported () = + { + types = Hashtbl.create 10; + values = Hashtbl.create 10; + modules = Hashtbl.create 10; + (* constructors: Hashtbl.create(10), *) + } + +type moduleItem = + | MValue of Types.type_expr + | MType of Type.t * Types.rec_status + | Module of moduleKind + +and moduleContents = { + docstring : string list; + exported : exported; + topLevel : moduleItem declared list; +} + +and moduleKind = Ident of Path.t | Structure of moduleContents + +type 't stampMap = (int, 't) Hashtbl.t + +type stamps = { + types : Type.t declared stampMap; + values : Types.type_expr declared stampMap; + modules : moduleKind declared stampMap; + constructors : constructor declared stampMap; +} + +let initStamps () = + { + types = Hashtbl.create 10; + values = Hashtbl.create 10; + modules = Hashtbl.create 10; + constructors = Hashtbl.create 10; + } + +type file = { + uri : Uri2.t; + stamps : stamps; + moduleName : string; + contents : moduleContents; +} + +let emptyFile moduleName uri = + { + uri; + stamps = initStamps (); + moduleName; + contents = {docstring = []; exported = initExported (); topLevel = []}; + } + +type tip = Value | Type | Field of string | Constructor of string | Module + +let tipToString tip = + match tip with + | Value -> "Value" + | Type -> "Type" + | Field f -> "Field(" ^ f ^ ")" + | Constructor a -> "Constructor(" ^ a ^ ")" + | Module -> "Module" + +type path = Tip of string | Nested of string * path + +let rec pathToString path = + match path with + | Tip name -> name + | Nested (name, inner) -> name ^ "." ^ pathToString inner + +type locKind = + | LocalReference of int * tip + | GlobalReference of string * path * tip + | NotFound + | Definition of int * tip + +type loc = + | Typed of Types.type_expr * locKind + | Constant of Asttypes.constant + | LModule of locKind + | TopLevelModule of string + | TypeDefinition of string * Types.type_declaration * int + | Explanation of string + +type openTracker = { + path : Path.t; + loc : Location.t; + extent : Location.t; + mutable used : (path * tip * Location.t) list; +} + +(** These are the bits of info that we need to make in-app stuff awesome *) +type extra = { + internalReferences : (int, Location.t list) Hashtbl.t; + externalReferences : (string, (path * tip * Location.t) list) Hashtbl.t; + mutable locations : (Location.t * loc) list; + (* This is the "open location", like the location... + or maybe the >> location of the open ident maybe *) + (* OPTIMIZE: using a stack to come up with this would cut the computation time of this considerably. *) + opens : (Location.t, openTracker) Hashtbl.t; +} +[@@ocaml.doc + " These are the bits of info that we need to make in-app stuff awesome "] + +type full = {extra : extra; file : file} + +let initExtra () = + { + internalReferences = Hashtbl.create 10; + externalReferences = Hashtbl.create 10; + locations = []; + opens = Hashtbl.create 10; + } + +let hashList h = Hashtbl.fold (fun a b c -> (a, b) :: c) h [] diff --git a/src/SharedTypes.re b/src/SharedTypes.re deleted file mode 100644 index b0ee5554..00000000 --- a/src/SharedTypes.re +++ /dev/null @@ -1,232 +0,0 @@ -type filePath = string; -type paths = - | Impl(filePath, option(filePath)) - | Intf(filePath, filePath) - // .cm(t)i, .mli, .cmt, .rei - | IntfAndImpl(filePath, filePath, filePath, filePath); - -open Infix; -let showPaths = paths => - switch (paths) { - | Impl(cmt, src) => Printf.sprintf("Impl(%s, %s)", cmt, src |? "nil") - | Intf(cmti, src) => Printf.sprintf("Intf(%s, %s)", cmti, src) - | IntfAndImpl(cmti, srci, cmt, src) => - Printf.sprintf("IntfAndImpl(%s, %s, %s, %s)", cmti, srci, cmt, src) - }; - -let getSrc = p => - switch (p) { - | Impl(_, s) => s - | Intf(_, s) - | IntfAndImpl(_, s, _, _) => Some(s) - }; - -let getCmt = (~interface=true, p) => - switch (p) { - | Impl(c, _) - | Intf(c, _) => c - | IntfAndImpl(cint, _, cimpl, _) => interface ? cint : cimpl - }; - -type visibilityPath = - | File(Uri2.t, string) - | NotVisible - | IncludedModule(Path.t, visibilityPath) - | ExportedModule(string, visibilityPath); - -type declared('t) = { - name: Location.loc(string), - extentLoc: Location.t, - scopeLoc: Location.t, - stamp: int, - modulePath: visibilityPath, - exported: bool, - deprecated: option(string), - docstring: list(string), - item: 't, - /* TODO maybe add a uri? */ - /* scopeType: scope, */ - /* scopeStart: (int, int), */ -}; - -let emptyDeclared = name => { - name: Location.mknoloc(name), - extentLoc: Location.none, - scopeLoc: Location.none, - stamp: 0, - modulePath: NotVisible, - exported: false, - deprecated: None, - docstring: [], - item: (), -}; - -type field = { - stamp: int, - fname: Location.loc(string), - typ: Types.type_expr, -}; - -type constructor = { - stamp: int, - cname: Location.loc(string), - args: list((Types.type_expr, Location.t)), - res: option(Types.type_expr), -}; - -module Type = { - type kind = - | Abstract(option((Path.t, list(Types.type_expr)))) - | Open - | Tuple(list(Types.type_expr)) - | Record(list(field)) - | Variant(list(constructor)); - - type t = { - kind, - decl: Types.type_declaration, - }; -}; - -/* type scope = - | File - | Switch - | Module - | Let - | LetRec; */ - -type namedMap('t) = Hashtbl.t(string, 't); -type namedStampMap = namedMap(int); - -type exported = { - types: namedStampMap, - values: namedStampMap, - modules: namedStampMap, - /* constructors: namedStampMap, */ - /* classes: namedStampMap, - classTypes: namedStampMap, */ -}; -let initExported = () => { - types: Hashtbl.create(10), - values: Hashtbl.create(10), - modules: Hashtbl.create(10), - /* constructors: Hashtbl.create(10), */ -}; -type moduleItem = - | MValue(Types.type_expr) - | MType(Type.t, Types.rec_status) - | Module(moduleKind) -and moduleContents = { - docstring: list(string), - exported, - topLevel: list(declared(moduleItem)), -} -and moduleKind = - | Ident(Path.t) - | Structure(moduleContents); - -type stampMap('t) = Hashtbl.t(int, 't); - -type stamps = { - types: stampMap(declared(Type.t)), - values: stampMap(declared(Types.type_expr)), - modules: stampMap(declared(moduleKind)), - constructors: stampMap(declared(constructor)), -}; - -let initStamps = () => { - types: Hashtbl.create(10), - values: Hashtbl.create(10), - modules: Hashtbl.create(10), - constructors: Hashtbl.create(10), -}; - -type file = { - uri: Uri2.t, - stamps, - moduleName: string, - contents: moduleContents, -}; - -let emptyFile = (moduleName, uri) => { - uri, - stamps: initStamps(), - moduleName, - contents: { - docstring: [], - exported: initExported(), - topLevel: [], - }, -}; - -type tip = - | Value - | Type - | Field(string) - | Constructor(string) - | Module; - -let tipToString = tip => - switch (tip) { - | Value => "Value" - | Type => "Type" - | Field(f) => "Field(" ++ f ++ ")" - | Constructor(a) => "Constructor(" ++ a ++ ")" - | Module => "Module" - }; - -type path = - | Tip(string) - | Nested(string, path); - -let rec pathToString = path => - switch (path) { - | Tip(name) => name - | Nested(name, inner) => name ++ "." ++ pathToString(inner) - }; - -type locKind = - | LocalReference(int, tip) - | GlobalReference(string, path, tip) - | NotFound - | Definition(int, tip); - -type loc = - | Typed(Types.type_expr, locKind) - | Constant(Asttypes.constant) - | LModule(locKind) - | TopLevelModule(string) - | TypeDefinition(string, Types.type_declaration, int) - | Explanation(string); - -type openTracker = { - path: Path.t, - loc: Location.t, - extent: Location.t, - mutable used: list((path, tip, Location.t)), -}; - -/** These are the bits of info that we need to make in-app stuff awesome */ -type extra = { - internalReferences: Hashtbl.t(int, list(Location.t)), - externalReferences: Hashtbl.t(string, list((path, tip, Location.t))), - mutable locations: list((Location.t, loc)), - /* This is the "open location", like the location... - or maybe the >> location of the open ident maybe */ - /* OPTIMIZE: using a stack to come up with this would cut the computation time of this considerably. */ - opens: Hashtbl.t(Location.t, openTracker), -}; - -type full = { - extra, - file, -}; - -let initExtra = () => { - internalReferences: Hashtbl.create(10), - externalReferences: Hashtbl.create(10), - locations: [], - opens: Hashtbl.create(10), -}; - -let hashList = h => Hashtbl.fold((a, b, c) => [(a, b), ...c], h, []); diff --git a/src/State.ml b/src/State.ml new file mode 100644 index 00000000..d1dc2de5 --- /dev/null +++ b/src/State.ml @@ -0,0 +1,92 @@ +open Infix +open TopTypes + +let isMl path = + Filename.check_suffix path ".ml" || Filename.check_suffix path ".mli" + +let odocToMd text = MarkdownOfOCamldoc.convert text + +let compose fn1 fn2 arg = fn1 arg |> fn2 + +let converter src = + let mlToOutput s = [compose odocToMd Omd.to_markdown s] in + fold src mlToOutput (fun src -> + match isMl src with true -> mlToOutput | false -> fun x -> [x]) + +let newDocsForCmt ~moduleName cmtCache changed cmt src = + let uri = Uri2.fromPath (src |? cmt) in + match + Process_406.fileForCmt ~moduleName ~uri cmt (converter src) + |> RResult.toOptionAndLog + with + | None -> None + | Some file -> + Hashtbl.replace cmtCache cmt (changed, file); + Some file + +let docsForCmt ~moduleName cmt src state = + if Hashtbl.mem state.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 (fun x -> [x]) 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.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 diff --git a/src/State.re b/src/State.re deleted file mode 100644 index b881f3ae..00000000 --- a/src/State.re +++ /dev/null @@ -1,112 +0,0 @@ -open Infix; - -open TopTypes; - -let isMl = path => - Filename.check_suffix(path, ".ml") || Filename.check_suffix(path, ".mli"); - -let odocToMd = text => MarkdownOfOCamldoc.convert(text); -let compose = (fn1, fn2, arg) => fn1(arg) |> fn2; - -let converter = src => { - let mlToOutput = s => [compose(odocToMd, Omd.to_markdown, s)]; - fold(src, mlToOutput, src => isMl(src) ? mlToOutput : (x => [x])); -}; - -let newDocsForCmt = (~moduleName, cmtCache, changed, cmt, src) => { - let uri = Uri2.fromPath(src |? cmt); - switch ( - Process_406.fileForCmt(~moduleName, ~uri, cmt, converter(src)) - |> RResult.toOptionAndLog - ) { - | None => None - | Some(file) => - Hashtbl.replace(cmtCache, cmt, (changed, file)); - Some(file); - }; -}; - -let docsForCmt = (~moduleName, cmt, src, state) => - if (Hashtbl.mem(state.cmtCache, cmt)) { - let (mtime, docs) = Hashtbl.find(state.cmtCache, cmt); - /* TODO I should really throttle this mtime checking to like every 50 ms or so */ - switch (Files.getMtime(cmt)) { - | None => - Log.log("⚠️ cannot get docs for nonexistant cmt " ++ cmt); - None; - | Some(changed) => - if (changed > mtime) { - newDocsForCmt(~moduleName, state.cmtCache, changed, cmt, src); - } else { - Some(docs); - } - }; - } else { - switch (Files.getMtime(cmt)) { - | None => - Log.log("⚠️ 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); - switch (Packages.getPackage(uri, state)) { - | Error(e) => Error(e) - | Ok(package) => - let moduleName = - BuildSystem.namespacedName(package.namespace, FindFiles.getName(path)); - switch (Hashtbl.find_opt(package.pathsForModule, moduleName)) { - | Some(paths) => - let cmt = - SharedTypes.getCmt(~interface=Utils.endsWith(path, "i"), paths); - switch (Process_406.fullForCmt(~moduleName, ~uri, cmt, x => [x])) { - | 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.pathsForModule, modname)) { - let paths = Hashtbl.find(package.pathsForModule, modname); - /* TODO do better */ - let cmt = SharedTypes.getCmt(paths); - let src = SharedTypes.getSrc(paths); - Log.log("FINDING docs for module " ++ SharedTypes.showPaths(paths)); - Log.log("FINDING " ++ cmt ++ " src " ++ (src |? "")); - switch (docsForCmt(~moduleName=modname, cmt, src, state)) { - | None => None - | Some(docs) => Some((docs, src)) - }; - } else { - Log.log("No path for module " ++ modname); - None; - }; - -let fileForUri = (state, uri) => { - switch (getFullFromCmt(~state, ~uri)) { - | Error(e) => Error(e) - | Ok((_package, {extra, file})) => Ok((file, extra)) - }; -}; - -let fileForModule = (state, ~package, modname) => { - switch (docsForModule(modname, state, ~package)) { - | None => None - | Some((file, _)) => Some(file) - }; -}; diff --git a/src/TopTypes.ml b/src/TopTypes.ml new file mode 100644 index 00000000..1f200514 --- /dev/null +++ b/src/TopTypes.ml @@ -0,0 +1,31 @@ +(* Aliases to make the intents clearer *) +type uri = Uri2.t + +type filePath = string + +type moduleName = string + +(* Here are the things that will be different between jbuilder things *) +type package = { + rootPath : filePath; + (* Depend on bsb having already run *) + localModules : moduleName list; + interModuleDependencies : (moduleName, moduleName list) Hashtbl.t; + dependencyModules : moduleName list; + pathsForModule : (moduleName, SharedTypes.paths) Hashtbl.t; + namespace : string option; + opens : string list; +} + +type state = { + packagesByRoot : (string, package) Hashtbl.t; + rootForUri : (uri, string) Hashtbl.t; + cmtCache : (filePath, float * SharedTypes.file) Hashtbl.t; +} + +let empty () = + { + packagesByRoot = Hashtbl.create 1; + rootForUri = Hashtbl.create 30; + cmtCache = Hashtbl.create 30; + } diff --git a/src/TopTypes.re b/src/TopTypes.re deleted file mode 100644 index 7f480935..00000000 --- a/src/TopTypes.re +++ /dev/null @@ -1,28 +0,0 @@ -/* Aliases to make the intents clearer */ -type uri = Uri2.t; -type filePath = string; -type moduleName = string; - -/* Here are the things that will be different between jbuilder things */ -type package = { - rootPath: filePath, - /* Depend on bsb having already run */ - localModules: list(moduleName), - interModuleDependencies: Hashtbl.t(moduleName, list(moduleName)), - dependencyModules: list(moduleName), - pathsForModule: Hashtbl.t(moduleName, SharedTypes.paths), - namespace: option(string), - opens: list(string), -}; - -type state = { - packagesByRoot: Hashtbl.t(string, package), - rootForUri: Hashtbl.t(uri, string), - cmtCache: Hashtbl.t(filePath, (float, SharedTypes.file)), -}; - -let empty = () => { - packagesByRoot: Hashtbl.create(1), - rootForUri: Hashtbl.create(30), - cmtCache: Hashtbl.create(30), -}; diff --git a/src/Uri2.ml b/src/Uri2.ml new file mode 100644 index 00000000..a40cf0ab --- /dev/null +++ b/src/Uri2.ml @@ -0,0 +1,28 @@ +module Uri : sig + type t + + val fromPath : string -> t + + val toPath : t -> string + + val toString : t -> string +end = struct + type t = {path : string; uri : string} + + let pathToUri path = + if Sys.os_type = "Unix" then "file://" ^ path + else + "file://" + ^ ( 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") ) + + let fromPath path = {path; uri = pathToUri path} + + let toPath {path} = path + + let toString {uri} = uri +end + +include Uri diff --git a/src/Uri2.re b/src/Uri2.re deleted file mode 100644 index 9b6d1925..00000000 --- a/src/Uri2.re +++ /dev/null @@ -1,35 +0,0 @@ -module Uri: { - type t; - let fromPath: string => t; - let toPath: t => string; - let toString: t => string; -} = { - type t = { - path: string, - uri: string, - }; - - let pathToUri = path => - if (Sys.os_type == "Unix") { - "file://" ++ path; - } else { - "file://" - ++ ( - Str.global_replace(Str.regexp_string("\\"), "/", path) - |> Str.substitute_first( - Str.regexp("^\\([a-zA-Z]\\):"), - text => { - let name = Str.matched_group(1, text); - "/" ++ String.lowercase_ascii(name) ++ "%3A"; - }, - ) - ); - }; - - let fromPath = path => {path, uri: pathToUri(path)}; - - let toPath = ({path}) => path; - let toString = ({uri}) => uri; -}; - -include Uri; diff --git a/src/Utils.ml b/src/Utils.ml new file mode 100644 index 00000000..e65529de --- /dev/null +++ b/src/Utils.ml @@ -0,0 +1,127 @@ +(* + steal from OCaml stdlib + https://github.com/ocaml/ocaml/blob/7c9c210884e1b46f21af5bb4dfab995bb3336cf7/stdlib/string.ml#L205-L214 +*) +let split_on_char sep s = + let open String in + let r = ref [] in + let j = ref (length s) in + for i = length s - 1 downto 0 do + if unsafe_get s i = sep then ( + r := sub s (i + 1) (!j - i - 1) :: !r; + j := i ) + done; + sub s 0 !j :: !r + +let topLoc fname = + { + Location.loc_start = + {Lexing.pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0}; + Location.loc_end = + {Lexing.pos_fname = fname; pos_lnum = 1; pos_bol = 0; pos_cnum = 0}; + loc_ghost = false; + } + +(** + * `startsWith(string, prefix)` + * true if the string starts with the prefix + *) +let startsWith s prefix = + if prefix = "" then true + else + let p = String.length prefix in + p <= String.length s && String.sub s 0 p = prefix + +let endsWith s suffix = + if suffix = "" then true + else + let p = String.length suffix in + let l = String.length s in + p <= String.length s && String.sub s (l - p) p = suffix + +let cmtLocFromVscode (line, col) = (line + 1, col) + +let sliceToEnd s start = + let l = String.length s in + match start <= l with true -> String.sub s start (l - start) | false -> "" + +let locWithinLoc inner outer = + let open Location in + inner.loc_start.pos_cnum >= outer.loc_start.pos_cnum + && inner.loc_end.pos_cnum <= outer.loc_end.pos_cnum + +let endOfLocation loc length = + let open Location in + { + loc with + loc_start = {loc.loc_end with pos_cnum = loc.loc_end.pos_cnum - length}; + } + +let chopLocationEnd loc length = + let open Location in + { + loc with + loc_end = {loc.loc_end with pos_cnum = loc.loc_end.pos_cnum - length}; + } + +let chopPrefix s prefix = sliceToEnd s (String.length prefix) + +(** An optional List.find *) +let rec find fn items = + match items with + | [] -> None + | one :: rest -> ( + match fn one with None -> find fn rest | Some x -> Some x ) + +let dedup items = + let m = Hashtbl.create (List.length items) in + items + |> List.filter (fun a -> + if Hashtbl.mem m a then false + else ( + Hashtbl.add m a (); + true )) + +let tupleOfLexing {Lexing.pos_lnum; pos_cnum; pos_bol} = + (pos_lnum - 1, pos_cnum - pos_bol) + +(** + Check if pos is within the location, but be fuzzy about when the location ends. + If it's within 5 lines, go with it. +*) +let locationContainsFuzzy {Location.loc_start; loc_end} (l, c) = + tupleOfLexing loc_start <= (l, c) && tupleOfLexing loc_end >= (l - 5, c) + +(* + * Quotes filename when not quoted + * Example: + * myFile.exe -> 'myFile.exe' + * 'myFile.exe' -> 'myFile.exe' + *) +let maybeQuoteFilename filename = + let len = String.length filename in + if len < 1 then "" + else + let firstChar = filename.[0] in + let lastChar = filename.[len - 1] in + match (firstChar, lastChar) with + | '\'', '\'' | '"', '"' -> filename + | _ -> Filename.quote filename + +let filterMap f = + let rec aux accu = function + | [] -> List.rev accu + | x :: l -> ( + match f x with None -> aux accu l | Some v -> aux (v :: accu) l ) + in + aux [] + +let filterMapIndex f = + let rec aux accu i = function + | [] -> List.rev accu + | x :: l -> ( + match f i x with + | None -> aux accu i l + | Some v -> aux (v :: accu) (i + 1) l ) + in + aux [] 0 diff --git a/src/Utils.re b/src/Utils.re deleted file mode 100644 index 30da43ba..00000000 --- a/src/Utils.re +++ /dev/null @@ -1,170 +0,0 @@ -/* - steal from OCaml stdlib - https://github.com/ocaml/ocaml/blob/7c9c210884e1b46f21af5bb4dfab995bb3336cf7/stdlib/string.ml#L205-L214 - */ -let split_on_char = (sep, s) => { - open String; - let r = ref([]); - let j = ref(length(s)); - for (i in length(s) - 1 downto 0) { - if (unsafe_get(s, i) == sep) { - r := [sub(s, i + 1, j^ - i - 1), ...r^]; - j := i; - }; - }; - [sub(s, 0, j^), ...r^]; -}; - -let topLoc = fname => { - Location.loc_start: { - Lexing.pos_fname: fname, - pos_lnum: 1, - pos_bol: 0, - pos_cnum: 0, - }, - Location.loc_end: { - Lexing.pos_fname: fname, - pos_lnum: 1, - pos_bol: 0, - pos_cnum: 0, - }, - loc_ghost: false, -}; - -/** - * `startsWith(string, prefix)` - * true if the string starts with the prefix - */ -let startsWith = (s, prefix) => - if (prefix == "") { - true; - } else { - let p = String.length(prefix); - p <= String.length(s) && String.sub(s, 0, p) == prefix; - }; - -let endsWith = (s, suffix) => - if (suffix == "") { - true; - } else { - let p = String.length(suffix); - let l = String.length(s); - p <= String.length(s) && String.sub(s, l - p, p) == suffix; - }; - -let cmtLocFromVscode = ((line, col)) => (line + 1, col); - -let sliceToEnd = (s, start) => { - let l = String.length(s); - start <= l ? String.sub(s, start, l - start) : ""; -}; - -let locWithinLoc = (inner, outer) => { - Location.( - inner.loc_start.pos_cnum >= outer.loc_start.pos_cnum - && inner.loc_end.pos_cnum <= outer.loc_end.pos_cnum - ); -}; - -let endOfLocation = (loc, length) => - Location.{ - ...loc, - loc_start: { - ...loc.loc_end, - pos_cnum: loc.loc_end.pos_cnum - length, - }, - }; - -let chopLocationEnd = (loc, length) => - Location.{ - ...loc, - loc_end: { - ...loc.loc_end, - pos_cnum: loc.loc_end.pos_cnum - length, - }, - }; - -let chopPrefix = (s, prefix) => sliceToEnd(s, String.length(prefix)); - -/** An optional List.find */ -let rec find = (fn, items) => - switch (items) { - | [] => None - | [one, ...rest] => - switch (fn(one)) { - | None => find(fn, rest) - | Some(x) => Some(x) - } - }; - -let dedup = items => { - let m = Hashtbl.create(List.length(items)); - items - |> List.filter(a => - if (Hashtbl.mem(m, a)) { - false; - } else { - Hashtbl.add(m, a, ()); - true; - } - ); -}; - -let tupleOfLexing = ({Lexing.pos_lnum, pos_cnum, pos_bol}) => ( - pos_lnum - 1, - pos_cnum - pos_bol, -); - -/** Check if pos is within the location, but be fuzzy about when the location ends. -If it's within 5 lines, go with it. - */ -let locationContainsFuzzy = ({Location.loc_start, loc_end}, (l, c)) => - tupleOfLexing(loc_start) <= (l, c) - && tupleOfLexing(loc_end) >= (l - 5, c); - -/* - * Quotes filename when not quoted - * Example: - * myFile.exe -> 'myFile.exe' - * 'myFile.exe' -> 'myFile.exe' - */ -let maybeQuoteFilename = filename => { - let len = String.length(filename); - if (len < 1) { - ""; - } else { - let firstChar = filename.[0]; - let lastChar = filename.[len - 1]; - switch (firstChar, lastChar) { - | ('\'', '\'') - | ('"', '"') => filename - | _ => Filename.quote(filename) - }; - }; -}; - -let filterMap = f => { - let rec aux = accu => - fun - | [] => List.rev(accu) - | [x, ...l] => - switch (f(x)) { - | None => aux(accu, l) - | Some(v) => aux([v, ...accu], l) - }; - - aux([]); -}; - -let filterMapIndex = f => { - let rec aux = (accu, i) => - fun - | [] => List.rev(accu) - | [x, ...l] => - switch (f(i, x)) { - | None => aux(accu, i, l) - | Some(v) => aux([v, ...accu], i + 1, l) - }; - - aux([], 0); -};