Remove type_unpacks (#150)

Author: ncik-roberts

typing/typecore.ml

@@ -48,13 +48,6 @@ type type_expected = {
   explanation: type_forcing_context option;
 }
 
-type to_unpack = {
-  tu_ident : Ident.t;
-  tu_name: string Location.loc;
-  tu_loc: Location.t;
-  tu_uid: Uid.t
-}
-
 module Datatype_kind = struct
   type t = Record | Variant
 
@@ -700,10 +693,18 @@ type pattern_variable =
     pv_attributes: attributes;
   }
 
+type module_variable =
+  {
+    mv_id : Ident.t;
+    mv_name: string Location.loc;
+    mv_loc: Location.t;
+    mv_uid: Uid.t
+  }
+
 let pattern_variables = ref ([] : pattern_variable list)
 let pattern_force = ref ([] : (unit -> unit) list)
 let allow_modules = ref Modules_rejected
-let module_variables = ref ([] : to_unpack list)
+let module_variables = ref ([] : module_variable list)
 let reset_pattern allow =
   pattern_variables := [];
   pattern_force := [];
@@ -737,6 +738,38 @@ let add_pattern_variables ?check ?check_as env pv =
     )
     pv env
 
+let add_module_variables env module_variables =
+  List.fold_left (fun env { mv_id; mv_loc; mv_name; mv_uid } ->
+    Typetexp.TyVarEnv.with_local_scope begin fun () ->
+      (* This code is parallel to the typing of Pexp_letmodule. However we
+         omit the call to [Mtype.lower_nongen] as it's not necessary here.
+         For Pexp_letmodule, the call to [type_module] is done in a raised
+         level and so needs to be modified to have the correct, outer level.
+         Here, on the other hand, we're calling [type_module] outside the
+         raised level, so there's no extra step to take.
+      *)
+      let modl, md_shape =
+        !type_module env
+          Ast_helper.(
+            Mod.unpack ~loc:mv_loc
+              (Exp.ident ~loc:mv_name.loc
+                  (mkloc (Longident.Lident mv_name.txt)
+                    mv_name.loc)))
+      in
+      let pres =
+        match modl.mod_type with
+        | Mty_alias _ -> Mp_absent
+        | _ -> Mp_present
+      in
+      let md =
+        { md_type = modl.mod_type; md_attributes = [];
+          md_loc = mv_name.loc;
+          md_uid = mv_uid; }
+      in
+      Env.add_module_declaration ~shape:md_shape ~check:true mv_id pres md env
+    end
+  ) env module_variables
+
 let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name mode ty
     attrs =
   if List.exists (fun {pv_id; _} -> Ident.name pv_id = name.txt)
@@ -755,10 +788,10 @@ let enter_variable ?(is_module=false) ?(is_as_variable=false) loc name mode ty
           escape ~loc ~env:Env.empty ~reason:Other mode;
           let id = Ident.create_scoped name.txt ~scope in
           module_variables :=
-            { tu_ident = id;
-              tu_name = name;
-              tu_loc = loc;
-              tu_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
+            { mv_id = id;
+              mv_name = name;
+              mv_loc = loc;
+              mv_uid = Uid.mk ~current_unit:(Env.get_unit_name ());
             } :: !module_variables;
           id
     end else
@@ -1722,7 +1755,7 @@ type 'case_pattern half_typed_case =
     untyped_case: Parsetree.case;
     branch_env: Env.t;
     pat_vars: pattern_variable list;
-    unpacks: to_unpack list;
+    module_vars: module_variable list;
     contains_gadt: bool; }
 
 let rec has_literal_pattern p =
@@ -2582,8 +2615,8 @@ let type_pattern category ~lev ~alloc_mode env spat expected_ty allow_modules =
   let new_env = ref env in
   let pat = type_pat category ~lev ~alloc_mode new_env spat expected_ty in
   let pvs = get_ref pattern_variables in
-  let unpacks = get_ref module_variables in
-  (pat, !new_env, get_ref pattern_force, pvs, unpacks)
+  let mvs = get_ref module_variables in
+  (pat, !new_env, get_ref pattern_force, pvs, mvs)
 
 let type_pattern_list
     category no_existentials env spatl expected_tys allow_modules
@@ -2599,9 +2632,8 @@ let type_pattern_list
   in
   let patl = List.map2 type_pat spatl expected_tys in
   let pvs = get_ref pattern_variables in
-  let unpacks = get_ref module_variables in
-  let new_env = add_pattern_variables !new_env pvs in
-  (patl, new_env, get_ref pattern_force, pvs, unpacks)
+  let mvs = get_ref module_variables in
+  (patl, !new_env, get_ref pattern_force, pvs, mvs)
 
 let type_class_arg_pattern cl_num val_env met_env l spat =
   if !Clflags.principal then Ctype.begin_def ();
@@ -3980,17 +4012,18 @@ and type_expect_
           Modules_allowed { scope }
         end else Modules_rejected
       in
