GenType: removed support for @genType.as which has become unnecessary.

Author: cristianoc

CHANGELOG.md

@@ -46,6 +46,7 @@ These are only breaking changes for unformatted code.
 - Remove deprecated module `Printexc`
 - `@deriving(jsConverter)` not supported anymore for variant types https://github.com/rescript-lang/rescript-compiler/pull/6088
 - New representation for variants, where the tag is a string instead of a number. https://github.com/rescript-lang/rescript-compiler/pull/6088
+- GenType: removed support for `@genType.as` for records and variants which has become unnecessary. Use the language's `@as` instead to channge the runtime representation without requiring any runtime conversion during FFI.
 
 #### :bug: Bug Fix
 

Makefile

@@ -13,7 +13,7 @@ bench:
 	$(DUNE_BIN_DIR)/syntax_benchmarks
 
 dce:
-	reanalyze.exe -- -dce-cmt _build
+	reanalyze.exe -dce-cmt _build/default/jscomp
 
 ninja/ninja:
 	./scripts/buildNinjaBinary.js
@@ -42,7 +42,7 @@ test-gentype:
 test-all: test test-gentype
 
 reanalyze:
-	reanalyze.exe -set-exit-code -all-cmt _build/default/res_syntax -suppress res_syntax/testrunner
+	reanalyze.exe -set-exit-code -all-cmt _build/default/jscomp -suppress res_syntax/testrunner -exclude-paths jscomp/super_errors,jscomp/outcome_printer,jscomp/ounit_tests,jscomp/ml,jscomp/js_parser,jscomp/frontend,jscomp/ext,jscomp/depends,jscomp/core,jscomp/common,jscomp/cmij,jscomp/bsb_helper,jscomp/bsb
 
 lib: build node_modules/.bin/semver
 	node scripts/ninja.js config

jscomp/gentype/Annotation.ml

@@ -64,65 +64,89 @@ let rec getAttributePayload checkText (attributes : Typedtree.attributes) =
   in
   match attributes with
   | [] -> None
-  | ({Asttypes.txt}, payload) :: _tl when checkText txt -> (
+  | ({txt; loc}, payload) :: _tl when checkText txt -> (
+    let payload =
+      match payload with
+      | PStr [] -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_eval (expr, _)} :: _) -> expr |> fromExpr
+      | PStr ({pstr_desc = Pstr_extension _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_value _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_primitive _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_type _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_typext _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_exception _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_module _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_recmodule _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_modtype _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_open _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_class _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_class_type _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_include _} :: _) -> Some UnrecognizedPayload
+      | PStr ({pstr_desc = Pstr_attribute _} :: _) -> Some UnrecognizedPayload
+      | PPat _ -> Some UnrecognizedPayload
+      | PSig _ -> Some UnrecognizedPayload
+      | PTyp _ -> Some UnrecognizedPayload
+    in
     match payload with
-    | PStr [] -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_eval (expr, _)} :: _) -> expr |> fromExpr
-    | PStr ({pstr_desc = Pstr_extension _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_value _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_primitive _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_type _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_typext _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_exception _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_module _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_recmodule _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_modtype _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_open _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_class _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_class_type _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_include _} :: _) -> Some UnrecognizedPayload
-    | PStr ({pstr_desc = Pstr_attribute _} :: _) -> Some UnrecognizedPayload
-    | PPat _ -> Some UnrecognizedPayload
-    | PSig _ -> Some UnrecognizedPayload
-    | PTyp _ -> Some UnrecognizedPayload)
+    | None -> None
+    | Some payload -> Some (loc, payload))
   | _hd :: tl -> getAttributePayload checkText tl
 
 let getGenTypeAsRenaming attributes =
   match attributes |> getAttributePayload tagIsGenTypeAs with
-  | Some (StringPayload s) -> Some s
+  | Some (_, StringPayload s) -> Some s
   | None -> (
     match attributes |> getAttributePayload tagIsGenType with
-    | Some (StringPayload s) -> Some s
+    | Some (_, StringPayload s) -> Some s
     | _ -> None)
   | _ -> None
 
