Add lint about constructor names that hide default constructor names (fix #26)

CHANGES

@@ -14,6 +14,9 @@
 - Expose library to parse DIFF format. It is available as 'zanuda.diff_parser' ocamlfind package.
 - #28: Add lint about nested if expressions.
   (contributed by @Artem-Rzhankoff)
+  #32: Add lint about constructor names that hide default constructor names (contributed by @nnemakin)
+
+
 ### Changed
 
 - #15: Split 'string_concat' lint to check separately patterns 'a^b^c' (level=Allow) and 'List.fold_left (^)' (level=Warn).

src/main.ml

@@ -23,7 +23,8 @@ let untyped_linters =
 let typed_linters =
   let open TypedLints in
   [ (* *** *** *** *** *** *** *** *** *** *** *** *** *** *** *** *** *** *)
-    (module ExcTryWithWildcard : LINT.TYPED)
+    (module AmbiguousConstructors : LINT.TYPED)
+  ; (module ExcTryWithWildcard : LINT.TYPED)
   ; (module Equality : LINT.TYPED)
   ; (module Failwith : LINT.TYPED)
   ; (module If_bool : LINT.TYPED)

src/typed/AmbiguousConstructors.ml

@@ -0,0 +1,108 @@
+(** Copyright 2021-2023, Kakadu. *)
+
+(** SPDX-License-Identifier: LGPL-3.0-or-later *)
+
+open Base
+open Zanuda_core
+open Zanuda_core.Utils
+
+type input = Tast_iterator.iterator
+
+let lint_id = "ambiguous_constructors"
+let group = LINT.Nursery
+let level = LINT.Warn
+let lint_source = LINT.Other
+
+let documentation =
+  {|
+### What it does
+
+Checks if there are constructor names that hide default constructor names
+from `Stdlib`, such as `Some`, `None`, `Error`, `Ok`. 
+
+### Why it is important
+
+Shadowing names of default constructors may lead to name clashes within toplevel.
+Using custom constructors is recommended.
+
+|}
+  |> Stdlib.String.trim
+;;
+
+let describe_as_json () =
+  describe_as_clippy_json lint_id ~group ~level ~docs:documentation
+;;
+
+let msg ppf names =
+  let show_names =
+    List.map names ~f:(Format.asprintf "`%s`") |> String.concat ~sep:", "
+  in
+  Format.fprintf
+    ppf
+    "Constructor%s %s of this type should not look like defaults"
+    (if List.length names = 1 then "" else "s")
+    show_names
+;;
+
+let report ~loc ~filename names =
+  let module M = struct
+    let txt ppf () = Report.txt ~loc ~filename ppf msg names
+
+    let rdjsonl ppf () =
+      Report.rdjsonl
+        ~loc
+        ~filename:(Config.recover_filepath loc.loc_start.pos_fname)
+        ~code:lint_id
+        ppf
+        msg
+        names
+    ;;
+  end
+  in
+  (module M : LINT.REPORTER)
+;;
+
+let run _ fallback =
+  let pat =
+    let open Tast_pattern in
+    core_typ (typ_constr __ drop)
+  in
+  let get_bad_names tdecl =
+    let default_names = [ "Some"; "None"; "Error"; "Ok" ] in
+    let open Typedtree in
+    let names =
+      match tdecl.typ_kind with
+      | Ttype_variant cdecls -> List.map cdecls ~f:(fun decl -> decl.cd_name.txt)
+      | _ -> []
+    in
+    List.filter names ~f:(fun name -> List.mem default_names name ~equal:String.equal)
+  in
+  let open Typedtree in
+  let open Tast_iterator in
+  { fallback with
+    type_declaration =
+      (fun self tdecl ->
+        let tmfest = tdecl.typ_manifest in
+        let loc = tdecl.typ_loc in
+        let is_stdlib_alias =
+          match tmfest with
+          | None -> false
+          | Some ctyp ->
+            Tast_pattern.parse
+              pat
+              ctyp.ctyp_loc
+              ctyp
+              (fun p ->
+                match Ident.name (Path.head p) with
+                | "Stdlib" | "option" -> true
+                | _ -> false)
+              ~on_error:(fun _ -> false)
+        in
+        let names = get_bad_names tdecl in
+        if (not is_stdlib_alias) && not (List.is_empty names)
+        then (
+          let filename = loc.Location.loc_start.Lexing.pos_fname in
+          CollectedLints.add ~loc (report ~loc ~filename names));
+        fallback.type_declaration self tdecl)
+  }
+;;

src/typed/dune

@@ -2,6 +2,7 @@
  (name TypedLints)
  (libraries zanuda_core Tast_pattern)
  (modules
+  AmbiguousConstructors
   ExcTryWithWildcard
   Equality
   Failwith

src/untyped/dune

@@ -4,12 +4,12 @@
  (modules
   Casing
   GuardInsteadOfIf
-  Dollar
-  License
   ParsetreeHasDocs
   Propose_function
   ToplevelEval
+  Dollar
   VarShouldNotBeUsed
+  License
   ;
   )
  (preprocess

tests/typed/amb_cstrs.t/amb_cstrs.ml

@@ -0,0 +1,34 @@
+module Linted = struct
+  type 'a result = 
+    | Error of string 
+    | Ok of 'a  
+
+  type str_option = 
+    | Some of string
+    | None
+
+  type 'a option = 
+    | Nothing
+    | Some of 'a
+
+end
+
+module Not_linted = struct
+  type 'a opt = 
+    | Something of 'a 
+    | Nothing
+
+  type 'a maybe = 'a option = None | Some of 'a 
+
+  type ('c, 'd) res = ('c, 'd) result = Ok of 'c | Error of 'd
+end
+
+(* should give a lint *)
+type 'a option = 
+  | Option
+  | Some of 'a
+
+(* should not give a lint *)
+type 'a option2 = 'a option = 
+  | Option
+  | Some of 'a

tests/typed/amb_cstrs.t/dune

@@ -0,0 +1,12 @@
+(library
+ (name test_amb_cstrs)
+ (wrapped false)
+ (modules amb_cstrs)
+ (flags
+  (:standard
+   ;-dsource
+   ;
+   )))
+
+(cram
+ (deps %{bin:zanuda.exe}))

tests/typed/amb_cstrs.t/dune-project

@@ -0,0 +1,3 @@
+(lang dune 2.8)
+
+(cram enable)

tests/typed/amb_cstrs.t/run.t

@@ -0,0 +1,22 @@
+  $ dune build
+  $ zanuda -no-check-filesystem -no-top_file_license -dir .  -ordjsonl /dev/null
+  File "amb_cstrs.ml", lines 2-4, characters 2-14:
+  2 | ..type 'a result = 
+  3 |     | Error of string 
+  4 |     | Ok of 'a..
+  Alert zanuda-linter: Constructors `Error`, `Ok` of this type should not look like defaults
+  File "amb_cstrs.ml", lines 6-8, characters 2-10:
+  6 | ..type str_option = 
+  7 |     | Some of string
+  8 |     | None
+  Alert zanuda-linter: Constructors `Some`, `None` of this type should not look like defaults
+  File "amb_cstrs.ml", lines 10-12, characters 2-16:
+  10 | ..type 'a option = 
+  11 |     | Nothing
+  12 |     | Some of 'a
+  Alert zanuda-linter: Constructor `Some` of this type should not look like defaults
+  File "amb_cstrs.ml", lines 27-29, characters 0-14:
+  27 | type 'a option = 
+  28 |   | Option
+  29 |   | Some of 'a
+  Alert zanuda-linter: Constructor `Some` of this type should not look like defaults