Bring syntax to master.

Author: cristianoc

jscomp/main/rescript_compiler_main.ml

@@ -183,7 +183,6 @@ let format_file input =
     match ext with 
     | Ml | Mli -> `ml
     | Res | Resi -> `res 
-    | Re | Rei -> `refmt (Filename.concat (Filename.dirname Sys.executable_name) "refmt.exe") 
     | _ -> Bsc_args.bad_arg ("don't know what to do with " ^ input) in   
   let formatted =   Res_multi_printer.print syntax ~input in 
   match !Clflags.output_name with 

lib/4.06.1/unstable/js_compiler.ml

@@ -261670,9 +261670,10 @@ let otherAttrsPure (loc, _) = loc.txt <> "react.component"
 let hasAttrOnBinding { pvb_attributes } = find_opt hasAttr pvb_attributes <> None
 
 (* Finds the name of the variable the binding is assigned to, otherwise raises Invalid_argument *)
-let getFnName binding =
+let rec getFnName binding =
   match binding with
-  | { pvb_pat = { ppat_desc = Ppat_var { txt } } } -> txt
+  | { ppat_desc = Ppat_var { txt } } -> txt
+  | { ppat_desc = Ppat_constraint (pat, _) } -> getFnName pat
   | _ -> raise (Invalid_argument "react.component calls cannot be destructured.")
   [@@raises Invalid_argument]
 
@@ -261809,6 +261810,17 @@ let makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList =
     (makePropsType ~loc namedTypeList)
   [@@raises Invalid_argument]
 
+let newtypeToVar newtype type_ =
+  let var_desc = Ptyp_var ("type-" ^ newtype) in
+  let typ (mapper : Ast_mapper.mapper) typ =
+    match typ.ptyp_desc with
+    | Ptyp_constr ({txt = Lident name}, _) when name = newtype ->
+      {typ with ptyp_desc = var_desc}
+    | _ -> Ast_mapper.default_mapper.typ mapper typ
+  in
+  let mapper = {Ast_mapper.default_mapper with typ} in
+  mapper.typ mapper type_
+
 (* TODO: some line number might still be wrong *)
 let jsxMapper () =
   let jsxVersion = ref None in
@@ -261911,7 +261923,7 @@ let jsxMapper () =
     [@@raises Invalid_argument]
   in
 
-  let rec recursivelyTransformNamedArgsForMake mapper expr list =
+  let rec recursivelyTransformNamedArgsForMake mapper expr args newtypes =
     let expr = mapper.expr mapper expr in
     match expr.pexp_desc with
     (* TODO: make this show up with a loc. *)
@@ -261952,19 +261964,23 @@ let jsxMapper () =
         let type_ = match pattern with { ppat_desc = Ppat_constraint (_, type_) } -> Some type_ | _ -> None in
 
         recursivelyTransformNamedArgsForMake mapper expression
-          ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: list)
+          ((arg, default, pattern, alias, pattern.ppat_loc, type_) :: args) newtypes
     | Pexp_fun (Nolabel, _, { ppat_desc = Ppat_construct ({ txt = Lident "()" }, _) | Ppat_any }, _expression) ->
-        (list, None)
+        (args, newtypes, None)
     | Pexp_fun
         ( Nolabel,
           _,
           { ppat_desc = Ppat_var { txt } | Ppat_constraint ({ ppat_desc = Ppat_var { txt } }, _) },
           _expression ) ->
-        (list, Some txt)
+        (args, newtypes, Some txt)
     | Pexp_fun (Nolabel, _, pattern, _expression) ->
         Location.raise_errorf ~loc:pattern.ppat_loc
           "React: react.component refs only support plain arguments and type annotations."
-    | _ -> (list, None)
+    | Pexp_newtype (label, expression) ->
+        recursivelyTransformNamedArgsForMake mapper expression args (label :: newtypes)
+    | Pexp_constraint (expression, _typ) ->
+        recursivelyTransformNamedArgsForMake mapper expression args newtypes
+    | _ -> (args, newtypes, None)
     [@@raises Invalid_argument]
   in
 
@@ -262064,7 +262080,7 @@ let jsxMapper () =
             let bindingLoc = binding.pvb_loc in
             let bindingPatLoc = binding.pvb_pat.ppat_loc in
             let binding = { binding with pvb_pat = { binding.pvb_pat with ppat_loc = emptyLoc }; pvb_loc = emptyLoc } in
-            let fnName = getFnName binding in
+            let fnName = getFnName binding.pvb_pat in
             let internalFnName = fnName ^ "$Internal" in
             let fullModuleName = makeModuleName fileName !nestedModules fnName in
             let modifiedBindingOld binding =
@@ -262073,7 +262089,8 @@ let jsxMapper () =
               let rec spelunkForFunExpression expression =
                 match expression with
                 (* let make = (~prop) => ... *)
-                | { pexp_desc = Pexp_fun _ } -> expression
+                | { pexp_desc = Pexp_fun _ }
+                | { pexp_desc = Pexp_newtype _ } -> expression
                 (* let make = {let foo = bar in (~prop) => ...} *)
                 | { pexp_desc = Pexp_let (_recursive, _vbs, returnExpression) } ->
                     (* here's where we spelunk! *)
@@ -262083,6 +262100,8 @@ let jsxMapper () =
                     spelunkForFunExpression innerFunctionExpression
                 | { pexp_desc = Pexp_sequence (_wrapperExpression, innerFunctionExpression) } ->
                     spelunkForFunExpression innerFunctionExpression
+                | { pexp_desc = Pexp_constraint (innerFunctionExpression, _typ) } ->
+                    spelunkForFunExpression innerFunctionExpression
                 | _ ->
                     raise
                       (Invalid_argument
@@ -262171,8 +262190,8 @@ let jsxMapper () =
             in
             let props = getPropsAttr payload in
             (* do stuff here! *)
-            let namedArgList, forwardRef =
-              recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) []
+            let namedArgList, newtypes, forwardRef =
+              recursivelyTransformNamedArgsForMake mapper (modifiedBindingOld binding) [] []
             in
             let namedArgListWithKeyAndRef =
               (optional "key", None, Pat.var { txt = "key"; loc = emptyLoc }, "key", emptyLoc, Some (keyType emptyLoc))
@@ -262207,7 +262226,25 @@ let jsxMapper () =
             in
             let namedTypeList = List.fold_left argToType [] namedArgList in
             let loc = emptyLoc in
-            let externalDecl = makeExternalDecl fnName loc namedArgListWithKeyAndRef namedTypeList in
+            let externalArgs = (* translate newtypes to type variables *)
+              List.fold_left
+                (fun args newtype ->
+                   List.map (fun (a, b, c, d, e, maybeTyp) ->
+                       match maybeTyp with
+                       | Some typ -> (a, b, c, d, e, Some (newtypeToVar newtype.txt typ))
+                       | None -> (a, b, c, d, e, None))
+                     args)
+                namedArgListWithKeyAndRef
+                newtypes
+            in
+            let externalTypes = (* translate newtypes to type variables *)
+              List.fold_left
+                (fun args newtype ->
+                   List.map (fun (a, b, typ) -> (a, b, newtypeToVar newtype.txt typ)) args)
+                namedTypeList
+                newtypes
+            in
+            let externalDecl = makeExternalDecl fnName loc externalArgs externalTypes in
             let innerExpressionArgs =
               List.map pluckArg namedArgListWithKeyAndRefForNew
               @ if hasUnit then [ (Nolabel, Exp.construct { loc; txt = Lident "()" } None) ] else []
@@ -262237,7 +262274,7 @@ let jsxMapper () =
                 {
                   ppat_desc =
                     Ppat_constraint
-                      (makePropsName ~loc:emptyLoc props.propsName, makePropsType ~loc:emptyLoc namedTypeList);
+                      (makePropsName ~loc:emptyLoc props.propsName, makePropsType ~loc:emptyLoc externalTypes);
                   ppat_loc = emptyLoc;
                   ppat_attributes = [];
                 }