Implement ghost bindings as a separate category in the environment

Armaël Guéneau · Armaël Guéneau · commit 293b5225e7d2 · 2017-11-10T22:32:24.000+01:00
This replaces the trick consisting of using a special string prefix added to
normal identifiers.
diff --git a/typing/env.ml b/typing/env.ml
@@ -165,6 +165,7 @@ type summary =
   | Env_functor_arg of summary * Ident.t
   | Env_constraints of summary * type_declaration PathMap.t
   | Env_copy_types of summary * string list
+  | Env_ghost_value of summary * Ident.t * value_description
 
 module TycompTbl =
   struct
@@ -450,6 +451,7 @@ type t = {
   components: module_components IdTbl.t;
   classes: class_declaration IdTbl.t;
   cltypes: class_type_declaration IdTbl.t;
+  ghost_values: value_description IdTbl.t;
   functor_args: unit Ident.tbl;
   summary: summary;
   local_constraints: type_declaration PathMap.t;
@@ -483,6 +485,7 @@ and structure_components = {
   mutable comp_components: module_components comp_tbl;
   mutable comp_classes: class_declaration comp_tbl;
   mutable comp_cltypes: class_type_declaration comp_tbl;
+  mutable comp_ghost_values : value_description comp_tbl;
 }
 
 and functor_components = {
@@ -536,6 +539,7 @@ let empty = {
   modules = IdTbl.empty; modtypes = IdTbl.empty;
   components = IdTbl.empty; classes = IdTbl.empty;
   cltypes = IdTbl.empty;
+  ghost_values = IdTbl.empty;
   summary = Env_empty; local_constraints = PathMap.empty; gadt_instances = [];
   flags = 0;
   functor_args = Ident.empty;
@@ -624,7 +628,8 @@ let empty_structure =
     comp_types = Tbl.empty;
     comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
     comp_components = Tbl.empty; comp_classes = Tbl.empty;
-    comp_cltypes = Tbl.empty }
+    comp_cltypes = Tbl.empty;
+    comp_ghost_values = Tbl.empty; }
 
 let get_components c =
   match get_components_opt c with
@@ -910,6 +915,8 @@ and find_class =
   find (fun env -> env.classes) (fun sc -> sc.comp_classes)
 and find_cltype =
   find (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+and find_ghost_value =
+  find (fun env -> env.ghost_values) (fun sc -> sc.comp_ghost_values)
 
 let type_of_cstr path = function
   | {cstr_inlined = Some d; _} ->
@@ -1281,6 +1288,8 @@ let lookup_class =
   lookup (fun env -> env.classes) (fun sc -> sc.comp_classes)
 let lookup_cltype =
   lookup (fun env -> env.cltypes) (fun sc -> sc.comp_cltypes)
+let lookup_ghost_value =
+  lookup (fun env -> env.ghost_values) (fun sc -> sc.comp_ghost_values)
 
 let copy_types l env =
   let f desc = {desc with val_type = Subst.type_expr Subst.identity desc.val_type} in
@@ -1680,7 +1689,8 @@ and components_of_module_maker (env, sub, path, mty) =
           comp_labels = Tbl.empty; comp_types = Tbl.empty;
           comp_modules = Tbl.empty; comp_modtypes = Tbl.empty;
           comp_components = Tbl.empty; comp_classes = Tbl.empty;
-          comp_cltypes = Tbl.empty } in
+          comp_cltypes = Tbl.empty;
+          comp_ghost_values = Tbl.empty; } in
       let pl, sub = prefix_idents path sub sg in
       let env = ref env in
       let pos = ref 0 in
@@ -1798,6 +1808,11 @@ and store_value ?check id decl env =
     values = IdTbl.add id decl env.values;
     summary = Env_value(env.summary, id, decl) }
 
+and store_ghost_value id decl env =
+  { env with
+    ghost_values = IdTbl.add id decl env.ghost_values;
+    summary = Env_ghost_value(env.summary, id, decl) }
+
 and store_type ~check id info env =
   let loc = info.type_loc in
   if check then
