Implements checks in TypeFeasiblySubsumes and WIP fix TType_erased_un…

…ion usages

src/fsharp/CheckExpressions.fs

@@ -4270,7 +4270,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv
                 |> List.iter (fun ty -> addToCases ty unionTypeCases)
             ResizeArray.toList unionTypeCases
 
-        let commonAncestorTy g amap tys = 
+        let getCommonAncestorOfTys g amap tys = 
             let superTypes = List.map (AllPrimarySuperTypesOfType g amap m AllowMultiIntfInstantiations.No) tys
             List.fold (ListSet.intersect (typeEquiv g)) (List.head superTypes) (List.tail superTypes) |> List.head
 
@@ -4283,7 +4283,7 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv
         // Map from sorted indexes to unsorted index
         let sigma = List.map fst sortedIndexedErasedUnionCases |> List.toArray
         let sortedErasedUnionCases = List.map snd sortedIndexedErasedUnionCases
-        let commonAncestorTy = commonAncestorTy g cenv.amap sortedErasedUnionCases
+        let commonAncestorTy = getCommonAncestorOfTys g cenv.amap sortedErasedUnionCases
 
         let erasedUnionInfo = ErasedUnionInfo.Create(commonAncestorTy, sigma)
         TType_erased_union(erasedUnionInfo, sortedErasedUnionCases), tpenv

src/fsharp/TypeRelations.fs

@@ -7,6 +7,7 @@ module internal FSharp.Compiler.TypeRelations
 open FSharp.Compiler.AbstractIL.Internal 
 open FSharp.Compiler.AbstractIL.Internal.Library 
 open FSharp.Compiler.ErrorLogger
+open FSharp.Compiler.Lib
 open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeBasics
 open FSharp.Compiler.TypedTreeOps
@@ -78,6 +79,9 @@ let rec TypesFeasiblyEquivalent stripMeasures ndeep g amap m ty1 ty2 =
 
     | TType_fun (d1, r1), TType_fun (d2, r2)   -> 
         (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) d1 d2 && (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) r1 r2
+
+    | TType_erased_union (_, l1), TType_erased_union (_, l2)     -> 
+        List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 
 
     | TType_measure _, TType_measure _ ->
         true
@@ -108,7 +112,12 @@ let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 =
     | TType_tuple _, TType_tuple _
     | TType_anon _, TType_anon _
     | TType_fun _, TType_fun _ -> TypesFeasiblyEquiv ndeep g amap m ty1 ty2
-
+    | TType_app _, TType_erased_union (_, l2) ->
+        List.forall (TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce) l2
+    | TType_erased_union (_, l1), TType_app _ ->
+        List.exists (fun x1 -> TypeFeasiblySubsumesType ndeep g amap m x1 canCoerce ty1) l1
+    | TType_erased_union (_, l1), TType_erased_union (_, l2) ->
+        ListSet.isSupersetOf (fun x1 x2 -> TypeFeasiblySubsumesType ndeep g amap m x1 canCoerce x2) l1 l2
     | TType_measure _, TType_measure _ ->
         true
 

src/fsharp/TypedTreeOps.fs

@@ -3517,6 +3517,7 @@ module DebugPrint =
            auxTyparsL env tcL prefix tinst
         | TType_anon (anonInfo, tys) -> braceBarL (sepListL (wordL (tagText ";")) (List.map2 (fun nm ty -> wordL (tagField nm) --- auxTypeAtomL env ty) (Array.toList anonInfo.SortedNames) tys))
         | TType_tuple (_tupInfo, tys) -> sepListL (wordL (tagText "*")) (List.map (auxTypeAtomL env) tys) |> wrap
+        | TType_erased_union (_, tys) -> leftL (tagText "(") ^^ sepListL (wordL (tagText "|")) (List.map (auxTypeAtomL env) tys) ^^ rightL (tagText ")")
         | TType_fun (f, x) -> ((auxTypeAtomL env f ^^ wordL (tagText "->")) --- auxTypeL env x) |> wrap
         | TType_var typar -> auxTyparWrapL env isAtomic typar 
         | TType_measure unt -> 
@@ -8079,6 +8080,9 @@ let rec typeEnc g (gtpsType, gtpsMethod) ty =
         typarEnc g (gtpsType, gtpsMethod) typar
 
     | TType_measure _ -> "?"
+    | TType_erased_union (_, tys) ->
+        // SWOORUP TODO idk
+        typeEnc g (gtpsType, gtpsMethod) (List.head tys) + "|"
 
 and tyargsEnc g (gtpsType, gtpsMethod) args = 
      match args with     

src/fsharp/service/ItemKey.fs

@@ -42,6 +42,9 @@ module ItemKeyTags =
 
     [<Literal>]
     let typeUnionCase = "#U#"
+
+    [<Literal>]
+    let typeErasedUnionCase = "#G#"
 
     [<Literal>]
     let typeMeasureVar = "#p#"
@@ -251,6 +254,9 @@ and [<Sealed>] ItemKeyStoreBuilder() =
                 writeString ItemKeyTags.typeUnionCase
                 writeEntityRef tcref
                 writeString nm
+        | TType_erased_union (_, tinst) ->
+            writeString ItemKeyTags.typeErasedUnionCase
+            tinst |> List.iter (writeType false)
 
     and writeMeasure isStandalone (ms: Measure) =
         match ms with