Test code xform using the AST: if-then-else to switch.

analysis/src/Commands.ml

@@ -400,6 +400,11 @@ let test ~path =
             SemanticTokens.command ~debug:true
               ~emitter:(SemanticTokens.Token.createEmitter ())
               ~path
+          | "xfm" ->
+            print_endline
+              ("Xform " ^ path ^ " " ^ string_of_int line ^ ":"
+             ^ string_of_int col);
+            Xform.command ~path ~pos:(line, col)
           | _ -> ());
           print_newline ())
     in

analysis/src/Xform.ml

@@ -0,0 +1,150 @@
+(** Code transformations using the parser/printer and ast operations *)
+
+let posInLoc ~pos ~loc =
+  Utils.tupleOfLexing loc.Location.loc_start <= pos
+  && pos < Utils.tupleOfLexing loc.loc_end
+
+module IfThenElse = struct
+  (* Convert if-then-else to switch *)
+
+  let rec listToPat ~itemToPat = function
+    | [] -> Some []
+    | x :: xList -> (
+      match (itemToPat x, listToPat ~itemToPat xList) with
+      | Some p, Some pList -> Some (p :: pList)
+      | _ -> None)
+
+  let rec expToPat (exp : Parsetree.expression) =
+    let mkPat ppat_desc =
+      Ast_helper.Pat.mk ~loc:exp.pexp_loc ~attrs:exp.pexp_attributes ppat_desc
+    in
+    match exp.pexp_desc with
+    | Pexp_construct (lid, None) -> Some (mkPat (Ppat_construct (lid, None)))
+    | Pexp_construct (lid, Some e1) -> (
+      match expToPat e1 with
+      | None -> None
+      | Some p1 -> Some (mkPat (Ppat_construct (lid, Some p1))))
+    | Pexp_variant (label, None) -> Some (mkPat (Ppat_variant (label, None)))
+    | Pexp_variant (label, Some e1) -> (
+      match expToPat e1 with
+      | None -> None
+      | Some p1 -> Some (mkPat (Ppat_variant (label, Some p1))))
+    | Pexp_constant c -> Some (mkPat (Ppat_constant c))
+    | Pexp_tuple eList -> (
+      match listToPat ~itemToPat:expToPat eList with
+      | None -> None
+      | Some patList -> Some (mkPat (Ppat_tuple patList)))
+    | Pexp_record (items, None) -> (
+      let itemToPat (x, e) =
+        match expToPat e with None -> None | Some p -> Some (x, p)
+      in
+      match listToPat ~itemToPat items with
+      | None -> None
+      | Some patItems -> Some (mkPat (Ppat_record (patItems, Closed))))
+    | Pexp_record (_, Some _) -> None
+    | _ -> None
+
+  let mkMapper ~pos ~changed =
+    let expr (mapper : Ast_mapper.mapper) (e : Parsetree.expression) =
+      let newExp =
+        match e.pexp_desc with
+        | Pexp_ifthenelse
+            ( {
+                pexp_desc =
+                  Pexp_apply
+                    ( {
+                        pexp_desc =
+                          Pexp_ident {txt = Lident (("=" | "<>") as op)};
+                      },
+                      [(Nolabel, arg1); (Nolabel, arg2)] );
+              },
+              e1,
+              Some e2 )
+          when posInLoc ~pos ~loc:e.pexp_loc -> (
+          let e1, e2 = if op = "=" then (e1, e2) else (e2, e1) in
+          let mkMatch ~arg ~pat =
+            let cases =
+              [
+                Ast_helper.Exp.case pat e1;
+                Ast_helper.Exp.case (Ast_helper.Pat.any ()) e2;
+              ]
+            in
+            Ast_helper.Exp.match_ ~loc:e.pexp_loc ~attrs:e.pexp_attributes arg
+              cases
+          in
+
+          match expToPat arg2 with
+          | None -> (
+            match expToPat arg1 with
+            | None -> None
+            | Some pat1 ->
+              let newExp = mkMatch ~arg:arg2 ~pat:pat1 in
+              Some newExp)
+          | Some pat2 ->
+            let newExp = mkMatch ~arg:arg1 ~pat:pat2 in
+            Some newExp)
+        | _ -> None
+      in
+      match newExp with
+      | Some newExp ->
+        changed := true;
+        newExp
+      | None -> Ast_mapper.default_mapper.expr mapper e
+    in
+
+    {Ast_mapper.default_mapper with expr}
+
+  let xform ~pos structure =
+    let changed = ref false in
+    let mapper = mkMapper ~pos ~changed in
+    let newStructure = mapper.structure mapper structure in
+    if !changed then Some newStructure else None
+end
+
+let parse ~filename =
+  let {Res_driver.parsetree = structure; comments} =
+    Res_driver.parsingEngine.parseImplementation ~forPrinter:false ~filename
+  in
+  let print ~structure =
+    Res_printer.printImplementation ~width:!Res_cli.ResClflags.width ~comments
+      structure
+  in
+  (structure, print)
+
+let diff ~filename ~newContents =
+  match Files.readFile ~filename with
+  | None -> assert false
+  | Some oldContents ->
+    let rec findFirstLineDifferent n old new_ =
+      match (old, new_) with
+      | old1 :: oldRest, new1 :: newRest ->
+        if old1 = new1 then findFirstLineDifferent (n + 1) oldRest newRest
+        else (n, old, new_)
+      | _ -> (n, old, new_)
+    in
+    let oldLines = String.split_on_char '\n' oldContents in
+    let newLines = String.split_on_char '\n' newContents in
+    let firstLineDifferent, old, new_ =
+      findFirstLineDifferent 0 oldLines newLines
+    in
+    let firstLineR, _oldR, newR =
+      findFirstLineDifferent 0 (List.rev old) (List.rev new_)
+    in
+    let lastLineEqual = firstLineDifferent + List.length old - firstLineR in
+    let newLines = List.rev newR in
+    (firstLineDifferent, lastLineEqual, newLines)
+
+let command ~path ~pos =
+  if Filename.check_suffix path ".res" then
+    let structure, print = parse ~filename:path in
+    match IfThenElse.xform ~pos structure with
+    | None -> ()
+    | Some newStructure ->
+      let formatted = print newStructure in
+      let firstLineDifferent, lastLineEqual, newLines =
+        diff ~filename:path ~newContents:formatted
+      in
+      Printf.printf
+        "Hit IfThenElse firstLineDifferent:%d lastLineEqual:%d newLines:\n%s\n"
+        firstLineDifferent lastLineEqual
+        (newLines |> String.concat "\n")