@@ -1979,6 +1994,8 @@ let add_local_constraint path info elv env =
       add_local_type path info env
   | _ -> assert false
 
+let add_ghost_value id desc env =
+  store_ghost_value id desc env
 
 (* Insertion of bindings by name *)
 
diff --git a/typing/env.mli b/typing/env.mli
@@ -33,6 +33,10 @@ type summary =
   | Env_functor_arg of summary * Ident.t
   | Env_constraints of summary * type_declaration PathMap.t
   | Env_copy_types of summary * string list
+  (* Ghost bindings are used to keep track of non-recursive let-bindings that
+     may be missing a 'rec', in order to provide a special error message in that
+     case. *)
+  | Env_ghost_value of summary * Ident.t * value_description
 
 type t
 
@@ -67,6 +71,7 @@ val find_module: Path.t -> t -> module_declaration
 val find_modtype: Path.t -> t -> modtype_declaration
 val find_class: Path.t -> t -> class_declaration
 val find_cltype: Path.t -> t -> class_type_declaration
+val find_ghost_value: Path.t -> t -> value_description
 
 val find_type_expansion:
     Path.t -> t -> type_expr list * type_expr * int option
@@ -123,6 +128,8 @@ val lookup_class:
   ?loc:Location.t -> Longident.t -> t -> Path.t * class_declaration
 val lookup_cltype:
   ?loc:Location.t -> Longident.t -> t -> Path.t * class_type_declaration
+val lookup_ghost_value:
+  ?loc:Location.t -> Longident.t -> t -> Path.t * value_description
 
 val copy_types: string list -> t -> t
   (* Used only in Typecore.duplicate_ident_types. *)
@@ -146,6 +153,7 @@ val add_class: Ident.t -> class_declaration -> t -> t
 val add_cltype: Ident.t -> class_type_declaration -> t -> t
 val add_local_constraint: Path.t -> type_declaration -> int -> t -> t
 val add_local_type: Path.t -> type_declaration -> t -> t
+val add_ghost_value: Ident.t -> value_description -> t -> t
 
 (* Insertion of all fields of a signature. *)
 
diff --git a/typing/envaux.ml b/typing/envaux.ml
@@ -39,6 +39,9 @@ let rec env_from_summary sum subst =
       | Env_value(s, id, desc) ->
           Env.add_value id (Subst.value_description subst desc)
                         (env_from_summary s subst)
+      | Env_ghost_value(s, id, desc) ->
+          Env.add_ghost_value id (Subst.value_description subst desc)
+            (env_from_summary s subst)
       | Env_type(s, id, desc) ->
           Env.add_type ~check:false id
             (Subst.type_declaration subst desc)
diff --git a/typing/typecore.ml b/typing/typecore.ml
@@ -136,48 +136,38 @@ type recarg =
 let case lhs rhs =
   {c_lhs = lhs; c_guard = None; c_rhs = rhs}
 
-(* Add a dummy prefix to a name in order to help track missing
-   "rec" keywords *)
-let ghost_name_easytype s =
-  "***" ^ s
 
-(* Add a dummy prefix to an ident in order to help track missing
-   "rec" keywords *)
-let ghost_ident_easytype id =
-  { id with Ident.name = ghost_name_easytype (Ident.name id) }
+(* For detecting missing "rec" keywords, we add "ghost" bindings in the
+   environment for variables that are bound non-recursively. Then, when an
+   identifier is unbound, [find_value] additionally checks if it exists as a
+   "ghost" binding. In that case, an special-cased error message "you are
+   probably missing the rec keyword" is displayed.
+*)
 
 (* Add pattern variables as ghost bindings, i.e., bindings that may be
    used for the error message "you are probably missing the rec keyword". *)
-let add_pattern_variables_ghost_easytype loc_let ?check ?check_as env pv =
-  (* Note: the arguments ?check ?check_as might not be needed *)
+let add_pattern_variables_ghost loc_let env pv =
   List.fold_right
