Merge pull request ocaml-ppx#29 from Twinside/master

Adding handling of shadowed standard types in mutually recursive types.

Author: whitequark

src/ppx_deriving.ml

@@ -5,6 +5,8 @@ open Parsetree
 open Ast_helper
 open Ast_convenience
 
+module StringSet = Set.Make(String)
+
 type deriver = {
   name : string ;
   core_type : (core_type -> expression) option;
@@ -269,3 +271,36 @@ let strong_type_of_type ty =
   let free_vars = free_vars_in_core_type ty in
   Typ.force_poly @@ Typ.poly free_vars ty
 
+let predefined_types =
+  [
+    "unit";
+    "int";
+    "int32";
+    "int64";
+    "nativeint";
+    "float";
+    "bool";
+    "char";
+    "string";
+    "bytes"
+  ]
+
+let predefined_set =
+  List.fold_right StringSet.add predefined_types StringSet.empty
+
+let extract_typename_of_type_group deriver ~allow_shadowing type_list =
+  let add_name acc ty =
+    let typename = ty.ptype_name.txt in
+    let is_shadowing_predefined =
+      StringSet.mem typename predefined_set in
+    if is_shadowing_predefined && not allow_shadowing then
+      raise_errorf
+        ~loc:ty.ptype_loc
+        ("%s don't allow derivation of shadowed standard type %s. " ^^
+         "Use option 'allow_std_type_masking' to lift the restriction.")
+        deriver
+        typename
+    else
+      StringSet.add ty.ptype_name.txt acc in
+  List.fold_left add_name StringSet.empty type_list
+

src/ppx_deriving.mli

@@ -2,6 +2,8 @@
 
 open Parsetree
 
+module StringSet : Set.S with type elt = string
+
 (** {2 Registration} *)
 
 (** A type of deriving plugins.
@@ -241,3 +243,10 @@ val binop_reduce : expression -> expression -> expression -> expression
     [freevars . ty], giving a strong polymorphic type *)
 val strong_type_of_type: core_type -> core_type
 
+(** [extract_typename_of_type_group ~allow_shadowing tys] will extract
+    the set of all types in a type group. Will raise an error in case
+    of type shadowing standard types, unless [~allow_shadowing] is set
+    to true. *)
+val extract_typename_of_type_group : string -> allow_shadowing:bool ->
+                                     type_declaration list -> StringSet.t
+

src_plugins/ppx_deriving_eq.ml

@@ -5,13 +5,28 @@ open Parsetree
 open Ast_helper
 open Ast_convenience
 
+module StringSet = Ppx_deriving.StringSet
+
 let deriver = "eq"
 let raise_errorf = Ppx_deriving.raise_errorf
 
+type eq_options =
+  {
+    allow_std_type_shadowing: bool;
+  }
+
+let default_eq_options =
+  {
+    allow_std_type_shadowing= false;
+  }
+
 let parse_options options =
-  options |> List.iter (fun (name, expr) ->
+  let option_parser acc (name, expr) =
     match name with
-    | _ -> raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name)
+    | "allow_std_type_shadowing" -> { allow_std_type_shadowing = true }
+    | _ ->
+      raise_errorf ~loc:expr.pexp_loc "%s does not support option %s" deriver name in
+  List.fold_left option_parser default_eq_options options
 
 let attr_equal attrs =
   Ppx_deriving.(attrs |> attr ~deriver "equal" |> Arg.(get_attr ~deriver expr))
@@ -23,58 +38,63 @@ let pattn side typs =
   List.mapi (fun i _ -> pvar (argn side i)) typs
 
 let core_type_of_decl ~options ~path type_decl =
-  parse_options options;
+  ignore (parse_options options);
   let typ = Ppx_deriving.core_type_of_type_decl type_decl in
   Ppx_deriving.poly_arrow_of_type_decl
     (fun var -> [%type: [%t var] -> [%t var] -> bool])
     type_decl
     [%type: [%t typ] -> [%t typ] -> bool]
 
 let sig_of_type ~options ~path type_decl =
-  parse_options options;
+  ignore (parse_options options);
   [Sig.value (Val.mk (mknoloc (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl))
              (core_type_of_decl ~options ~path type_decl))]
 
-let rec exprsn typs =
+let rec exprsn group_def typs =
   typs |> List.mapi (fun i typ ->
-    app (expr_of_typ typ) [evar (argn `lhs i); evar (argn `rhs i)])
+    app (expr_of_typ group_def typ) [evar (argn `lhs i); evar (argn `rhs i)])
 
