Implement --experimental-tagged-union

build/build.fs

@@ -172,7 +172,7 @@ module Test =
 
       let packages = [
          // "full" package involving a lot of inheritance
-         "full", !! "node_modules/typescript/lib/typescript.d.ts", [];
+         "full", !! "node_modules/typescript/lib/typescript.d.ts", ["--experimental-tagged-union"];
 
          // "full" packages involving a lot of dependencies (which includes some "safe" packages)
          "safe", !! "node_modules/@types/scheduler/tracing.d.ts", [];

dist/res/src/ts2ocaml.res

@@ -125,14 +125,6 @@ module Primitive = {
     }
 }
 
-module Interop = {
-  module PolyVariant = {
-    let name  = (it: 'PolyVariant) : 'name => %raw(`it.NAME`)
-    let value = (it: 'PolyVariant) : 'value => %raw(`it.VAL`)
-    let make  = (name: 'name, value: 'value) : 'PolyVariant => %raw(`{ NAME: name, VAL: value }`)
-  }
-}
-
 module Newable = {
   type t0<'t>
   type t1<'arg1, 't>
@@ -222,4 +214,12 @@ module ThisType = { type t<'a> }
 module Uppercase = { type t<'s> = private intrinsic }
 module Lowercase = { type t<'s> = private intrinsic }
 module Capitalize = { type t<'s> = private intrinsic }
-module Uncapitalize = { type t<'s> = private intrinsic }
+module Uncapitalize = { type t<'s> = private intrinsic }
+
+// utilities for experimental features
+module Experimental = {
+  module Variant = {
+    let box = (it: 't, tag: string) : 'Variant => %raw(`{ [tag]: it[tag], _0: it }`)
+    let unbox = (it: 'Variant) : 't => %raw(`it._0`)
+  }
+}

docs/rescript.md

@@ -768,3 +768,73 @@ TypeScript code often has mutually recursive definitions. ReScript support defin
 >
 > Also, you wouldn't need this unless you're using the [`--no-resi`](#--no-resi) option, as the `Types` module is hidden by the `.resi` file and won't show up in the editor autocompletion.
 
+# Experimental Options
+
+> **Warning:**
+> These features are experimental and may be subject to change.
+
+## `--experimental-tagged-union`
+
+Emit additional variant type for tagged union.
+
+Assume we have the following input:
+
+```typescript
+interface Foo {
+  kind: "foo";
+  ...
+}
+
+interface Bar {
+  kind: "bar";
+  ...
+}
+
+type FooBar = Foo | Bar;
+```
+
+Normally, `ts2ocaml` would generate the following code:
+
+```rescript
+module Foo = {
+  type t
+  @get external get_kind: (t) => string = "kind"
+  ...
+}
+
+module Bar = {
+  type t
+  @get external get_kind: (t) => string = "kind"
+  ...
+}
+
+module FooBar = {
+  type t = Union.t2<Foo.t, Bar.t>
+}
+```
+
+With this option, `ts2ocaml` will generate an additional type `FooBar.cases` and additional functions `FooBar.box` and `FooBar.unbox`:
+
+```rescript
+module FooBar = {
+  type t = Union.t2<Foo.t, Bar.t>
+
+  @tag("kind") type cases =
+    | @as("foo") Foo (Foo.t)
+    | @as("bar") Bar (Bar.t)
+
+  let box: (t) => cases = ...
+  let unbox: (cases) => t = ...
+}
+```
+
+Now you can match over the tagged union type by `box`ing it first:
+
+```rescript
+let x : FooBar.t = ...
+
+switch x->FooBar.box {
+  | Foo(foo) => ...
+  | Bar(bar) => ...
+}
+```

lib/Common.fs

@@ -35,6 +35,7 @@ type OverloadRenamer(?rename: string -> int -> string, ?used: Set<string * strin
   ///
   /// `category` can be arbitrary, but it is intended for something like `value`, `type`, `module`, etc.
   member __.Rename (category: string) (name: string) =
+    let name = String.normalize name
     match m.TryGetValue((category, name)) with
     | true, i ->
       m.[(category, name)] <- i + 1

lib/Extensions.fs

@@ -105,6 +105,20 @@ module Map =
       | Some v1 -> m1 |> Map.add k (f v1 v2)
     ) m1
 
+  let intersectWith f m1 m2 =
+    let getKeys = Map.keys >> Set.ofSeq
+    Set.intersect (getKeys m1) (getKeys m2)
+    |> Set.toSeq
+    |> Seq.choose (fun key ->
+      let v1 = m1 |> Map.tryFind key
+      let v2 = m2 |> Map.tryFind key
+      match v1, v2 with
+      | None, None -> None
+      | Some v, None
+      | None, Some v -> Some (key, v)
+      | Some v1, Some v2 -> f v1 v2 |> Option.map (fun v -> key, v))
+    |> Map.ofSeq
+
 type MutableMap<'k, 'v> = Collections.Generic.Dictionary<'k, 'v>
 type MutableSet<'v> = Collections.Generic.HashSet<'v>
 

lib/Typer.fs

@@ -1071,6 +1071,69 @@ module Type =
         s1 + s2
     | UnknownType _ -> "unknown"
 
+  module GetAnonymousInterfaces =
+    let rec treatFuncType (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (ft: FuncType<Type>) tps =
+      seq {
+        for arg in ft.args do
+          let ty, origin =
+            match arg with
+            | Choice1Of2 fl -> fl.value, { state.origin with argName = Some fl.name }
+            | Choice2Of2 t -> t, state.origin
+          yield! findTypes typeFinder {| state with origin = origin |} ty
+        yield! findTypes typeFinder state ft.returnType
+        yield! treatTypeParameters state tps
+      }
+    and treatTypeParameters (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (tps: TypeParam list) =
+      seq {
+        for tp in tps do
+          yield! tp.extends |> Option.map (findTypes typeFinder state) |? Seq.empty
+          yield! tp.defaultType |> Option.map (findTypes typeFinder state) |? Seq.empty
+      }
+    and treatNamed (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) name value =
+      findTypes typeFinder {| state with origin = { state.origin with valueName = Some name } |} value
+    and typeFinder (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) ty =
+      let inline resultMany xs = Some [], state, xs
+      match ty with
+      | App (AAnonymousInterface i, _, _) | AnonymousInterface i ->
+        let inner =
+          let state = {| state with origin = AnonymousInterfaceOrigin.Empty |}
+          treatClassLike state (i.MapName(ignore))
+        None, {| state with origin = AnonymousInterfaceOrigin.Empty |}, Seq.append [i, state] inner
+      | Func (ft, tps, _) | NewableFunc (ft, tps, _) ->
+        treatFuncType state ft tps |> resultMany
+      | Union { types = types } | Intersection { types = types } ->
+        Some types, state, Seq.empty
+      | _ -> None, {| state with origin = AnonymousInterfaceOrigin.Empty |}, Seq.empty
+    and treatClassLike (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (c: Class<unit>) =
+      seq {
+        for _, m in c.members do
+          match m with
+          | Method (name, ft, tps) ->
+            yield! treatFuncType {| state with origin = { state.origin with valueName = Some name } |} ft tps
+          | Newable (ft, tps) | Callable (ft, tps) -> yield! treatFuncType state ft tps
+          | Field (fl, _) | Getter fl | Setter fl -> yield! treatNamed state fl.name fl.value
+          | Indexer (ft, _) -> yield! treatFuncType state ft []
+          | SymbolIndexer (name, ft, _) ->
+            yield! treatFuncType {| state with origin = { state.origin with valueName = Some name } |} ft []
+          | Constructor ft ->
+            for arg in ft.args do
+              let ty, origin =
+                match arg with
+                | Choice1Of2 fl -> fl.value, { state.origin with argName = Some fl.name }
+                | Choice2Of2 t -> t, state.origin
+              yield! findTypes typeFinder {| state with origin = origin |} ty
+          | UnknownMember _ -> ()
+        for t in c.implements do
+          yield! findTypes typeFinder state t
+        yield! treatTypeParameters state c.typeParams
+      }
+  let getAnonymousInterfaces ty =
+    let state = {|
+      origin = AnonymousInterfaceOrigin.Empty
+      namespace_ = []
+    |}
+    findTypes GetAnonymousInterfaces.typeFinder state ty
+
 module Statement =
   open Type
 
@@ -1145,81 +1208,25 @@ module Statement =
       () stmts |> Set.ofSeq
 
   let getAnonymousInterfaces stmts : Set<AnonymousInterface * {| origin: AnonymousInterfaceOrigin; namespace_: string list |}> =
-    let rec treatFuncType (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (ft: FuncType<Type>) tps =
-      seq {
-        for arg in ft.args do
-          let ty, origin =
-            match arg with
-            | Choice1Of2 fl -> fl.value, { state.origin with argName = Some fl.name }
-            | Choice2Of2 t -> t, state.origin
-          yield! findTypes typeFinder {| state with origin = origin |} ty
-        yield! findTypes typeFinder state ft.returnType
-        yield! treatTypeParameters state tps
-      }
-    and treatTypeParameters (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (tps: TypeParam list) =
-      seq {
-        for tp in tps do
-          yield! tp.extends |> Option.map (findTypes typeFinder state) |? Seq.empty
-          yield! tp.defaultType |> Option.map (findTypes typeFinder state) |? Seq.empty
-      }
-    and treatNamed (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) name value =
-      findTypes typeFinder {| state with origin = { state.origin with valueName = Some name } |} value
-    and typeFinder (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) ty =
-      let inline resultMany xs = Some [], state, xs
-      match ty with
-      | App (AAnonymousInterface i, _, _) | AnonymousInterface i ->
-        let inner =
-          let state = {| state with origin = AnonymousInterfaceOrigin.Empty |}
-          treatClassLike state (i.MapName(ignore))
-        None, {| state with origin = AnonymousInterfaceOrigin.Empty |}, Seq.append [i, state] inner
-      | Func (ft, tps, _) | NewableFunc (ft, tps, _) ->
-        treatFuncType state ft tps |> resultMany
-      | Union { types = types } | Intersection { types = types } ->
-        Some types, state, Seq.empty
-      | _ -> None, {| state with origin = AnonymousInterfaceOrigin.Empty |}, Seq.empty
-    and treatClassLike (state: {| origin: AnonymousInterfaceOrigin; namespace_: string list |}) (c: Class<unit>) =
-      seq {
-        for _, m in c.members do
-          match m with
-          | Method (name, ft, tps) ->
-            yield! treatFuncType {| state with origin = { state.origin with valueName = Some name } |} ft tps
-          | Newable (ft, tps) | Callable (ft, tps) -> yield! treatFuncType state ft tps
-          | Field (fl, _) | Getter fl | Setter fl -> yield! treatNamed state fl.name fl.value
-          | Indexer (ft, _) -> yield! treatFuncType state ft []
-          | SymbolIndexer (name, ft, _) ->
-            yield! treatFuncType {| state with origin = { state.origin with valueName = Some name } |} ft []
-          | Constructor ft ->
-            for arg in ft.args do
-              let ty, origin =
-                match arg with
-                | Choice1Of2 fl -> fl.value, { state.origin with argName = Some fl.name }
-                | Choice2Of2 t -> t, state.origin
-              yield! findTypes typeFinder {| state with origin = origin |} ty
-          | UnknownMember _ -> ()
-        for t in c.implements do
-          yield! findTypes typeFinder state t
-        yield! treatTypeParameters state c.typeParams
-      }
-
     findStatements (fun currentNamespace state stmt ->
       let inline result_ x = Some [], state, x
       let state = {| origin = state; namespace_ = currentNamespace |}
       match stmt with
       | TypeAlias ta ->
         let state = {| state with origin = { state.origin with typeName = Some ta.name } |}
         seq {
-          yield! findTypes typeFinder state ta.target
-          yield! treatTypeParameters state ta.typeParams
+          yield! findTypes GetAnonymousInterfaces.typeFinder state ta.target
+          yield! GetAnonymousInterfaces.treatTypeParameters state ta.typeParams
         } |> result_
       | Variable v ->
-        treatNamed state v.name v.typ |> result_
+        GetAnonymousInterfaces.treatNamed state v.name v.typ |> result_
       | Function f ->
-        treatFuncType {| state with origin = { state.origin with valueName = Some f.name } |} f.typ f.typeParams |> result_
+        GetAnonymousInterfaces.treatFuncType {| state with origin = { state.origin with valueName = Some f.name } |} f.typ f.typeParams |> result_
       | Class c ->
         let typeName =
           match c.name with Name n -> Some n | _ -> None
         let state = {| state with namespace_ = currentNamespace; origin = { state.origin with typeName = typeName } |}
-        treatClassLike state (c.MapName(ignore)) |> result_
+        GetAnonymousInterfaces.treatClassLike state (c.MapName(ignore)) |> result_
       | _ -> None, state.origin, Seq.empty
     ) AnonymousInterfaceOrigin.Empty stmts |> Set.ofSeq
 
@@ -1428,6 +1435,26 @@ module ResolvedUnion =
     ]
     cases |> String.concat " | "
 
+  let expand ctx (u: UnionType) : UnionType =
+    let (|Dummy|) _ = []
+    let rec go (t: Type) =
+      match t with
+      | Union { types = types } ->
+        let types = types |> List.collect (fun ty -> go ty |? [ty])
+        if types |> List.exists (function AnonymousInterface _ -> true | _ -> false) then None
+        else Some types
+      | (Ident ({ loc = loc } & i) & Dummy tyargs)
+      | App (AIdent i, tyargs, loc) ->
+        let finder = function
+          | Definition.TypeAlias a ->
+            let bindings = Type.createBindings i.name loc a.typeParams tyargs
+            go (a.target |> Type.substTypeVar bindings ())
+          | _ -> None
+        i |> Ident.getDefinitions ctx
+          |> List.tryPick (finder)
+      | _ -> None
+    { u with types = u.types |> List.collect (fun ty -> go ty |? [ty]) |> List.distinct }
+
   let checkNullOrUndefined (u: UnionType) : {| hasNull: bool; hasUndefined: bool; rest: Type list |} =
     let u = Type.normalizeUnion u
     let nullOrUndefined, rest =

src/Targets/ReScript/Common.fs

@@ -80,6 +80,8 @@ type Options =
   abstract simplify: Simplify list with get, set
   abstract readableNames: bool with get, set
   abstract noTypesModule: bool with get, set
+  // experimental options
+  abstract experimentalTaggedUnion: bool with get, set
 
 module Options =
   open Fable.Core.JsInterop
@@ -229,6 +231,19 @@ module Options =
         defaultValue = false
       )
 
+      .group(
+        !^ResizeArray[
+          "experimental-tagged-union"
+        ],
+        "Experimental Options:"
+      )
+      .addFlag(
+        "experimental-tagged-union",
+        (fun (o: Options) -> o.experimentalTaggedUnion),
+        descr="Experimental. Emit additional variant type for tagged union.",
+        defaultValue=false
+      )
+
       .middleware(!^validate)
 
 

src/Targets/ReScript/ReScriptHelper.fs

@@ -405,15 +405,13 @@ module Term =
     | _ :: [] -> failwith "1-ary tuple"
     | xs -> concat (str ", ") xs |> between "(" ")"
 
-  let appCurried t us = t + (us |> concat (str ", ") |> between "(" ")")
-  let appUncurried t us = t + (us |> concat (str ", ") |> between "(. " ")")
+  let app t us = t + (us |> concat (str ", ") |> between "(" ")")
 
   /// `(arg1, arg2) => ret`
   let arrow args ret =
     let lhs =
       match args with
-      | [] -> failwith "0-ary function"
-      | [x] -> x
+      | [] -> str "()"
       | xs -> concat (str ", ") xs |> between "(" ")"
     lhs +@ " => " + ret