Merge branch 'master' into jsx-ast

Author: nojaf

CHANGELOG.md

@@ -22,6 +22,12 @@
 - Fix `%external` extension. https://github.com/rescript-lang/rescript/pull/7272
 - Fix issue with type environment for unified ops. https://github.com/rescript-lang/rescript/pull/7277
 - Fix completion for application with tagged template. https://github.com/rescript-lang/rescript/pull/7278
+- Fix error message for arity in the presence of optional arguments. https://github.com/rescript-lang/rescript/pull/7284
+- Fix issue in functors with more than one argument (which are curried): emit nested function always. https://github.com/rescript-lang/rescript/pull/7273
+
+#### :house: Internal
+
+- Remove ignore in res_scanner.ml . https://github.com/rescript-lang/rescript/pull/7280
 
 # 12.0.0-alpha.8
 

Makefile

@@ -32,6 +32,12 @@ node_modules/.bin/semver:
 test: lib
 	node scripts/test.js -all
 
+test-analysis:
+	make -C tests/analysis_tests clean test
+	
+test-tools:
+	make -C tests/tools_tests clean test
+
 test-syntax:
 	bash ./scripts/test_syntax.sh
 	make reanalyze
@@ -45,7 +51,7 @@ test-syntax-roundtrip:
 test-gentype:
 	make -C tests/gentype_tests/typescript-react-example clean test
 
-test-all: test test-gentype
+test-all: test test-gentype test-analysis test-tools
 
 reanalyze:
 	reanalyze.exe -set-exit-code -all-cmt _build/default/compiler _build/default/tests -exclude-paths compiler/outcome_printer,compiler/ml,compiler/js_parser,compiler/frontend,compiler/ext,compiler/depends,compiler/core,compiler/common,compiler/cmij,compiler/bsb_helper,compiler/bsb
@@ -95,4 +101,4 @@ dev-container:
 
 .DEFAULT_GOAL := build
 
-.PHONY: build watch rewatch ninja bench dce test test-syntax test-syntax-roundtrip test-gentype test-all lib playground playground-cmijs playground-release artifacts format checkformat clean-gentype clean-rewatch clean clean-all dev-container
+.PHONY: build watch rewatch ninja bench dce test test-syntax test-syntax-roundtrip test-gentype test-analysis test-tools test-all lib playground playground-cmijs playground-release artifacts format checkformat clean-gentype clean-rewatch clean clean-all dev-container

compiler/ml/translmod.ml

@@ -18,7 +18,7 @@
 
 open Typedtree
 
-type error = Conflicting_inline_attributes | Fragile_pattern_in_toplevel
+type error = Fragile_pattern_in_toplevel
 
 exception Error of Location.t * error
 
@@ -78,37 +78,30 @@ let rec apply_coercion loc strict (restr : Typedtree.module_coercion) arg =
   | Tcoerce_functor (cc_arg, cc_res) ->
     let param = Ident.create "funarg" in
     let carg = apply_coercion loc Alias cc_arg (Lvar param) in
-    apply_coercion_result loc strict arg [param] [carg] cc_res
+    apply_coercion_result loc strict arg param carg cc_res
   | Tcoerce_primitive {pc_loc; pc_desc; pc_env; pc_type} ->
     Translcore.transl_primitive pc_loc pc_desc pc_env pc_type
   | Tcoerce_alias (path, cc) ->
     Lambda.name_lambda strict arg (fun _ ->
         apply_coercion loc Alias cc (Lambda.transl_normal_path path))
 
-and apply_coercion_result loc strict funct params args cc_res =
-  match cc_res with
-  | Tcoerce_functor (cc_arg, cc_res) ->
-    let param = Ident.create "funarg" in
-    let arg = apply_coercion loc Alias cc_arg (Lvar param) in
-    apply_coercion_result loc strict funct (param :: params) (arg :: args)
-      cc_res
-  | _ ->
-    Lambda.name_lambda strict funct (fun id ->
-        Lfunction
-          {
-            params = List.rev params;
-            attr = {Lambda.default_function_attribute with is_a_functor = true};
-            loc;
-            body =
-              apply_coercion loc Strict cc_res
-                (Lapply
-                   {
-                     ap_loc = loc;
-                     ap_func = Lvar id;
-                     ap_args = List.rev args;
-                     ap_inlined = Default_inline;
-                   });
-          })
+and apply_coercion_result loc strict funct param arg cc_res =
+  Lambda.name_lambda strict funct (fun id ->
+      Lfunction
+        {
+          params = [param];
+          attr = {Lambda.default_function_attribute with is_a_functor = true};
+          loc;
+          body =
+            apply_coercion loc Strict cc_res
+              (Lapply
+                 {
+                   ap_loc = loc;
+                   ap_func = Lvar id;
+                   ap_args = [arg];
+                   ap_inlined = Default_inline;
+                 });
+        })
 
 and wrap_id_pos_list loc id_pos_list get_field lam =
   let fv = Lambda.free_variables lam in
