Emit unboxed variant if appropriate

dist/res/src/ts2ocaml.res

@@ -23,7 +23,6 @@ module Unknown = {
 type true_ = bool
 type false_ = bool
 type symbol = Js.Types.symbol
-type bigint = Js.Bigint.t
 type intrinsic = private string
 type untypedObject = any
 type untypedFunction = any
@@ -82,7 +81,7 @@ module Intersection = {
 type intf<-'tags>
 
 module Primitive = {
-  type cases<'other> = [ #Null | #Undefined | #String(string) | #Number(float) | #Boolean(bool) | #Symbol(symbol) | #BigInt(bigint) | #Other('other) ]
+  type cases<'other> = [ #Null | #Undefined | #String(string) | #Number(float) | #Boolean(bool) | #Symbol(symbol) | #Bigint(Js.Bigint.t) | #Other('other) ]
   type t<+'cases>
 
   let return: ([< cases<'other>] as 'cases) => t<'cases> = x =>
@@ -94,6 +93,15 @@ module Primitive = {
     }
   })(x)`)
 
+  let null: t<[> #Null]> = %raw(`null`)
+  let undefined: t<[> #Undefined]> = %raw(`undefined`)
+  external string: string => t<[> #String(string)]> = "%identity"
+  external number: float => t<[> #Number(float)]> = "%identity"
+  external boolean: bool => t<[> #Boolean(bool)]> = "%identity"
+  external symbol: symbol => t<[> #Symbol(symbol)]> = "%identity"
+  external bigint: Js.Bigint.t => t<[> #Bigint(Js.Bigint.t)]> = "%identity"
+  external other: 'a => t<[> #Other('a)]> = "%identity"
+
   external fromNull: Js.null<'a> => t<[> #Null | #Other('a) ]> = "%identity"
   external toNull: t<[< #Null | #Other('a) ]> => Js.null<'a> = "%identity"
 
@@ -109,7 +117,7 @@ module Primitive = {
       | "number" => Obj.magic(#Number(Obj.magic(x)))
       | "boolean" => Obj.magic(#Boolean(Obj.magic(x)))
       | "symbol" => Obj.magic(#Symbol(Obj.magic(x)))
-      | "bigint" => Obj.magic(#BigInt(Obj.magic(x)))
+      | "bigint" => Obj.magic(#Bigint(Obj.magic(x)))
       | "undefined" => Obj.magic(#Undefined)
       | _ =>
         if (Js.testAny(x)) { Obj.magic(#Null) }

lib/Syntax.fs

@@ -230,7 +230,19 @@ and [<StructuralEquality; StructuralComparison>] FullName = {
 
 and FieldLike = { name:string; isOptional:bool; value:Type }
 
-and FuncType<'returnType> = { args:Choice<FieldLike, Type> list; isVariadic:bool; returnType:'returnType; loc: Location }
+and FuncType<'returnType> = {
+  args:Choice<FieldLike, Type> list
+  isVariadic:bool
+  returnType:'returnType
+  loc: Location
+} with
+  member this.map (f: 'returnType -> 'a) =
+    {
+      args = this.args
+      isVariadic = this.isVariadic
+      returnType = f this.returnType
+      loc = this.loc
+    }
 
 and Accessibility = Public | Protected | Private
 and Mutability = ReadOnly | WriteOnly | Mutable
@@ -317,43 +329,75 @@ and MemberAttribute = {
     member this.getComments() = this.comments
     member this.mapComments f = { this with comments = f this.comments }
 
-and Variable = {
+and Variable<'Type> = {
   name: string
-  typ: Type
+  typ: 'Type
   isConst: bool
   isExported: Exported
   accessibility : Accessibility option
   comments: Comment list
   loc: Location
 } with
-  interface ICommented<Variable> with
+  member this.map (f: 'Type -> 'a) =
+    {
+      name = this.name
+      typ = f this.typ
+      isConst = this.isConst
+      isExported = this.isExported
+      accessibility = this.accessibility
+      comments = this.comments
+      loc = this.loc
+    }
+  interface ICommented<Variable<'Type>> with
     member this.getComments() = this.comments
     member this.mapComments f = { this with comments = f this.comments }
+and Variable = Variable<Type>
 
-and Function = {
+and Function<'Type> = {
   name: string
-  typ: FuncType<Type>
+  typ: FuncType<'Type>
   typeParams: TypeParam list
   isExported: Exported
   accessibility : Accessibility option
   comments: Comment list
   loc: Location
 } with
-  interface ICommented<Function> with
+  member this.map (f: 'Type -> 'a) =
+    {
+      name = this.name
+      typ = this.typ.map f
+      typeParams = this.typeParams
+      isExported = this.isExported
+      accessibility = this.accessibility
+      comments = this.comments
+      loc = this.loc
+    }
+  interface ICommented<Function<'Type>> with
     member this.getComments() = this.comments
     member this.mapComments f = { this with comments = f this.comments }
+and Function = Function<Type>
 
-and TypeAlias = {
+and TypeAlias<'Type> = {
   name: string
   typeParams: TypeParam list
-  target: Type
+  target: 'Type
   comments: Comment list
   isExported: Exported
   loc: Location
 } with
-  interface ICommented<TypeAlias> with
+  member this.map (f: 'Type -> 'a) =
+    {
+      name = this.name
+      typeParams = this.typeParams
+      target = f this.target
+      comments = this.comments
+      isExported = this.isExported
+      loc = this.loc
+    }
+  interface ICommented<TypeAlias<'Type>> with
     member this.getComments() = this.comments
     member this.mapComments f = { this with comments = f this.comments }
+and TypeAlias = TypeAlias<Type>
 
 and Statement =
   /// ```ts