-and expr_of_typ typ =
+and expr_of_typ group_def typ =
   match attr_equal typ.ptyp_attributes with
   | Some fn -> fn
   | None ->
     match typ with
+    | { ptyp_desc = Ptyp_constr ({ txt = (Lident id as lid) }, args) } 
+        when StringSet.mem id group_def ->
+      let equal_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "equal") lid)) in
+      app equal_fn (List.map (expr_of_typ group_def) args)
     | [%type: _] | [%type: unit] -> [%expr fun _ _ -> true]
     | [%type: int] | [%type: int32] | [%type: Int32.t]
     | [%type: int64] | [%type: Int64.t] | [%type: nativeint] | [%type: Nativeint.t]
-    | [%type: float] | [%type: bool] | [%type: char] | [%type: string] | [%type: bytes] ->
+    | [%type: float] | [%type: bool] | [%type: char] | [%type: string] |
+      [%type: String.t] | [%type: bytes] ->
       [%expr (fun (a:[%t typ]) b -> a = b)]
-    | [%type: [%t? typ] ref]   -> [%expr fun a b -> [%e expr_of_typ typ] !a !b]
+    | [%type: [%t? typ] ref]   -> [%expr fun a b -> [%e expr_of_typ group_def typ] !a !b]
     | [%type: [%t? typ] list]  ->
       [%expr
         let rec loop x y =
           match x, y with
           | [], [] -> true
-          | a :: x, b :: y -> [%e expr_of_typ typ] a b && loop x y
+          | a :: x, b :: y -> [%e expr_of_typ group_def typ] a b && loop x y
           | _ -> false
         in (fun x y -> loop x y)]
     | [%type: [%t? typ] array] ->
       [%expr fun x y ->
         let rec loop i =
-          (i = Array.length x || [%e expr_of_typ typ] x.(i) y.(i)) && loop (i + 1)
+          (i = Array.length x || [%e expr_of_typ group_def typ] x.(i) y.(i)) && loop (i + 1)
         in Array.length x = Array.length y && loop 0]
     | [%type: [%t? typ] option] ->
       [%expr fun x y ->
         match x, y with
         | None, None -> true
-        | Some a, Some b -> [%e expr_of_typ typ] a b
+        | Some a, Some b -> [%e expr_of_typ group_def typ] a b
         | _ -> false]
     | { ptyp_desc = Ptyp_constr ({ txt = lid }, args) } ->
       let equal_fn = Exp.ident (mknoloc (Ppx_deriving.mangle_lid (`Prefix "equal") lid)) in
-      app equal_fn (List.map expr_of_typ args)
+      app equal_fn (List.map (expr_of_typ group_def) args)
     | { ptyp_desc = Ptyp_tuple typs } ->
       [%expr fun [%p ptuple (pattn `lhs typs)] [%p ptuple (pattn `rhs typs)] ->
-        [%e exprsn typs |> Ppx_deriving.(fold_exprs (binop_reduce [%expr (&&)]))]]
+        [%e exprsn group_def typs |> Ppx_deriving.(fold_exprs (binop_reduce [%expr (&&)]))]]
     | { ptyp_desc = Ptyp_variant (fields, _, _); ptyp_loc } ->
       let cases =
         (fields |> List.map (fun field ->
@@ -84,42 +104,44 @@ and expr_of_typ typ =
             Exp.case (pdup (fun _ -> Pat.variant label None)) [%expr true]
           | Rtag (label, _, false, [typ]) ->
             Exp.case (pdup (fun var -> Pat.variant label (Some (pvar var))))
-                     (app (expr_of_typ typ) [evar "lhs"; evar "rhs"])
+                     (app (expr_of_typ group_def typ) [evar "lhs"; evar "rhs"])
           | Rinherit ({ ptyp_desc = Ptyp_constr (tname, _) } as typ) ->
             Exp.case (pdup (fun var -> Pat.alias (Pat.type_ tname) (mknoloc var)))
-                     (app (expr_of_typ typ) [evar "lhs"; evar "rhs"])
+                     (app (expr_of_typ group_def typ) [evar "lhs"; evar "rhs"])
           | _ ->
             raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                          deriver (Ppx_deriving.string_of_core_type typ))) @
         [Exp.case (pvar "_") [%expr false]]
       in
       [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] cases]]
     | { ptyp_desc = Ptyp_var name } -> evar ("poly_"^name)
-    | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ typ
+    | { ptyp_desc = Ptyp_alias (typ, _) } -> expr_of_typ group_def typ
     | { ptyp_loc } ->
       raise_errorf ~loc:ptyp_loc "%s cannot be derived for %s"
                    deriver (Ppx_deriving.string_of_core_type typ)
 
-let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
-  parse_options options;
+let str_of_type ~options ~path group_def ({ ptype_loc = loc } as type_decl) =
+  ignore (parse_options options);
   let comparator =
     match type_decl.ptype_kind, type_decl.ptype_manifest with
-    | Ptype_abstract, Some manifest -> expr_of_typ manifest
+    | Ptype_abstract, Some manifest -> expr_of_typ group_def manifest
     | Ptype_variant constrs, _ ->
+      let wildcard = match constrs with
+        | [] | [_] -> []
+        | _ :: _ :: _ -> [Exp.case (pvar "_") [%expr false]] in
       let cases =
         (constrs |> List.map (fun { pcd_name = { txt = name }; pcd_args = typs } ->
-          exprsn typs |>
+          exprsn group_def typs |>
           Ppx_deriving.(fold_exprs ~unit:[%expr true] (binop_reduce [%expr (&&)])) |>
           Exp.case (ptuple [pconstr name (pattn `lhs typs);
-                            pconstr name (pattn `rhs typs)]))) @
-        [Exp.case (pvar "_") [%expr false]]
+                            pconstr name (pattn `rhs typs)]))) @ wildcard 
       in
       [%expr fun lhs rhs -> [%e Exp.match_ [%expr lhs, rhs] cases]]
     | Ptype_record labels, _ ->
       let exprs =
         labels |> List.map (fun { pld_name = { txt = name }; pld_type } ->
           let field obj = Exp.field obj (mknoloc (Lident name)) in
-          app (expr_of_typ pld_type) [field (evar "lhs"); field (evar "rhs")])
+          app (expr_of_typ group_def pld_type) [field (evar "lhs"); field (evar "rhs")])
       in
       [%expr fun lhs rhs -> [%e exprs |> Ppx_deriving.(fold_exprs (binop_reduce [%expr (&&)]))]]
     | Ptype_abstract, None ->
