refactor: tighten bindings (#855)

melange-re · Oct 31, 2023 · 1efce66 · 1efce66
1 parent 529b4ee
commit 1efce66
Show file tree

Hide file tree

Showing 2 changed files with 66 additions and 62 deletions.
diff --git a/jscomp/core/compile_rec_module.ml b/jscomp/core/compile_rec_module.ml
@@ -2,54 +2,57 @@ type t = Lambda.lambda
 
 (* Utilities for compiling "module rec" definitions *)
 
-let bs_init_mod (args : t list) loc : t =
-  Lprim
-    (Pccall (Primitive.simple ~name:"#init_mod" ~arity:2 ~alloc:true), args, loc)
-
-let bs_update_mod (args : t list) loc : t =
-  Lprim
-    ( Pccall (Primitive.simple ~name:"#update_mod" ~arity:3 ~alloc:true),
-      args,
-      loc )
-
 type loc = t
 
 type binding =
   Translmod.id_or_ignore_loc
   * (Lambda.lambda * Lambda.lambda) option
   * Lambda.lambda
 
-let eval_rec_bindings_aux (bindings : binding list) (cont : t) : t =
-  let rec bind_inits args acc =
-    match args with
-    | [] -> acc
-    | (_id, None, _rhs) :: rem -> bind_inits rem acc
-    | (Translmod.Ignore_loc _, _, _) :: rem -> bind_inits rem acc
-    | (Id id, Some (loc, shape), _rhs) :: rem ->
-        Lambda.Llet
-          ( Strict,
-            Pgenval,
-            id,
-            bs_init_mod [ loc; shape ] Loc_unknown,
-            bind_inits rem acc )
-  in
-  let rec bind_strict args acc =
-    match args with
-    | [] -> acc
-    | (Translmod.Id id, None, rhs) :: rem ->
-        Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc)
-    | (_id, (None | Some _), _rhs) :: rem -> bind_strict rem acc
-  in
-  let rec patch_forwards args =
-    match args with
-    | [] -> cont
-    | (_id, None, _rhs) :: rem -> patch_forwards rem
-    | (Translmod.Ignore_loc _, _, _rhs) :: rem -> patch_forwards rem
-    | (Id id, Some (_loc, shape), rhs) :: rem ->
-        Lsequence
-          (bs_update_mod [ shape; Lvar id; rhs ] Loc_unknown, patch_forwards rem)
+let eval_rec_bindings_aux =
+  let mel_init_mod (args : t list) loc : t =
+    Lprim
+      ( Pccall (Primitive.simple ~name:"#init_mod" ~arity:2 ~alloc:true),
+        args,
+        loc )
+  and mel_update_mod (args : t list) loc : t =
+    Lprim
+      ( Pccall (Primitive.simple ~name:"#update_mod" ~arity:3 ~alloc:true),
+        args,
+        loc )
   in
-  bind_inits bindings (bind_strict bindings (patch_forwards bindings))
+  fun (bindings : binding list) (cont : t) : t ->
+    let rec bind_inits args acc =
+      match args with
+      | [] -> acc
+      | (_id, None, _rhs) :: rem -> bind_inits rem acc
+      | (Translmod.Ignore_loc _, _, _) :: rem -> bind_inits rem acc
+      | (Id id, Some (loc, shape), _rhs) :: rem ->
+          Lambda.Llet
+            ( Strict,
+              Pgenval,
+              id,
+              mel_init_mod [ loc; shape ] Loc_unknown,
+              bind_inits rem acc )
+    in
+    let rec bind_strict args acc =
+      match args with
+      | [] -> acc
+      | (Translmod.Id id, None, rhs) :: rem ->
+          Lambda.Llet (Strict, Pgenval, id, rhs, bind_strict rem acc)
+      | (_id, (None | Some _), _rhs) :: rem -> bind_strict rem acc
+    in
+    let rec patch_forwards args =
+      match args with
+      | [] -> cont
+      | (_id, None, _rhs) :: rem -> patch_forwards rem
+      | (Translmod.Ignore_loc _, _, _rhs) :: rem -> patch_forwards rem
+      | (Id id, Some (_loc, shape), rhs) :: rem ->
+          Lsequence
+            ( mel_update_mod [ shape; Lvar id; rhs ] Loc_unknown,
+              patch_forwards rem )
+    in
+    bind_inits bindings (bind_strict bindings (patch_forwards bindings))
 
 (* collect all function declarations
     if the module creation is just a set of function declarations and consts,

diff --git a/jscomp/core/record_attributes_check.ml b/jscomp/core/record_attributes_check.ml
@@ -139,25 +139,26 @@ let check_mel_attributes_inclusion (attrs1 : Parsetree.attributes)
   let b = find_with_default attrs2 ~f:find_name ~default:lbl_name in
   if a = b then None else Some (a, b)
 
-let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list)
-    (coll : Set_string.t) =
-  match lbls with
-  | [] -> None
-  | { pld_name = { txt; _ } as pld_name; pld_attributes; _ } :: rest -> (
-      if Set_string.mem coll txt then Some pld_name
-      else
-        let coll_with_lbl = Set_string.add coll txt in
-        match List.find_map find_name_with_loc pld_attributes with
-        | None -> check_duplicated_labels_aux rest coll_with_lbl
-        | Some ({ txt = s; _ } as l) ->
-            if
-              Set_string.mem coll s
-              (*use coll to make check a bit looser
-                allow cases like [ x : int [@as "x"]]
-              *)
-            then Some l
-            else
-              check_duplicated_labels_aux rest (Set_string.add coll_with_lbl s))
-
-let check_duplicated_labels lbls =
-  check_duplicated_labels_aux lbls Set_string.empty
+let check_duplicated_labels =
+  let rec check_duplicated_labels_aux (lbls : Parsetree.label_declaration list)
+      (coll : Set_string.t) =
+    match lbls with
+    | [] -> None
+    | { pld_name = { txt; _ } as pld_name; pld_attributes; _ } :: rest -> (
+        if Set_string.mem coll txt then Some pld_name
+        else
+          let coll_with_lbl = Set_string.add coll txt in
+          match List.find_map find_name_with_loc pld_attributes with
+          | None -> check_duplicated_labels_aux rest coll_with_lbl
+          | Some ({ txt = s; _ } as l) ->
+              if
+                Set_string.mem coll s
+                (*use coll to make check a bit looser
+                  allow cases like [ x : int [@as "x"]]
+                *)
+              then Some l
+              else
+                check_duplicated_labels_aux rest
+                  (Set_string.add coll_with_lbl s))
+  in
+  fun lbls -> check_duplicated_labels_aux lbls Set_string.empty