diff --git a/analysis/src/Commands.ml b/analysis/src/Commands.ml index 1c4cbdbbc..dd92ec557 100644 --- a/analysis/src/Commands.ml +++ b/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 diff --git a/analysis/src/Xform.ml b/analysis/src/Xform.ml new file mode 100644 index 000000000..5a149e3b7 --- /dev/null +++ b/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") diff --git a/analysis/tests/src/Xform.res b/analysis/tests/src/Xform.res new file mode 100644 index 000000000..4229ea8f4 --- /dev/null +++ b/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 diff --git a/analysis/tests/src/expected/Debug.res.txt b/analysis/tests/src/expected/Debug.res.txt index 2897bf280..0cf048a86 100644 --- a/analysis/tests/src/expected/Debug.res.txt +++ b/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: diff --git a/analysis/tests/src/expected/Xform.res.txt b/analysis/tests/src/expected/Xform.res.txt new file mode 100644 index 000000000..4c3378e6b --- /dev/null +++ b/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") +} +