Eta reduction (#50)

* one step eta-reduction add description fixed problem with multiple occurence of arg Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * multistep eta-reduction Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * fixes Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * more fixes Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * fixed labelled args Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * fixes Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * fixes + refactor Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * more refactor Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * refactor Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * format Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * refactor Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * remove unused decls Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * refactow Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * rewrite to filter_map Signed-off-by: Jegor Popow <juicedogegor@gmail.com> * refactor Signed-off-by: Jegor Popow <juicedogegor@gmail.com> --------- Signed-off-by: Jegor Popow <juicedogegor@gmail.com>
Kakadu · May 10, 2024 · e320eef · e320eef
1 parent ec85d54
commit e320eef
Show file tree

Hide file tree

Showing 10 changed files with 190 additions and 3 deletions.
diff --git a/src/main.ml b/src/main.ml
@@ -28,6 +28,7 @@ let typed_linters =
     (module AmbiguousConstructors : LINT.TYPED)
   ; (module ExcTryWithWildcard : LINT.TYPED)
   ; (module Equality : LINT.TYPED)
+  ; (module Eta : LINT.TYPED)
   ; (module Equality_phys : LINT.TYPED)
   ; (module Failwith : LINT.TYPED)
   ; (module If_bool : LINT.TYPED)

diff --git a/src/typed/Eta.ml b/src/typed/Eta.ml
@@ -0,0 +1,133 @@
+(** Copyright 2021-2024, Kakadu *)
+
+(** SPDX-License-Identifier: LGPL-3.0-or-later *)
+
+open Base
+module Format = Caml.Format
+open Zanuda_core
+open Zanuda_core.Utils
+open Tast_pattern
+
+type input = Tast_iterator.iterator
+
+let lint_id = "eta_reduction"
+let group = LINT.Suspicious
+let level = LINT.Warn
+let lint_source = LINT.FPCourse
+
+let documentation =
+  {|
+### What it does
+Straightforward wrapper functions are excessive and may be reduced 
+
+#### Explanation
+
+Let's look at the expression 'let f x = g x'. It may be simply replaced with an expression, `let f = g` which has the same semantics. In general, wrappers like this may be confusing, so it is recommended to get rid of them
+|}
+  |> Stdlib.String.trim
+;;
+
+let describe_as_json () =
+  describe_as_clippy_json lint_id ~group ~level ~docs:documentation
+;;
+
+let expr2string e0 =
+  let open Parsetree in
+  let e = MyUntype.untype_expression e0 in
+  let open Ast_helper in
+  Format.asprintf "let (_: %a) = %a" Printtyp.type_expr e0.exp_type Pprintast.expression e
+;;
+
+let msg ppf e0 =
+  let open Parsetree in
+  let e = MyUntype.untype_expression e0 in
+  let si =
+    let open Ast_helper in
+    Format.asprintf "%a" Pprintast.expression e
+  in
+  Caml.Format.fprintf
+    ppf
+    "Eta reduction proposed. It's recommended to rewrite it as '%s'%!"
+    si
+;;
+
+let report filename ~loc e =
+  let module M = struct
+    let txt ppf () = Utils.Report.txt ~filename ~loc ppf msg e
+
+    let rdjsonl ppf () =
+      RDJsonl.pp
+        ppf
+        ~filename:(Config.recover_filepath loc.loc_start.pos_fname)
+        ~line:loc.loc_start.pos_lnum
+        msg
+        e
+    ;;
+  end
+  in
+  (module M : LINT.REPORTER)
+;;
+
+let no_ident ident c = Utils.no_ident ident (fun it -> it.expr it c)
+
+let run _ fallback =
+  let pattern_cons_map f id = function
+    | ids, func, args -> f (id :: ids, func, args)
+  in
+  let var_pattern_func = to_func (tpat_var __) in
+  let extract_path = function
+    | Asttypes.Nolabel, Some { Typedtree.exp_desc = Typedtree.Texp_ident (path, _, _) } ->
+      Some path
+    | _ -> None
+  in
+  let rec pat_func ctx lc e k =
+    let open Tast_pattern in
+    match e.Typedtree.exp_desc with
+    | Texp_function
+        { arg_label = Nolabel; cases = { c_lhs; c_guard = None; c_rhs } :: [] } ->
+      pattern_cons_map k |> var_pattern_func ctx lc c_lhs |> pat_func ctx lc c_rhs
+    | Texp_apply (body, args) ->
+      let paths = List.filter_map ~f:extract_path args in
+      if List.length args = List.length paths
+      then k ([], body, paths)
+      else fail lc "eta_redex"
+    | _ -> fail lc "eta-redex"
+  in
+  let pat = of_func pat_func in
+  let open Tast_iterator in
+  { fallback with
+    expr =
+      (fun self expr ->
+        let open Typedtree in
+        let loc = expr.exp_loc in
+        let extract_ident = function
+          | Path.Pident id -> Some id
+          | _ -> None
+        in
+        Tast_pattern.parse
+          pat
+          loc
+          ~on_error:(fun _desc () -> ())
+          expr
+          (fun (ids, func, args) () ->
+            (*              Format.printf "Expr: `%s`\nInner=`%s`\nFormal args=`%s`\nReal args=`%s`\nLengths: %d %d\n"
+                            (expr2string expr)
+                            (expr2string func)
+                            (String.concat ~sep:", " ids)
+                            (String.concat ~sep:", " (List.map ~f:ident2string args))
+                            (List.length ids)
+                            (List.length args); *)
+            let idents = List.filter_map ~f:extract_ident args in
+            if List.length args > 0
+               && List.length args = List.length idents
+               && List.equal String.equal ids (List.map idents ~f:Ident.name)
+               && (not (Base.List.contains_dup ~compare:String.compare ids))
+               && List.for_all idents ~f:(fun ident -> no_ident ident func)
+            then
+              CollectedLints.add
+                ~loc
+                (report loc.Location.loc_start.Lexing.pos_fname ~loc func))
+          ();
+        fallback.expr self expr)
+  }
+;;
diff --git a/src/typed/dune b/src/typed/dune
@@ -6,6 +6,7 @@
   ExcTryWithWildcard
   Equality
   Equality_phys
+  Eta
   Failwith
   Hashtables
   If_bool

diff --git a/tests/typed/Eta.t/Eta.ml b/tests/typed/Eta.t/Eta.ml
@@ -0,0 +1,21 @@
+let my_id x = x
+
+let wrapper x = my_id x
+
+let my_add x y = x + y
+
+let my_add3 x y z = x + y + z
+
+let good_wrapper x = my_add x x
+
+let strange_wrapper x x = my_add x x
+
+let xx f g h = my_add3 f g h 
+
+let flipper x y z = my_add3 y z x
+
+let listsAreEqual a b = List.equal (fun lhs rhs -> String.equal lhs rhs) a b
+
+let labeled_add ~x ~y = x + y
+
+let labeled_wrapper a b = labeled_add ~x:a ~y:b
diff --git a/tests/typed/Eta.t/dune b/tests/typed/Eta.t/dune
@@ -0,0 +1,5 @@
+(library
+ (name test_Eta)
+ (wrapped false)
+ (libraries base)
+ (modules Eta))
diff --git a/tests/typed/Eta.t/dune-project b/tests/typed/Eta.t/dune-project
@@ -0,0 +1,3 @@
+(lang dune 2.8)
+
+(cram enable)
diff --git a/tests/typed/Eta.t/run.t b/tests/typed/Eta.t/run.t
@@ -0,0 +1,23 @@
+  $ dune build
+  File "Eta.ml", line 11, characters 20-21:
+  11 | let strange_wrapper x x = my_add x x
+                           ^
+  Error (warning 27 [unused-var-strict]): unused variable x.
+  [1]
+  $ zanuda  -no-check-filesystem -no-top_file_license -dir . -ordjsonl /dev/null
+  File "Eta.ml", line 3, characters 12-23:
+  3 | let wrapper x = my_id x
+                  ^^^^^^^^^^^
+  Alert zanuda-linter: Eta reduction proposed. It's recommended to rewrite it as 'my_id'
+  File "Eta.ml", line 5, characters 11-22:
+  5 | let my_add x y = x + y
+                 ^^^^^^^^^^^
+  Alert zanuda-linter: Eta reduction proposed. It's recommended to rewrite it as '(+)'
+  File "Eta.ml", line 13, characters 7-28:
+  13 | let xx f g h = my_add3 f g h 
+              ^^^^^^^^^^^^^^^^^^^^^
+  Alert zanuda-linter: Eta reduction proposed. It's recommended to rewrite it as 'my_add3'
+  File "Eta.ml", line 17, characters 35-72:
+  17 | let listsAreEqual a b = List.equal (fun lhs rhs -> String.equal lhs rhs) a b
+                                          ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+  Alert zanuda-linter: Eta reduction proposed. It's recommended to rewrite it as 'String.equal'
diff --git a/tests/typed/monad_laws.t/run.t b/tests/typed/monad_laws.t/run.t
@@ -1,5 +1,5 @@
   $ dune build
-  $ zanuda  -no-check-filesystem -no-top_file_license -dir .  -ordjsonl /dev/null
+  $ zanuda -no-check-filesystem -no-eta_reduction -no-top_file_license -dir .  -ordjsonl /dev/null
   File "laws.ml", line 5, characters 12-35:
   5 | let foo x = x >>= fun y -> return y
                   ^^^^^^^^^^^^^^^^^^^^^^^

diff --git a/tests/untyped/manual_fold.t/run.t b/tests/untyped/manual_fold.t/run.t
@@ -1,5 +1,5 @@
   $ dune build
-  $ zanuda  -no-check-filesystem -no-top_file_license -no-propose_function_untyped -no-propose_function -dir .  -ordjsonl /dev/null
+  $ zanuda  -no-check-filesystem -no-eta_reduction -no-top_file_license -no-propose_function_untyped -no-propose_function -dir .  -ordjsonl /dev/null
   File "manual_fold.ml", lines 2-5, characters 0-39:
   2 | let rec fold_left f acc l =
   3 |   match l with

diff --git a/tests/untyped/var_should_not_be_used.t/run.t b/tests/untyped/var_should_not_be_used.t/run.t
@@ -1,5 +1,5 @@
   $ dune build
-  $ zanuda -no-check-filesystem -no-top_file_license -dir .  -ordjsonl /dev/null
+  $ zanuda -no-check-filesystem -no-eta_reduction -no-top_file_license -dir .  -ordjsonl /dev/null
   File "lib.ml", line 1, characters 8-12:
   1 | let rec _foo x = _foo x
               ^^^^