+(* This is not supported anymore: only use to give a warning *)
+let checkUnsupportedGenTypeAsRenaming attributes =
+  let error ~loc =
+    Log_.Color.setup ();
+    Log_.info ~loc ~name:"Warning genType" (fun ppf () ->
+        Format.fprintf ppf
+          "@\n\
+           @genType.as is not supported anymore in type definitions. Use @as \
+           from the language.")
+  in
+  match attributes |> getAttributePayload tagIsGenTypeAs with
+  | Some (loc, _) -> error ~loc
+  | None -> (
+    match attributes |> getAttributePayload tagIsGenType with
+    | Some (loc, _) -> error ~loc
+    | None -> ())
+
 let getBsAsRenaming attributes =
   match attributes |> getAttributePayload tagIsBsAs with
-  | Some (StringPayload s) -> Some s
+  | Some (_, StringPayload s) -> Some s
   | _ -> None
 
 let getBsAsInt attributes =
   match attributes |> getAttributePayload tagIsBsAs with
-  | Some (IntPayload s) -> (
+  | Some (_, IntPayload s) -> (
     try Some (int_of_string s) with Failure _ -> None)
   | _ -> None
 
 let getAttributeImportRenaming attributes =
   let attributeImport = attributes |> getAttributePayload tagIsGenTypeImport in
   let genTypeAsRenaming = attributes |> getGenTypeAsRenaming in
   match (attributeImport, genTypeAsRenaming) with
-  | Some (StringPayload importString), _ ->
+  | Some (_, StringPayload importString), _ ->
     (Some importString, genTypeAsRenaming)
   | ( Some
-        (TuplePayload [StringPayload importString; StringPayload renameString]),
+        ( _,
+          TuplePayload [StringPayload importString; StringPayload renameString]
+        ),
       _ ) ->
     (Some importString, Some renameString)
   | _ -> (None, genTypeAsRenaming)
 
 let getDocString attributes =
   let docPayload = attributes |> getAttributePayload tagIsOcamlDoc in
   match docPayload with
-  | Some (StringPayload docString) -> "/** " ^ docString ^ " */\n"
+  | Some (_, StringPayload docString) -> "/** " ^ docString ^ " */\n"
   | _ -> ""
 
 let hasAttribute checkText (attributes : Typedtree.attributes) =
@@ -133,7 +157,7 @@ let fromAttributes ~loc (attributes : Typedtree.attributes) =
   else if hasAttribute (fun s -> tagIsGenType s || tagIsGenTypeAs s) attributes
   then (
     (match attributes |> getAttributePayload tagIsGenType with
-    | Some UnrecognizedPayload -> ()
+    | Some (_, UnrecognizedPayload) -> ()
     | Some _ ->
       Log_.Color.setup ();
       Log_.info ~loc ~name:"Warning genType" (fun ppf () ->

jscomp/gentype/Converter.ml

@@ -198,10 +198,10 @@ let typeGetConverterNormalized ~config ~inline ~lookupId ~typeNameIsInterface
       in
       ( ObjectC
           (fieldsConverted
-          |> List.map (fun ({nameJS; nameRE; optional}, (converter, _)) ->
+          |> List.map (fun ({nameJS; optional}, (converter, _)) ->
                  {
                    lblJS = nameJS;
-                   lblRE = nameRE;
+                   lblRE = nameJS;
                    c =
                      (match optional = Mandatory with
                      | true -> converter
@@ -357,14 +357,7 @@ let rec converterIsIdentity ~config ~toJS converter =
                 argConverter |> converterIsIdentity ~config ~toJS:(not toJS)
               | GroupConverter _ -> false)
   | IdentC -> true
-  | ObjectC fieldsC ->
-    fieldsC
-    |> List.for_all (fun {lblJS; lblRE; c} ->
-           lblJS = lblRE
-           &&
-           match c with
-           | OptionC c1 -> c1 |> converterIsIdentity ~config ~toJS
-           | _ -> c |> converterIsIdentity ~config ~toJS)
+  | ObjectC _ -> true
   | OptionC c -> c |> converterIsIdentity ~config ~toJS
   | PromiseC c -> c |> converterIsIdentity ~config ~toJS
   | TupleC innerTypesC ->
@@ -456,7 +449,7 @@ let rec apply ~config ~converter ~indent ~nameGen ~toJS ~variantTables value =
             groupConverters
             |> List.mapi (fun i (s, _optional, argConverter) ->
                    s ^ ":"
-                   ^ (varNamesArr.(i)
+                   ^ ((varNamesArr.(i) [@doesNotRaise])
                      |> apply ~config ~converter:argConverter ~indent:indent2
                           ~nameGen ~toJS:notToJS ~variantTables))
             |> String.concat ", "

jscomp/gentype/EmitJs.ml

@@ -513,7 +513,9 @@ let rec readCmtFilesRecursively ~config ~env ~inputCmtTranslateTypeDeclarations
       let exportTypeMapFromCmt =
         typeDeclarations
         |> createExportTypeMap ~config ~fromCmtReadRecursively:true
-             ~file:(cmtFile |> Filename.basename |> Filename.chop_extension)
+             ~file:
+               (cmtFile |> Filename.basename
+              |> (Filename.chop_extension [@doesNotRaise]))
       in
       let cmtToExportTypeMap =
         env.cmtToExportTypeMap |> StringMap.add cmtFile exportTypeMapFromCmt

jscomp/gentype/EmitText.ml

@@ -49,7 +49,7 @@ let newNameGen () = Hashtbl.create 1
 let quotes x = "\"" ^ x ^ "\""
 
 let quotesIfRequired x =
-  match String.length x > 0 && x.[0] = '"' with
+  match String.length x > 0 && (x.[0] [@doesNotRaise]) = '"' with
   | true -> x
   | false -> quotes x
 

jscomp/gentype/EmitType.ml

@@ -60,16 +60,15 @@ let typeReactRef ~type_ =
         {
           mutable_ = Mutable;
           nameJS = reactRefCurrent;
-          nameRE = reactRefCurrent;
           optional = Mandatory;
           type_ = Null type_;
         };
       ] )
 
 let isTypeReactRef ~fields =
   match fields with
-  | [{mutable_ = Mutable; nameJS; nameRE; optional = Mandatory}] ->
-    nameJS == reactRefCurrent && nameJS == nameRE
+  | [{mutable_ = Mutable; nameJS; optional = Mandatory}] ->
+    nameJS == reactRefCurrent
   | _ -> false
 
 let isTypeFunctionComponent ~fields type_ =
@@ -182,7 +181,6 @@ let rec renderType ~(config : Config.t) ?(indent = None) ~typeNameIsInterface
       {
         mutable_ = Mutable;
         nameJS = name;
-        nameRE = name;
         optional = Mandatory;
         type_ = TypeVar value;
       }

jscomp/gentype/ExportModule.ml

@@ -56,7 +56,6 @@ and exportModuleItemToFields =
            {
              mutable_ = Mutable;
              nameJS = fieldName;
-             nameRE = fieldName;
              optional = Mandatory;
              type_ = typeForType;
            }

jscomp/gentype/GenTypeCommon.ml

@@ -18,7 +18,7 @@ type case = {label: string; labelJS: labelJS}
 
 let isJSSafePropertyName name =
   name = ""
-  || (match name.[0] with
+  || (match name.[0] [@doesNotRaise] with
      | 'A' .. 'z' -> true
      | _ -> false)
      && name
@@ -36,12 +36,12 @@ let labelJSToString ?(alwaysQuotes = false) case =
     let len = String.length s in
     len > 0
     && (match len > 1 with
-       | true -> s.[0] > '0'
+       | true -> (s.[0] [@doesNotRaise]) > '0'
        | false -> true)
     &&
     let res = ref true in
     for i = 0 to len - 1 do
-      match s.[i] with
+      match s.[i] [@doesNotRaise] with
       | '0' .. '9' -> ()
       | _ -> res := false
     done;
@@ -78,7 +78,6 @@ and argType = {aName: string; aType: type_}
 and field = {
   mutable_: mutable_;
   nameJS: string;
-  nameRE: string;
   optional: optional;
   type_: type_;
 }
@@ -248,7 +247,7 @@ module NodeFilename = struct
 
     let concat dirname filename =
       let isDirSep s i =
-        let c = s.[i] in
+        let c = (s.[i] [@doesNotRaise]) in
         c = '/' || c = '\\' || c = ':'
       in
       let l = length dirname in

jscomp/gentype/GenTypeConfig.ml

@@ -76,7 +76,9 @@ let getShims map =
            | Ext_json_types.Str {str} ->
              let fromTo = str |> String.split_on_char '=' |> Array.of_list in
              assert (Array.length fromTo == 2);
-             shims := (fromTo.(0), fromTo.(1)) :: !shims
+             shims :=
+               ((fromTo.(0) [@doesNotRaise]), (fromTo.(1) [@doesNotRaise]))
+               :: !shims
            | _ -> ())
   | _ -> ());
   !shims

jscomp/gentype/GenTypeMain.ml

@@ -126,7 +126,9 @@ let processCmtFile cmt =
         inputCMT |> cmtCheckAnnotations ~checkAnnotation
       in
       if isInterface then
-        let cmtFileImpl = (cmtFile |> Filename.chop_extension) ^ ".cmt" in
+        let cmtFileImpl =
+          (cmtFile |> (Filename.chop_extension [@doesNotRaise])) ^ ".cmt"
+        in
         let inputCMTImpl = readCmt cmtFileImpl in
         let hasGenTypeAnnotationsImpl =
           inputCMTImpl
@@ -168,3 +170,4 @@ let processCmtFile cmt =
     else (
       outputFile |> GeneratedFiles.logFileAction NoMatch;
       if Sys.file_exists outputFile then Sys.remove outputFile)
+  [@@live]

jscomp/gentype/GeneratedFiles.ml

@@ -27,7 +27,7 @@ let readLines (file : string) : string list =
       done;
       []
     with End_of_file ->
-      close_in chan;
+      close_in chan [@doesNotRaise];
       !lines |> List.rev
   in
   finished_lines
@@ -37,7 +37,7 @@ let readFile (file : string) : string = String.concat "\n" (readLines file)
 let writeFile (filePath : string) (contents : string) =
   let outFile = open_out filePath in
   output_string outFile contents;
-  close_out outFile
+  close_out outFile [@doesNotRaise]
 
 let writeFileIfRequired ~outputFile ~fileContents =
   if Sys.file_exists outputFile then

jscomp/gentype/ModuleName.ml

@@ -13,7 +13,9 @@ let sanitizeId s =
            | c -> c)
     else s
   in
-  if s <> "" && s.[0] >= 'A' && s.[0] <= 'z' then s else "_" ^ s
+  if s <> "" && (s.[0] [@doesNotRaise]) >= 'A' && (s.[0] [@doesNotRaise]) <= 'z'
+  then s
+  else "_" ^ s
 
 let forBsFile s = sanitizeId s ^ "BS"
 

jscomp/gentype/NamedArgs.ml

@@ -14,25 +14,13 @@ let rec groupReversed ~revCurGroup ~revResult labeledTypes =
     (* Add it to the current group, not result. *)
     groupReversed
       ~revCurGroup:
-        ({
-           mutable_ = Immutable;
-           nameJS = name;
-           nameRE = name;
-           optional = Optional;
-           type_;
-         }
+        ({mutable_ = Immutable; nameJS = name; optional = Optional; type_}
         :: revCurGroup)
       ~revResult tl
   | _, (Label name, type_) :: tl ->
     groupReversed
       ~revCurGroup:
-        ({
-           mutable_ = Immutable;
-           nameJS = name;
-           nameRE = name;
-           optional = Mandatory;
-           type_;
-         }
+        ({mutable_ = Immutable; nameJS = name; optional = Mandatory; type_}
         :: revCurGroup)
       ~revResult tl
   | [], [] -> revResult