@@ -135,11 +157,26 @@ let str_of_type ~options ~path ({ ptype_loc = loc } as type_decl) =
     pvar (Ppx_deriving.mangle_type_decl (`Prefix "equal") type_decl) in
   [Vb.mk (Pat.constraint_ eq_var out_type) (polymorphize comparator)]
 
+let type_decl_str ~options ~path type_decls =
+  let opts = parse_options options in
+  let typename_set =
+    Ppx_deriving.extract_typename_of_type_group 
+      deriver
+      ~allow_shadowing:opts.allow_std_type_shadowing
+      type_decls in
+  let here_loc = (List.hd type_decls).ptype_loc in
+  if StringSet.mem "bool" typename_set then
+    raise_errorf
+      ~loc:here_loc
+      "%s can't derivate types when shadowing bool (even with option)" deriver;
+  let code =
+    List.map (str_of_type ~options ~path typename_set) type_decls in
+  [Str.value Recursive (List.concat code)]
+
 let () =
-  Ppx_deriving.(register (create "eq"
-    ~core_type: expr_of_typ
-    ~type_decl_str: (fun ~options ~path type_decls ->
-       [Str.value Recursive (List.concat (List.map (str_of_type ~options ~path) type_decls))])
+  Ppx_deriving.(register (create deriver
+    ~core_type:(expr_of_typ StringSet.empty)
+    ~type_decl_str: type_decl_str
     ~type_decl_sig: (fun ~options ~path type_decls ->
        List.concat (List.map (sig_of_type ~options ~path) type_decls))
     ()