analysis/tests/src/Xform.res

@@ -0,0 +1,15 @@
+type kind = First | Second | Third
+type r = {name: string, age: int}
+
+let ret = _ => assert false
+let kind = assert false
+
+if kind == First {
+  // ^xfm
+  ret("First")
+} else {
+  ret("Not First")
+}
+
+#kind("First", {name: "abc", age: 3}) != kind ? ret("Not First") : ret("First")
+//             ^xfm

analysis/tests/src/expected/Debug.res.txt

@@ -4,7 +4,7 @@ Dependencies: @rescript/react
 Source directories: tests/node_modules/@rescript/react/src tests/node_modules/@rescript/react/src/legacy
 Source files: tests/node_modules/@rescript/react/src/React.res tests/node_modules/@rescript/react/src/ReactDOM.res tests/node_modules/@rescript/react/src/ReactDOMServer.res tests/node_modules/@rescript/react/src/ReactDOMStyle.res tests/node_modules/@rescript/react/src/ReactEvent.res tests/node_modules/@rescript/react/src/ReactEvent.resi tests/node_modules/@rescript/react/src/ReactTestUtils.res tests/node_modules/@rescript/react/src/ReactTestUtils.resi tests/node_modules/@rescript/react/src/RescriptReactErrorBoundary.res tests/node_modules/@rescript/react/src/RescriptReactErrorBoundary.resi tests/node_modules/@rescript/react/src/RescriptReactRouter.res tests/node_modules/@rescript/react/src/RescriptReactRouter.resi tests/node_modules/@rescript/react/src/legacy/ReactDOMRe.res tests/node_modules/@rescript/react/src/legacy/ReasonReact.res
 Source directories: tests/src tests/src/expected