-      let (pat_exp_list, new_env, unpacks) =
+      let (pat_exp_list, new_env) =
         type_let existential_context env rec_flag spat_sexp_list allow_modules
       in
       let in_function =
         match sexp.pexp_attributes with
         | [{Parsetree.attr_name = {txt="#default"};_}] -> in_function
         | _ -> None
       in
-      let extended_env, body =
-        type_unpacks ?in_function
-          new_env expected_mode unpacks sbody ty_expected_explained in
+      let body =
+        type_expect ?in_function
+          new_env expected_mode sbody ty_expected_explained
+      in
       let () =
         if rec_flag = Recursive then
           check_recursive_bindings env pat_exp_list
@@ -4008,9 +4041,9 @@ and type_expect_
       *)
       if may_contain_modules then begin
         end_def ();
-        unify_exp extended_env body (newvar ());
+        unify_exp new_env body (newvar ());
         if rec_flag = Recursive then
-          check_scope_escape_let_bound_idents extended_env pat_exp_list
+          check_scope_escape_let_bound_idents new_env pat_exp_list
       end;
       re {
         exp_desc = Texp_let(rec_flag, pat_exp_list, body);
@@ -6314,60 +6347,6 @@ and type_statement ?explanation env sexp =
     exp
   end
 
-(* Type the body within an environment extended with the unpacked modules are
-   added, returning both the typechecked body and the extended environment. *)
-and type_unpacks
-    ?(in_function : (Location.t * type_expr * bool) option)
-    env (expected_mode : expected_mode) (unpacks : to_unpack list) sbody expected_ty =
-  if unpacks = [] then
-    let body = type_expect ?in_function env expected_mode sbody expected_ty in
-    env, body
-  else
-  let extended_env =
-    List.fold_left (fun env unpack ->
-      Typetexp.TyVarEnv.with_local_scope begin fun () ->
-        (* This code is parallel to the typing of Pexp_letmodule. However we
-           omit the call to [Mtype.lower_nongen] as it's not necessary here.
-           For Pexp_letmodule, the call to [type_module] is done in a raised
-           level and so needs to be modified to have the correct, outer level.
-           Here, on the other hand, we're calling [type_module] outside the
-           raised level, so there's no extra step to take.
-        *)
-        let modl, md_shape =
-          !type_module env
-            Ast_helper.(
-              Mod.unpack ~loc:unpack.tu_loc
-                (Exp.ident ~loc:unpack.tu_name.loc
-                   (mkloc (Longident.Lident unpack.tu_name.txt)
-                      unpack.tu_name.loc)))
-        in
-        let pres =
-          match modl.mod_type with
-          | Mty_alias _ -> Mp_absent
-          | _ -> Mp_present
-        in
-        let md =
-          { md_type = modl.mod_type; md_attributes = [];
-            md_loc = unpack.tu_name.loc;
-            md_uid = unpack.tu_uid; }
-        in
-        Env.add_module_declaration ~shape:md_shape ~check:true
-          unpack.tu_ident pres md env
-      end
-    ) env unpacks
-  in
-  (* ideally, we should catch Expr_type_clash errors
-     in type_expect triggered by escaping identifiers from the local module
-     and refine them into Scoping_let_module errors
-  *)
-  let body =
-    type_expect ?in_function extended_env expected_mode sbody expected_ty
-  in
-  extended_env, body
-
-and type_unpacks' ?in_function env expected_mode unpacks sbody expected_ty =
-  snd (type_unpacks ?in_function env expected_mode unpacks sbody expected_ty)
-
 (* Typing of match cases *)
 and type_cases
     : type k . k pattern_category ->
@@ -6423,7 +6402,7 @@ and type_cases
         let ty_arg = instance ?partial:take_partial_instance ty_arg in
         end_def ();
         generalize_structure ty_arg;
-        let (pat, ext_env, force, pvs, unpacks) =
+        let (pat, ext_env, force, pvs, mvs) =
           type_pattern category ~lev ~alloc_mode:pmode env pc_lhs ty_arg
             allow_modules
         in
@@ -6442,7 +6421,7 @@ and type_cases
           untyped_case = case;
           branch_env = ext_env;
           pat_vars = pvs;
-          unpacks;
+          module_vars = mvs;
           contains_gadt = contains_gadt (as_comp_pattern category pat); }
         )
       caselist in
@@ -6485,7 +6464,8 @@ and type_cases
   let in_function = if List.length caselist = 1 then in_function else None in
   let cases =
     List.map