-     (fun (id, ty, _name, _loc, as_var) env ->
-       let check = if as_var then check_as else check in
-       Env.add_value ?check (ghost_ident_easytype id)
+     (fun (id, ty, _name, _loc, _as_var) env ->
+       Env.add_ghost_value id
          {val_type = ty; val_kind = Val_reg; Types.val_loc = loc_let;
           val_attributes = [];
          } env
      )
      pv env
 
 (* Lookup in the environment for a variable or a corresponding ghost variable *)
-let find_value_easytype env loc txt =
+let find_value env loc txt =
   try Typetexp.find_value env loc txt
-  with | (Typetexp.Error (loc', env', Typetexp.Unbound_value lid')) as error ->
-    let txt2 =
-      match txt with
-      | Longident.Lident s -> Longident.Lident (ghost_name_easytype s)
-      | _ -> raise error
-    in
-    let (_path, desc) =
-      try Typetexp.find_value env loc txt2
-      with Typetexp.Error (_, _, Typetexp.Unbound_value _) -> raise error
-    in
-    let loc = desc.val_loc in
-    raise
-      (Typetexp.Error
-         (loc', env', Typetexp.Unbound_value_missing_rec (lid', loc)))
-
+  with (Typetexp.Error (loc', env', Typetexp.Unbound_value lid')) as error ->
+    begin match Typetexp.find_ghost_value_opt env loc txt with
+    | None -> raise error
+    | Some (_, desc) ->
+        let loc = desc.val_loc in
+        raise
+          (Typetexp.Error
+             (loc', env', Typetexp.Unbound_value_missing_rec (lid', loc)))
+    end
 
 (* Upper approximation of free identifiers on the parse tree *)
 
@@ -2670,7 +2660,7 @@ and type_expect_ ?in_function ?(recarg=Rejected) env sexp ty_expected =
   match sexp.pexp_desc with
   | Pexp_ident lid ->
       begin
-        let (path, desc) = find_value_easytype env lid.loc lid.txt in
+        let (path, desc) = find_value env lid.loc lid.txt in
         if !Clflags.annotations then begin
           let dloc = desc.Types.val_loc in
           let annot =
@@ -4752,7 +4742,7 @@ and type_let ?(check = fun s -> Warnings.Unused_var s)
         | {pvb_loc; _} :: _ -> pvb_loc
         | _ -> assert false
       in
-      add_pattern_variables_ghost_easytype loc env pv
+      add_pattern_variables_ghost loc env pv
     end
     else env in
 
diff --git a/typing/typetexp.ml b/typing/typetexp.ml
@@ -187,6 +187,15 @@ let find_class_type env loc lid =
   Builtin_attributes.check_deprecated loc decl.clty_attributes (Path.name path);
   r
 
+let find_ghost_value_opt env loc lid =
+  try
+    Some
+      (find_component Env.lookup_ghost_value
+         (fun lid -> Unbound_value lid)
+         env loc lid)
+  with Error (_, _, Unbound_value _) ->
+    None
+
 let unbound_constructor_error env lid =
   narrow_unbound_lid_error env lid.loc lid.txt
     (fun lid -> Unbound_constructor lid)
diff --git a/typing/typetexp.mli b/typing/typetexp.mli
@@ -111,6 +111,12 @@ val find_modtype:
     Env.t -> Location.t -> Longident.t -> Path.t * modtype_declaration
 val find_class_type:
     Env.t -> Location.t -> Longident.t -> Path.t * class_type_declaration
+(* There is no constructor in [error] for an "unbound ghost value" error. Ghost
+   values should only be used internally, and never appear to the user: as an
+   attempt to document that fact, we provide a [find_*] function that returns an
+   option, instead of raising an exception. *)
+val find_ghost_value_opt:
+    Env.t -> Location.t -> Longident.t -> (Path.t * value_description) option
 
 val unbound_constructor_error: Env.t -> Longident.t Location.loc -> 'a
 val unbound_label_error: Env.t -> Longident.t Location.loc -> 'a