@@ -210,64 +203,41 @@ let rec bound_value_identifiers : Types.signature_item list -> Ident.t list =
    functor(s) being merged with.  Such an attribute will be placed on the
    resulting merged functor. *)
 
-let merge_inline_attributes (attr1 : Lambda.inline_attribute)
-    (attr2 : Lambda.inline_attribute) loc =
-  match (attr1, attr2) with
-  | Lambda.Default_inline, _ -> attr2
-  | _, Lambda.Default_inline -> attr1
-  | _, _ ->
-    if attr1 = attr2 then attr1
-    else raise (Error (loc, Conflicting_inline_attributes))
-
-let merge_functors mexp coercion root_path =
-  let rec merge mexp coercion path acc inline_attribute =
-    let finished = (acc, mexp, path, coercion, inline_attribute) in
-    match mexp.mod_desc with
-    | Tmod_functor (param, _, _, body) ->
-      let inline_attribute' =
-        Translattribute.get_inline_attribute mexp.mod_attributes
-      in
-      let arg_coercion, res_coercion =
-        match coercion with
-        | Tcoerce_none -> (Tcoerce_none, Tcoerce_none)
-        | Tcoerce_functor (arg_coercion, res_coercion) ->
-          (arg_coercion, res_coercion)
-        | _ -> Misc.fatal_error "Translmod.merge_functors: bad coercion"
-      in
-      let loc = mexp.mod_loc in
-      let path = functor_path path param in
-      let inline_attribute =
-        merge_inline_attributes inline_attribute inline_attribute' loc
-      in
-      merge body res_coercion path
-        ((param, loc, arg_coercion) :: acc)
-        inline_attribute
-    | _ -> finished
-  in
-  merge mexp coercion root_path [] Default_inline
+let get_functor_params mexp coercion root_path =
+  match mexp.mod_desc with
+  | Tmod_functor (param, _, _, body) ->
+    let inline_attribute =
+      Translattribute.get_inline_attribute mexp.mod_attributes
+    in
+    let arg_coercion, res_coercion =
+      match coercion with
+      | Tcoerce_none -> (Tcoerce_none, Tcoerce_none)
+      | Tcoerce_functor (arg_coercion, res_coercion) ->
+        (arg_coercion, res_coercion)
+      | _ -> Misc.fatal_error "Translmod.get_functor_params: bad coercion"
+    in
+    let loc = mexp.mod_loc in
+    let path = functor_path root_path param in
+    ((param, loc, arg_coercion), body, path, res_coercion, inline_attribute)
+  | _ -> assert false
 
 let export_identifiers : Ident.t list ref = ref []
 
 let rec compile_functor mexp coercion root_path loc =
-  let functor_params_rev, body, body_path, res_coercion, inline_attribute =
-    merge_functors mexp coercion root_path
+  let functor_param, body, body_path, res_coercion, inline_attribute =
+    get_functor_params mexp coercion root_path
   in
-  assert (functor_params_rev <> []);
   (* cf. [transl_module] *)