-      (fun { typed_pat = pat; branch_env = ext_env; pat_vars = pvs; unpacks;
+      (fun { typed_pat = pat; branch_env = ext_env;
+             pat_vars = pvs; module_vars = mvs;
              untyped_case = {pc_lhs = _; pc_guard; pc_rhs};
              contains_gadt; _ }  ->
         let ext_env =
@@ -6499,6 +6479,7 @@ and type_cases
             ~check:(fun s -> Warnings.Unused_var_strict s)
             ~check_as:(fun s -> Warnings.Unused_var s)
         in
+        let ext_env = add_module_variables ext_env mvs in
         let ty_res' =
           if !Clflags.principal then begin
             begin_def ();
@@ -6515,12 +6496,12 @@ and type_cases
           | None -> None
           | Some scond ->
               Some
-                (type_unpacks' ext_env mode_local unpacks scond
+                (type_expect ext_env mode_local scond
                    (mk_expected ~explanation:When_guard Predef.type_bool))
         in
         let exp =
-          type_unpacks' ?in_function ext_env emode
-            unpacks pc_rhs (mk_expected ?explanation ty_res')
+          type_expect ?in_function ext_env emode
+            pc_rhs (mk_expected ?explanation ty_res')
         in
         {
          c_lhs = pat;
@@ -6663,9 +6644,21 @@ and type_let
   let is_recursive = (rec_flag = Recursive) in
   let nvs = List.map (fun _ -> newvar ()) spatl in
   if is_recursive then begin_def ();
-  let (pat_list, new_env, force, pvs, unpacks) =
+  let (pat_list, new_env, force, pvs, mvs) =
     type_pattern_list Value existential_context env spatl nvs allow_modules
   in
+  (* Note [add_module_variables after checking expressions]
+     ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+     Don't call [add_module_variables] here, because its use of [type_module]
+     will fail until after we have type-checked the expression of the let.
+     Example: [let m : (module S) = ... in let (module M) = m in ...]
+     We learn the signature [S] from the type of [m] in the RHS of the second
+     let, and we need that knowledge for [type_module] to succeed. If we
+     type-checked expressions before patterns, then we could call
+     [add_module_variables] here.
+  *)
+  let new_env = add_pattern_variables new_env pvs in
   if is_recursive then begin
     end_def ();
     iter_pattern_variables_type generalize pvs
@@ -6709,7 +6702,13 @@ and type_let
   (* Only bind pattern variables after generalizing *)
   List.iter (fun f -> f()) force;
   let exp_env =
-    if is_recursive then new_env
+    (* See Note [add_module_variables after checking expressions]
+
+       We can't defer type-checking module variables with recursive definitions,
+       so things like [let rec (module M) = m in ...] always fail, even if the
+       type of [m] is known.
+    *)
+    if is_recursive then add_module_variables new_env mvs
     else if entirely_functions
     then begin
       (* Add ghost bindings to help detecting missing "rec" keywords.
@@ -6809,24 +6808,13 @@ and type_let
             end;
             let exp =
               Builtin_attributes.warning_scope pvb_attributes (fun () ->
-                if rec_flag = Recursive then
-                  type_unpacks' exp_env mode
-                    unpacks sexp (mk_expected ty')
-                else
-                  type_expect exp_env mode
-                    sexp (mk_expected ty')
-              )
+                type_expect exp_env mode sexp (mk_expected ty'))
             in
             exp, Some vars
         | _ ->
             let exp =
               Builtin_attributes.warning_scope pvb_attributes (fun () ->
-                  if rec_flag = Recursive then
-                    type_unpacks' exp_env mode
-                      unpacks sexp (mk_expected expected_ty)
-                  else
-                    type_expect exp_env mode
-                      sexp (mk_expected expected_ty))
+                type_expect exp_env mode sexp (mk_expected expected_ty))
             in
             exp, None)
       spat_sexp_list mode_typ_slot_list in
@@ -6897,7 +6885,9 @@ and type_let
                                       | _ -> false) pat_extra) then
             check_partial_application ~statement:false vb_expr
       | _ -> ()) l;
-  (l, new_env, unpacks)
+  (* See Note [add_module_variables after checking expressions] *)
+  let new_env = add_module_variables new_env mvs in
+  (l, new_env)
 
 and type_andops env sarg sands expected_ty =
   let rec loop env let_sarg rev_sands expected_ty =
@@ -7254,7 +7244,7 @@ and type_immutable_array
 
 let type_binding env rec_flag ?force_global spat_sexp_list =
   Typetexp.TyVarEnv.reset ();
-  let (pat_exp_list, new_env, _unpacks) =
+  let (pat_exp_list, new_env) =
     type_let
       ~check:(fun s -> Warnings.Unused_value_declaration s)
       ~check_strict:(fun s -> Warnings.Unused_value_declaration s)
@@ -7265,7 +7255,7 @@ let type_binding env rec_flag ?force_global spat_sexp_list =
   (pat_exp_list, new_env)
 
 let type_let existential_ctx env rec_flag spat_sexp_list =
-  let (pat_exp_list, new_env, _unpacks) =
+  let (pat_exp_list, new_env) =
     type_let existential_ctx env rec_flag spat_sexp_list Modules_rejected
   in
   (pat_exp_list, new_env)