@@ -404,6 +448,9 @@ and Statement =
   /// export ...
   /// ```
   | Export of Export
+  /// ```ts
+  /// export ... from ...
+  /// ```
   | ReExport of ReExport
   | Pattern of Pattern
   | UnknownStatement of {| origText: string option; comments: Comment list; loc: Location |}

lib/Typer.fs

@@ -1021,7 +1021,22 @@ module Type =
         |> String.replace "-" "minus"
         |> String.replace "." "_"
       match l with
-      | LString s -> formatString s
+      | LString s ->
+        match s with
+        | "\r" -> "cr" | "\n" -> "lf" | "\r\n" -> "crlf" | "\t" -> "tab"
+        | " " -> "whitespace"
+        | "/" -> "sol" | "\\" -> "bsol" | "|" -> "vert"
+        | "'" -> "apos" | "\"" -> "quot" | "`" -> "grave"
+        | "!" -> "excl" | "?" -> "quest"
+        | "," -> "comma" | "." -> "period" | ":" -> "colon" | ";" -> "semi"
+        | "+" -> "plus" | "-" -> "minus" | "*" -> "ast" | "^" -> "hat"
+        | "$" -> "dollar" | "&" -> "amp" | "%" -> "percnt" | "#" -> "num" | "@" -> "commat" | "_" -> "lowbar"
+        | "[" -> "lbrack" | "]" -> "rbrack" | "(" -> "lpar" | ")" -> "rpar" | "{" -> "lbrace" | "}" -> "rbrace"
+        | "<" -> "lt" | ">" -> "gt" | "=" -> "equals"
+        | _ ->
+          if System.String.IsNullOrEmpty s then "empty"
+          else if String.forall ((=) ' ') s then $"whitespace{s.Length}"
+          else formatString s
       | LInt i -> formatNumber i
       | LFloat f -> formatNumber f
       | LBool true -> "true" | LBool false -> "false"
@@ -1373,7 +1388,17 @@ type ResolvedUnion = {
   caseEnum: Set<Choice<Enum * EnumCase * Type, Literal>>
   discriminatedUnions: Map<string, Map<Literal, Type>>
   otherTypes: Set<Type>
-}
+} with
+  member this.satisfies(?hasNull, ?hasUndefined, ?hasTypeofable, ?hasArray, ?hasEnum, ?hasDU, ?hasOther) =
+    let check opt value =
+      opt |> Option.map (fun x -> x = value) |? true
+    check hasNull this.caseNull
+    && check hasUndefined this.caseUndefined
+    && check hasTypeofable (this.typeofableTypes |> Set.isEmpty |> not)
+    && check hasArray (this.caseArray |> Option.map (Set.isEmpty >> not) |? false)
+    && check hasEnum (this.caseEnum |> Set.isEmpty |> not)
+    && check hasDU (this.discriminatedUnions |> Map.isEmpty |> not)
+    && check hasOther (this.otherTypes |> Set.isEmpty |> not)
 
 module ResolvedUnion =
   let rec pp (ru: ResolvedUnion) =

src/Targets/ReScript/ReScriptHelper.fs

@@ -83,6 +83,14 @@ module Attr =
     /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#modeling-this-based-callbacks
     let this = str "@this"
 
+  module Variant =
+    /// https://rescript-lang.org/blog/improving-interop#tagged-variants
+    let tag name =
+      tprintf "@tag(\"%s\")" (String.escape name)
+
+    /// https://rescript-lang.org/blog/improving-interop#untagged-variants
+    let unboxed = str "@unboxed"
+
   module PolyVariant =
     /// https://rescript-lang.org/docs/manual/latest/bind-to-js-function#constrain-arguments-better
     let int = str "@int"