-  let params, body =
-    List.fold_left
-      (fun (params, body) (param, loc, arg_coercion) ->
-        let param' = Ident.rename param in
-        let arg = apply_coercion loc Alias arg_coercion (Lvar param') in
-        let params = param' :: params in
-        let body = Lambda.Llet (Alias, Pgenval, param, arg, body) in
-        (params, body))
-      ([], transl_module res_coercion body_path body)
-      functor_params_rev
+  let param, loc_, arg_coercion = functor_param in
+  let param' = Ident.rename param in
+  let arg = apply_coercion loc_ Alias arg_coercion (Lvar param') in
+  let body =
+    Lambda.Llet
+      (Alias, Pgenval, param, arg, transl_module res_coercion body_path body)
   in
   Lambda.Lfunction
     {
-      params;
+      params = [param'];
       attr =
         {
           inline = inline_attribute;
@@ -513,8 +483,6 @@ let transl_implementation module_name (str, cc) =
 (* Error report *)
 
 let report_error ppf = function
-  | Conflicting_inline_attributes ->
-    Format.fprintf ppf "@[Conflicting ``inline'' attributes@]"
   | Fragile_pattern_in_toplevel ->
     Format.fprintf ppf "@[Such fragile pattern not allowed in the toplevel@]"
 

compiler/ml/typecore.ml

@@ -3517,13 +3517,14 @@ and type_application ?type_clash_context total_app env funct (sargs : sargs) :
     | Some arity ->
       let newarity = arity - nargs in
       let fully_applied = newarity <= 0 in
-      if total_app && not fully_applied then
-        raise
-          (Error
-             ( funct.exp_loc,
-               env,
-               Uncurried_arity_mismatch
-                 (funct.exp_type, arity, List.length sargs) ));
+      (if total_app && not fully_applied then
+         let required_args = List.length sargs in
+         raise
+           (Error
+              ( funct.exp_loc,
+                env,
+                Uncurried_arity_mismatch
+                  (funct.exp_type, required_args + newarity, required_args) )));
       let new_t =
         if fully_applied then new_t
         else
@@ -4466,7 +4467,7 @@ let report_error env ppf error =
       "@ @[It is applied with @{<error>%d@} argument%s but it requires \
        @{<info>%d@}.@]@]"
       args
-      (if args = 0 then "" else "s")
+      (if args = 1 then "" else "s")
       arity
   | Field_not_optional (name, typ) ->
     fprintf ppf "Field @{<info>%s@} is not optional in type %a. Use without ?"

compiler/syntax/src/res_scanner.ml

@@ -257,13 +257,13 @@ let scan_number scanner =
         8)
     | _ -> 10
   in
-  ignore (scan_digits scanner ~base);
+  let _ : bool = scan_digits scanner ~base in
 
   (*  *)
   let is_float =
     if '.' == scanner.ch then (
       next scanner;
-      ignore (scan_digits scanner ~base);
+      let _ : bool = scan_digits scanner ~base in
       true)
     else false
   in

scripts/format.sh

@@ -4,7 +4,7 @@ shopt -s extglob
 
 dune build @fmt --auto-promote
 
-files=$(find runtime tests -type f \( -name "*.res" -o -name "*.resi" \) ! -name "syntaxErrors*" ! -path "tests/syntax_*" ! -path "tests/analysis_tests/tests*" ! -path "tests/gentype_tests/typescript-react-example/node_modules")
+files=$(find runtime tests -type f \( -name "*.res" -o -name "*.resi" \) ! -name "syntaxErrors*" ! -path "tests/syntax_*" ! -path "tests/analysis_tests/tests*" ! -path "*/node_modules/*")
 ./cli/rescript format $files
 
 npm run format

scripts/format_check.sh

@@ -17,7 +17,7 @@ case "$(uname -s)" in
     fi
 
     echo "Checking ReScript code formatting..."
-    files=$(find runtime tests -type f \( -name "*.res" -o -name "*.resi" \) ! -name "syntaxErrors*" ! -path "tests/syntax_*" ! -path "tests/analysis_tests/tests*" ! -path "tests/gentype_tests/typescript-react-example/node_modules")
+    files=$(find runtime tests -type f \( -name "*.res" -o -name "*.resi" \) ! -name "syntaxErrors*" ! -path "tests/syntax_*" ! -path "tests/analysis_tests/tests*" ! -path "*/node_modules/*")
     if ./cli/rescript format -check $files; then
       printf "${successGreen}✅ ReScript code formatting ok.${reset}\n"
     else

tests/analysis_tests/tests-generic-jsx-transform/Makefile

@@ -10,7 +10,7 @@ test: build
 	./test.sh
 
 clean:
-	rm -r node_modules lib
+	rm -rf node_modules lib
 
 .DEFAULT_GOAL := test
 

tests/analysis_tests/tests-incremental-typechecking/Makefile

@@ -10,7 +10,7 @@ test: build
 	./test.sh
 
 clean:
-	rm -r node_modules lib
+	rm -rf node_modules lib
 
 .DEFAULT_GOAL := test
 

tests/analysis_tests/tests-reanalyze/deadcode/Makefile

@@ -10,7 +10,7 @@ test: build node_modules/.bin/rescript
 	./test.sh
 
 clean:
-	rm -r node_modules lib
+	rm -rf node_modules lib
 
 .DEFAULT_GOAL := build