Add option to supply a formatter for ml files (#368)

* Add support for external .ml files formatter

* Simplify fmtCmdForUri: return type result(string, string)

Author: IwanKaramazow

editor-extensions/vscode/package.json

@@ -78,6 +78,10 @@
 					"type": "string",
 					"description": "Provide a location for the reason-lisp lispRefmt binary"
 				},
+				"reason_language_server.mlfmt": {
+					"type": "string",
+					"description": "Provide a location for an .ml/.mli formatter"
+				},
 				"reason_language_server.format_width": {
 					"type": "number",
 					"default": 80,

src/analyze/AsYouType.re

@@ -52,8 +52,8 @@ let convertToRe = (~formatWidth, ~interface, text, refmt) => {
   }
 };
 
-let format = (~formatWidth, ~interface, text, refmt) => {
-  let (out, error, success) = Commands.execFull(~input=text, Printf.sprintf("%s --print re --print-width=%d --parse re%s", Commands.shellEscape(refmt), formatWidth |? 80, interface ? " -i true" : ""));
+let format = (text, fmtCmd) => {
+  let (out, error, success) = Commands.execFull(~input=text, fmtCmd);
   if (success) {
     Ok(String.concat("\n", out))
   } else {

src/analyze/Packages.re

@@ -77,6 +77,7 @@ let newBsPackage = (~overrideBuildSystem=?, ~reportDiagnostics, state, rootPath)
   let compiledBase = BuildSystem.getCompiledBase(rootPath, buildSystem);
   let%try stdLibDirectories = BuildSystem.getStdlib(rootPath, buildSystem);
   let%try compilerPath = BuildSystem.getCompiler(rootPath, buildSystem);
+  let mlfmtPath = state.settings.mlfmtLocation;
   let%try refmtPath = BuildSystem.getRefmt(rootPath, buildSystem);
   let%try tmpPath = BuildSystem.hiddenLocation(rootPath, buildSystem);
   let%try (dependencyDirectories, dependencyModules) = FindFiles.findDependencyFiles(~debug=true, ~buildSystem, rootPath, config);
@@ -222,6 +223,7 @@ let newBsPackage = (~overrideBuildSystem=?, ~reportDiagnostics, state, rootPath)
       stdLibDirectories
       ,
     compilerPath,
+    mlfmtPath: mlfmtPath,
     refmtPath: Some(refmtPath),
     /** TODO detect this from node_modules */
     lispRefmtPath: None,
@@ -335,6 +337,7 @@ let newJbuilderPackage = (~overrideBuildSystem=?, ~reportDiagnostics, state, roo
 
   let%try compilerPath = BuildSystem.getCompiler(projectRoot, buildSystem);
   let%try compilerVersion = BuildSystem.getCompilerVersion(compilerPath);
+  let mlfmtPath = state.settings.mlfmtLocation;
   let refmtPath = BuildSystem.getRefmt(projectRoot, buildSystem) |> RResult.toOptionAndLog;
   Ok({
     basePath: rootPath,
@@ -354,6 +357,7 @@ let newJbuilderPackage = (~overrideBuildSystem=?, ~reportDiagnostics, state, roo
     includeDirectories,
     compilerVersion,
     compilerPath,
+    mlfmtPath,
     refmtPath,
     lispRefmtPath: None,
   });

src/analyze/State.re

@@ -174,6 +174,41 @@ let refmtForUri = (uri, package) =>
     }
   };
 
+let fmtCmdForUri = (~formatWidth, ~interface, uri, package) => {
+  if (Filename.check_suffix(uri, ".ml") || Filename.check_suffix(uri, ".mli")) {
+    switch (package.mlfmtPath) {
+    | None => Error("No formatter available for .ml(i) files")
+    | Some(fmtPath) => Ok(fmtPath);
+    };
+  } else if (Filename.check_suffix(uri, ".rel")
+             || Filename.check_suffix(uri, ".reli")) {
+    switch (package.lispRefmtPath) {
+    | None =>
+      Error("No lispRefmt path found, cannot process .rel or .reli files")
+    | Some(lispRefmt) =>
+      let cmd = Printf.sprintf(
+        "%s --print re --print-width=%d --parse re%s",
+        Commands.shellEscape(lispRefmt),
+        formatWidth |? 80,
+        interface ? " -i true" : "",
+      );
+      Ok(cmd);
+    };
+  } else {
+    switch (package.refmtPath) {
+    | None => Error("No refmt found for dune project. Cannot process .re file")
+    | Some(refmt) =>
+      let cmd = Printf.sprintf(
+        "%s --print re --print-width=%d --parse re%s",
+        Commands.shellEscape(refmt),
+        formatWidth |? 80,
+        interface ? " -i true" : "",
+      );
+      Ok(cmd);
+    };
+  };
+};
+
 open Infix;
 
 let getInterfaceFile = (uri, state, ~package: TopTypes.package) => {

src/analyze/TopTypes.re

@@ -29,6 +29,7 @@ type package = {
   buildCommand: option((string, string)),
   compilerPath: filePath,
   compilerVersion: BuildSystem.compilerVersion,
+  mlfmtPath: option(filePath),
   refmtPath: option(filePath),
   /** TODO maybe make this general, so that I can support arbitrary syntaxes? */
   lispRefmtPath: option(filePath),
@@ -37,6 +38,7 @@ type package = {
 type settings = {
   formatWidth: option(int),
   perValueCodelens: bool,
+  mlfmtLocation: option(string),
   refmtLocation: option(string),
   lispRefmtLocation: option(string),
   opensCodelens: bool,
@@ -82,6 +84,7 @@ let empty = () => {
   lastDefinitions: Hashtbl.create(10),
   settings: {
     formatWidth: None,
+    mlfmtLocation: None,
     refmtLocation: None,
     lispRefmtLocation: None,
     crossFileAsYouType: false,

src/analyze_fixture_tests/lib/TestUtils.re

@@ -24,6 +24,7 @@ let getPackage = (localModules) => {
     rebuildTimer: 0.,
     includeDirectories: [],
     compilerPath,
+    mlfmtPath: None,
     refmtPath: Some(refmtPath),
     lispRefmtPath: None,
   };
@@ -96,6 +97,7 @@ let getState = () => {
     lastDefinitions: Hashtbl.create(10),
     settings: {
       crossFileAsYouType: false,
+      mlfmtLocation: None,
       refmtLocation: None,
       lispRefmtLocation: None,
       formatWidth: None,

src/lsp/MessageHandlers.re

@@ -408,8 +408,6 @@ let handlers: list((string, (state, Json.t) => result((state, Json.t), string)))
     let%try uri = params |> RJson.get("textDocument") |?> RJson.get("uri") |?> RJson.string;
     let%try package = getPackage(uri, state);
     let%try (start, end_) = RJson.get("range", params) |?> Protocol.rgetRange;
-    let%try refmtPath = State.refmtForUri(uri, package);
-    let%try refmtPath = refmtPath |> R.orError("Cannot refmt ocaml yet");
 
     let text = State.getContents(uri, state);
     let maybeResult = {
@@ -470,7 +468,13 @@ let handlers: list((string, (state, Json.t) => result((state, Json.t), string)))
             |> String.concat("\n");
           };
         };
-        let%try_wrap text = AsYouType.format(~formatWidth=state.settings.formatWidth, ~interface=(Utils.endsWith(uri, "i")), substring, refmtPath);
+        let%try fmtCmd = State.fmtCmdForUri(
+          ~formatWidth=state.settings.formatWidth,
+          ~interface=(Utils.endsWith(uri, "i")),
+          uri,
+          package
+        );
+        let%try_wrap text = AsYouType.format(substring, fmtCmd);
         Util.JsonShort.(
           state,
           l([
@@ -540,9 +544,13 @@ let handlers: list((string, (state, Json.t) => result((state, Json.t), string)))
     let%try uri = params |> RJson.get("textDocument") |?> RJson.get("uri") |?> RJson.string;
     let%try package = getPackage(uri, state);
     let text = State.getContents(uri, state);
-    let%try refmtPath = State.refmtForUri(uri, package);
-    let%try refmtPath = refmtPath |> R.orError("Cannot refmt ocaml yet");
-    let%try_wrap newText = AsYouType.format(~formatWidth=state.settings.formatWidth, ~interface=(Utils.endsWith(uri, "i")), text, refmtPath);
+    let%try fmtCmd = State.fmtCmdForUri(
+      ~formatWidth=state.settings.formatWidth,
+      ~interface=(Utils.endsWith(uri, "i")),
+      uri,
+      package
+    );
+    let%try_wrap newText = AsYouType.format(text, fmtCmd);
     open Util.JsonShort;
     (state, text == newText ? Json.Null : l([o([
       ("range", Protocol.rangeOfInts(

src/lsp/NotificationHandlers.re

@@ -97,6 +97,7 @@ let notificationHandlers: list((string, (state, Json.t) => result(state, string)
   ("workspace/didChangeConfiguration", (state, params) => {
     let nullIfEmpty = item => item == "" ? None : Some(item);
     let settings = params |> Json.get("settings") |?> Json.get("reason_language_server");
+    let mlfmtLocation = (settings |?> Json.get("mlfmt") |?> Json.string) |?> nullIfEmpty;
     let refmtLocation = (settings |?> Json.get("refmt") |?> Json.string) |?> nullIfEmpty;
     let lispRefmtLocation = (settings |?> Json.get("lispRefmt") |?> Json.string |?> nullIfEmpty);
     let perValueCodelens = (settings |?> Json.get("per_value_codelens") |?> Json.bool) |? false;
@@ -120,6 +121,7 @@ let notificationHandlers: list((string, (state, Json.t) => result(state, string)
       settings: {
         ...state.settings,
         perValueCodelens,
+        mlfmtLocation,
         refmtLocation,
         lispRefmtLocation,
         opensCodelens,