@@ -151,7 +159,9 @@ module Naming =
 
   let constructorName (name: string list) =
     let s = String.concat "_" name |> removeInvalidChars |> upperFirst
-    if keywords |> Set.contains s then s + "_" else s
+    if s.StartsWith("_") then "C" + s
+    else if keywords |> Set.contains s then s + "_"
+    else s
 
   let structured (baseName: string -> string) (name: string list) =
     let rec prettify = function
@@ -324,23 +334,35 @@ module Type =
   let object = str "untypedObject"
   let function_ = str "untypedFunction"
   let symbol = str "symbol"
-  let regexp = str "Js.Re.t"
+  let regexp = str "Re.t"
   // ES2020
-  let bigint = str "Js.Bigint.t"
+  let bigint = str "Bigint.t"
 
   // TS types
   let never = str "never"
   let any = str "any"
   let unknown = str "unknown"
-  let null_or t = app (str "Js.null") [t]
+  let null_or t = app (str "Null.t") [t]
   let undefined_or t = app (str "option") [t]
-  let null_or_undefined_or t = app (str "Js.nullable") [t]
-  let null_ = str "Js.null<never>"
+  let null_or_undefined_or t = app (str "Nullable.t") [t]
+  let null_ = str "Null.t<never>"
   let undefined = str "unit"
   let intrinsic = str "intrinsic"
   let true_ = str "true_"
   let false_ = str "false_"
 
+  let record isInline (fields: {| name: string; isOptional: bool; attrs: text list; ty: text |} list) =
+    let body =
+      fields
+      |> List.map (fun f ->
+        let attrs = f.attrs |> List.map (fun x -> x +@ " ") |> join
+        let name = tprintf "%s%s: " f.name (if f.isOptional then "?" else "")
+        attrs + name + f.ty)
+      |> List.map (fun f -> if isInline then f else indent f)
+      |> concat (if isInline then str ", " else str ",")
+    if isInline then "{ " @+ body +@ " }"
+    else "{" @+ newline + body + newline +@ "}"
+
   // our types
   let intf tags = app (str "intf") [tags]
   let prim cases = app (str "prim") [cases]
@@ -521,3 +543,56 @@ module Statement =
         |> List.filter (fun x -> sccSet |> Set.contains x.origName |> not)
         |> emitNonRec
       sccModules @ otherModules
+
+type [<RequireQualifiedAccess>] Binding =
+  | Let of {| name: string; ty: text; body: text; attrs: text list; comments: text list |}
+  | Ext of {| name: string; ty: text; target: string; attrs: text list; comments: text list |}
+  | Unknown of {| msg:text option; comments: text list |}
+with
+  member this.comments =
+   match this with Let x -> x.comments | Ext x -> x.comments | Unknown x -> x.comments
+
+module Binding =
+  let let_ (attrs: text list) comments name ty body =
+    Binding.Let {| name = name; ty = ty; body = body; attrs = attrs; comments = comments |}
+
+  let ext (attrs: text list) comments name ty target =
+    Binding.Ext {| name = name; ty = ty; target = target; attrs = attrs; comments = comments |}
+
+  let unknown comments msg =
+    Binding.Unknown {| msg = msg; comments = comments |}
+
+  let cast comments name ty =
+    Binding.Ext {| name = name; ty = ty; target = "%identity"; attrs = []; comments = comments |}
+
+  let builder name (fields: {| isOptional: bool; name: string; value: text |} list) (thisType: text) =
+    let args =
+      fields
+      |> List.distinctBy (fun x -> x.name)
+      |> List.map (fun f ->
+        let name = f.name |> Naming.valueName
+        let suffix =
+          if f.isOptional then "=?" else ""
+        tprintf "~%s:" name + f.value +@ suffix)
+    let args =
+      match List.tryLast fields with
+      | None -> args
+      | Some last -> if last.isOptional then args @ [Type.void_] else args
+    let ty =
+      Type.curriedArrow args thisType
+    Binding.Ext {| name = name; ty = ty; target = ""; attrs = [Attr.External.obj]; comments = []|}
+
+  let emitForImplementation (b: Binding) = [
+    match b with
+    | Binding.Let x -> yield Statement.let_ x.attrs x.name x.ty x.body
+    | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target
+    | Binding.Unknown x -> match x.msg with Some msg -> yield comment msg | None -> ()
+  ]
+
+  let emitForInterface (b: Binding) = [
+    yield! b.comments
+    match b with
+    | Binding.Let x -> yield Statement.val_ x.attrs x.name x.ty
+    | Binding.Ext x -> yield Statement.external x.attrs x.name x.ty x.target
+    | Binding.Unknown x -> match x.msg with Some msg -> yield comment msg | None -> ()
+  ]