-Source files: tests/src/Auto.res tests/src/CompletePrioritize1.res tests/src/CompletePrioritize2.res tests/src/Completion.res tests/src/Component.res tests/src/Component.resi tests/src/Cross.res tests/src/Debug.res tests/src/Definition.res tests/src/DefinitionWithInterface.res tests/src/DefinitionWithInterface.resi tests/src/Div.res tests/src/Fragment.res tests/src/Highlight.res tests/src/Hover.res tests/src/Jsx.res tests/src/Jsx.resi tests/src/LongIdentTest.res tests/src/Obj.res tests/src/Patterns.res tests/src/RecModules.res tests/src/RecordCompletion.res tests/src/References.res tests/src/ReferencesWithInterface.res tests/src/ReferencesWithInterface.resi tests/src/Rename.res tests/src/RenameWithInterface.res tests/src/RenameWithInterface.resi tests/src/TableclothMap.ml tests/src/TableclothMap.mli tests/src/TypeDefinition.res
+Source files: tests/src/Auto.res tests/src/CompletePrioritize1.res tests/src/CompletePrioritize2.res tests/src/Completion.res tests/src/Component.res tests/src/Component.resi tests/src/Cross.res tests/src/Debug.res tests/src/Definition.res tests/src/DefinitionWithInterface.res tests/src/DefinitionWithInterface.resi tests/src/Div.res tests/src/Fragment.res tests/src/Highlight.res tests/src/Hover.res tests/src/Jsx.res tests/src/Jsx.resi tests/src/LongIdentTest.res tests/src/Obj.res tests/src/Patterns.res tests/src/RecModules.res tests/src/RecordCompletion.res tests/src/References.res tests/src/ReferencesWithInterface.res tests/src/ReferencesWithInterface.resi tests/src/Rename.res tests/src/RenameWithInterface.res tests/src/RenameWithInterface.resi tests/src/TableclothMap.ml tests/src/TableclothMap.mli tests/src/TypeDefinition.res tests/src/Xform.res
 Impl cmt:tests/lib/bs/src/Auto.cmt res:tests/src/Auto.res
 Impl cmt:tests/lib/bs/src/CompletePrioritize1.cmt res:tests/src/CompletePrioritize1.res
 Impl cmt:tests/lib/bs/src/CompletePrioritize2.cmt res:tests/src/CompletePrioritize2.res
@@ -30,6 +30,7 @@ Impl cmt:tests/lib/bs/src/Rename.cmt res:tests/src/Rename.res
 IntfAndImpl cmti:tests/lib/bs/src/RenameWithInterface.cmti resi:tests/src/RenameWithInterface.resi cmt:tests/lib/bs/src/RenameWithInterface.cmt res:tests/src/RenameWithInterface.res
 IntfAndImpl cmti:tests/lib/bs/src/TableclothMap.cmti resi:tests/src/TableclothMap.mli cmt:tests/lib/bs/src/TableclothMap.cmt res:tests/src/TableclothMap.ml
 Impl cmt:tests/lib/bs/src/TypeDefinition.cmt res:tests/src/TypeDefinition.res
+Impl cmt:tests/lib/bs/src/Xform.cmt res:tests/src/Xform.res
 Dependency dirs: tests/node_modules/@rescript/react/lib/bs/src tests/node_modules/@rescript/react/lib/bs/src/legacy
 Opens from bsconfig: 
 locItems:

analysis/tests/src/expected/Xform.res.txt

@@ -0,0 +1,16 @@
+Xform tests/src/Xform.res 6:5
+Hit IfThenElse firstLineDifferent:6 lastLineEqual:11 newLines:
+switch kind {
+| First =>
+  // ^xfm
+  ret("First")
+| _ => ret("Not First")
+
+Xform tests/src/Xform.res 13:15
+Hit IfThenElse firstLineDifferent:13 lastLineEqual:15 newLines:
+switch kind {
+| #kind("First", {name: "abc", age: 3}) => ret("First")
+//             ^xfm
+| _ => ret("Not First")
+}
+