[WIP] RFC FS-1092: Anonymous Type-tagged Union types #10896

src/Compiler/Checking/CheckDeclarations.fs

@@ -3465,7 +3465,8 @@ module EstablishTypeDefinitionCores =
 
             let rec accInAbbrevType ty acc = 
                 match stripTyparEqns ty with 
-                | TType_anon (_,l) 
+                | TType_anon (_,l)
+                | TType_erased_union (_, l)
                 | TType_tuple (_, l) -> accInAbbrevTypes l acc
                 | TType_ucase (UnionCaseRef(tcref2, _), tinst) 
                 | TType_app (tcref2, tinst, _) -> 

src/Compiler/Checking/CheckExpressions.fs

@@ -7,6 +7,7 @@ module internal FSharp.Compiler.CheckExpressions
 open System
 open System.Collections.Generic
 
+open Internal.Utilities
 open Internal.Utilities.Collections
 open Internal.Utilities.Library
 open Internal.Utilities.Library.Extras
@@ -35,6 +36,7 @@ open FSharp.Compiler.TcGlobals
 open FSharp.Compiler.Text
 open FSharp.Compiler.Text.Position
 open FSharp.Compiler.Text.Range
+open FSharp.Compiler.TypeRelations
 open FSharp.Compiler.Xml
 open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeBasics
@@ -4324,6 +4326,10 @@ and TcTypeOrMeasure kindOpt (cenv: cenv) newOk checkConstraints occ (iwsam: Warn
     | SynType.AnonRecd(isStruct, args, m) ->
         TcAnonRecdType cenv newOk checkConstraints occ env tpenv isStruct args m
 
+    | SynType.ErasedUnion(synCases, m) ->
+        checkLanguageFeatureError cenv.g.langVersion LanguageFeature.ErasedUnions m
+        TcErasedUnionTypeOr cenv env tpenv synCases m
+
     | SynType.Fun(argType = domainTy; returnType = resultTy) ->
         TcFunctionType cenv newOk checkConstraints occ env tpenv domainTy resultTy
 
@@ -4572,6 +4578,62 @@ and TcTypeMeasureApp kindOpt (cenv: cenv) newOk checkConstraints occ env tpenv a
 and TcType (cenv: cenv) newOk checkConstraints occ iwsam env (tpenv: UnscopedTyparEnv) ty =
     TcTypeOrMeasure (Some TyparKind.Type) cenv newOk checkConstraints occ iwsam env tpenv ty
 
+and TcErasedUnionTypeOr (cenv: cenv) env (tpenv: UnscopedTyparEnv) synCases m =
+    let g = cenv.g
+    // Helper method for eliminating duplicate types from lists of types that form a union type,
+    // create a disjoint set of cases
+    // taking into account that a subtype is a "duplicate" of its supertype.
+    let rec addToCases (pt: TType) (list: ResizeArray<TType>) =
+        if not (ResizeArray.exists (isObjTy g) list) then
+            if isObjTy g pt then
+                list.Clear()
+                list.Add(pt)
+            elif isErasedUnionTy g pt then
+                let otherUnsortedCases = tryUnsortedErasedUnionTyCases g pt |> ValueOption.defaultValue []
+                for otherCase in otherUnsortedCases
+                    do addToCases otherCase list
+            else
+                let mutable shouldAdd = true
+                let mutable i = 0
+                while i < list.Count && shouldAdd do
+                    let t = list.[i]
+                    if isSubTypeOf cenv.g cenv.amap m pt t then
+                        shouldAdd <- false
+                    elif isSuperTypeOf cenv.g cenv.amap m pt t then
+                        list.RemoveAt(i)
+                        i <- i - 1 // redo this index
+                    i <- i + 1
+                if shouldAdd then list.Add pt
+
+    let createDisjointTypes synErasedUnionCases = 
+        let unionTypeCases = ResizeArray()
+        do
+            synErasedUnionCases
+            |> List.map(fun (SynErasedUnionCase(typ=ty)) -> TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType env tpenv ty |> fst)
+            |> List.iter (fun ty -> addToCases ty unionTypeCases)
+        ResizeArray.toList unionTypeCases
+
+    let getCommonAncestorOfTys g amap tys = 
+        let superTypes = tys |> List.map (AllPrimarySuperTypesOfType g amap m AllowMultiIntfInstantiations.No)
+        List.fold (ListSet.intersect (typeEquiv g)) (List.head superTypes) (List.tail superTypes) |> List.head
+
+    // Sort into order for ordered equality
+    let sortedIndexedErasedUnionCases =
+        createDisjointTypes synCases 
+        |> List.indexed
+        |> List.sortBy (snd >> stripTyEqnsAndMeasureEqns g >> string)
+
+    // Map from sorted indexes to unsorted index
+    let sigma = List.map fst sortedIndexedErasedUnionCases |> List.toArray
+    let sortedErasedUnionCases = List.map snd sortedIndexedErasedUnionCases
+    let commonAncestorTy = getCommonAncestorOfTys g cenv.amap sortedErasedUnionCases
+
+    let erasedUnionInfo = ErasedUnionInfo.Create(commonAncestorTy, sigma)
+    TType_erased_union(erasedUnionInfo, sortedErasedUnionCases), tpenv
+
+and TcType cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) ty =
+    TcTypeOrMeasure (Some TyparKind.Type) cenv newOk checkCxs occ env tpenv ty
+
 and TcMeasure (cenv: cenv) newOk checkConstraints occ env (tpenv: UnscopedTyparEnv) (StripParenTypes ty) m =
     match ty with
     | SynType.Anon m ->

src/Compiler/Checking/ConstraintSolver.fs

@@ -849,6 +849,7 @@ let rec SimplifyMeasuresInType g resultFirst (generalizable, generalized as para
     | TType_ucase(_, l)
     | TType_app (_, l, _) 
     | TType_anon (_,l)
+    | TType_erased_union (_,l)
     | TType_tuple (_, l) -> SimplifyMeasuresInTypes g param l
 
     | TType_fun (domainTy, rangeTy, _) ->
@@ -894,6 +895,7 @@ let rec GetMeasureVarGcdInType v ty =
     | TType_ucase(_, l)
     | TType_app (_, l, _) 
     | TType_anon (_,l)
+    | TType_erased_union (_,l)
     | TType_tuple (_, l) -> GetMeasureVarGcdInTypes v l
 
     | TType_fun (domainTy, rangeTy, _) -> GcdRational (GetMeasureVarGcdInType v domainTy) (GetMeasureVarGcdInType v rangeTy)
@@ -1125,7 +1127,7 @@ and SolveAnonInfoEqualsAnonInfo (csenv: ConstraintSolverEnv) m2 (anonInfo1: Anon
         ErrorD (ConstraintSolverError(message, csenv.m,m2)) 
     else 
         ResultD ())
-
+        
 /// Add the constraint "ty1 = ty2" to the constraint problem. 
 /// Propagate all effects of adding this constraint, e.g. to solve type variables 
 and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTrace) (cxsln:(TraitConstraintInfo * TraitConstraintSln) option) ty1 ty2 = 
@@ -1203,7 +1205,10 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr
         if not (typarsAEquiv g aenv tps1 tps2) then localAbortD else
         SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace bodyTy1 bodyTy2 
 
-    | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2  -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2
+    | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2  ->
+        SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2
+    | TType_erased_union (_, cases1), TType_erased_union (_, cases2) -> 
+        SolveTypeEqualsTypeEqns csenv ndeep m2 trace None cases1 cases2
     | _  -> localAbortD
 
 and SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace ty1 ty2 =
@@ -1307,6 +1312,22 @@ and SolveTypeSubsumesType (csenv: ConstraintSolverEnv) ndeep m2 (trace: Optional
     | TType_ucase (uc1, l1), TType_ucase (uc2, l2) when g.unionCaseRefEq uc1 uc2  -> 
         SolveTypeEqualsTypeEqns csenv ndeep m2 trace cxsln l1 l2
 
+    // (int|string) :> sty1 if
+    //    int :> sty1 AND 
+    //    string :> sty1 
+    | _, TType_erased_union (_, cases2)  ->
+        cases2 |> IterateD (fun ty2 -> SolveTypeSubsumesType csenv ndeep m2 trace cxsln sty1 ty2)
+
+    // sty2 :> (IComparable|ICloneable) if
+    //    sty2 :> IComparable OR
+    //    sty2 :> ICloneable OR
+    // when sty2 is not an erased union type
+    | TType_erased_union (_, cases1), _ -> 
+        match cases1 |> List.tryFind (fun ty1 -> TypeFeasiblySubsumesType ndeep g amap csenv.m ty1 CanCoerce sty2) with
+        | Some ty1 ->
+            SolveTypeSubsumesType csenv ndeep m2 trace cxsln ty1 sty2
+        | None -> 
+            ErrorD (ConstraintSolverError(FSComp.SR.csErasedUnionTypeNotContained(NicePrint.minimalStringOfType denv sty2, NicePrint.minimalStringOfType denv sty1), csenv.m, m2))
     | _ ->  
         // By now we know the type is not a variable type 
 

src/Compiler/Checking/NicePrint.fs

@@ -939,6 +939,17 @@ module PrintTypes =
             layoutTyparRefWithInfo denv env r
 
         | TType_measure unt -> layoutMeasure denv unt
+
+        | TType_erased_union (unionInfo, types) ->
+            let sigma = unionInfo.UnsortedCaseSourceIndices
+
+            let unsortedTyps =
+                types
+                |> List.indexed
+                |> List.sortBy (fun (sortedIdx, _) -> sigma.[sortedIdx])
+                |> List.map snd
+
+            bracketL (layoutTypesWithInfoAndPrec denv env 2 (wordL (tagPunctuation "|")) unsortedTyps)
 
     /// Layout a list of types, separated with the given separator, either '*' or ','
     and layoutTypesWithInfoAndPrec denv env prec sep typl = 

src/Compiler/Checking/PostInferenceChecks.fs

@@ -385,6 +385,9 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi
     | TType_ucase (_, tinst) ->
         CheckTypesDeep cenv f g env tinst
 
+    | TType_erased_union (_, tys) ->
+        CheckTypesDeep cenv f g env tys
+
     | TType_tuple (_, tys) ->
         CheckTypesDeep cenv f g env tys
 

src/Compiler/Checking/TypeHierarchy.fs

@@ -314,6 +314,9 @@ let SearchEntireHierarchyOfType f g amap m ty =
             | Some _ -> acc)
         g amap m ty None
 
+let AllPrimarySuperTypesOfType g amap m allowMultiIntfInst ty =
+    FoldPrimaryHierarchyOfType (ListSet.insert (typeEquiv g)) g amap m allowMultiIntfInst ty []
+
 /// Get all super types of the type, including the type itself
 let AllSuperTypesOfType g amap m allowMultiIntfInst ty =
     FoldHierarchyOfTypeAux true allowMultiIntfInst SkipUnrefInterfaces.No (ListSet.insert (typeEquiv g)) g amap m ty []
@@ -337,6 +340,20 @@ let HasHeadType g tcref ty2 =
     | ValueSome tcref2 -> tyconRefEq g tcref tcref2
     | ValueNone -> false
 
+let isSubTypeOf g amap m typeToSearchFrom typeToLookFor =
+    ExistsInEntireHierarchyOfType (typeEquiv g typeToLookFor) g amap m AllowMultiIntfInstantiations.Yes typeToSearchFrom
+
+let isSuperTypeOf g amap m typeToSearchFrom typeToLookFor =
+    isSubTypeOf g amap m typeToLookFor typeToSearchFrom 
+
+let getCommonAncestorOfTys g amap tys m = 
+    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
+
+/// choose if a type exists somewhere in the hierarchy which has the same head type as the given type (note, the given type need not have a head type at all)
+let ChooseSameHeadTypeInHierarchy g amap m typeToSearchFrom typeToLookFor =
+    SearchEntireHierarchyOfType (HaveSameHeadType g typeToLookFor)  g amap m typeToSearchFrom
+
 /// Check if a type exists somewhere in the hierarchy which has the same head type as the given type (note, the given type need not have a head type at all)
 let ExistsSameHeadTypeInHierarchy g amap m typeToSearchFrom typeToLookFor =
     ExistsInEntireHierarchyOfType (HaveSameHeadType g typeToLookFor)  g amap m AllowMultiIntfInstantiations.Yes typeToSearchFrom

src/Compiler/Checking/TypeHierarchy.fsi

@@ -92,6 +92,15 @@ val AllSuperTypesOfType:
     ty: TType ->
         TType list
 
+/// Get all super types of the type, including the type itself
+val AllPrimarySuperTypesOfType:
+    g: TcGlobals ->
+    amap: ImportMap ->
+    m: range ->
+    allowMultiIntfInst: AllowMultiIntfInstantiations ->
+    ty: TType ->
+        TType list
+
 /// Get all interfaces of a type, including the type itself if it is an interface
 val AllInterfacesOfType:
     g: TcGlobals ->
@@ -115,6 +124,16 @@ val ExistsSameHeadTypeInHierarchy:
 val ExistsHeadTypeInEntireHierarchy:
     g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> tcrefToLookFor: TyconRef -> bool
 
+/// Check if one (nominal) type is a subtype of another
+val isSubTypeOf: g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool
+
+/// Check if one (nominal) type is a supertype of another
+val isSuperTypeOf:
+    g: TcGlobals -> amap: ImportMap -> m: range -> typeToSearchFrom: TType -> typeToLookFor: TType -> bool
+
+/// Get the common ancestor of a set of nominal types
+val getCommonAncestorOfTys: g: TcGlobals -> amap: ImportMap -> tys: TTypes -> m: range -> TType
+
 /// Read an Abstract IL type from metadata and convert to an F# type.
 val ImportILTypeFromMetadata:
     amap: ImportMap -> m: range -> scoref: ILScopeRef -> tinst: TType list -> minst: TType list -> ilTy: ILType -> TType

src/Compiler/Checking/TypeRelations.fs

@@ -6,7 +6,9 @@ module internal FSharp.Compiler.TypeRelations
 
 open Internal.Utilities.Collections
 open Internal.Utilities.Library 
+open Internal.Utilities.Library.Extras
 open FSharp.Compiler.DiagnosticsLogger
+open FSharp.Compiler.Infos
 open FSharp.Compiler.TcGlobals
 open FSharp.Compiler.TypedTree
 open FSharp.Compiler.TypedTreeBasics
@@ -81,6 +83,9 @@ let rec TypesFeasiblyEquivalent stripMeasures ndeep g amap m ty1 ty2 =
         TypesFeasiblyEquivalent stripMeasures ndeep g amap m domainTy1 domainTy2 &&
         TypesFeasiblyEquivalent stripMeasures ndeep g amap m rangeTy1 rangeTy2
 
+    | TType_erased_union (_, l1), TType_erased_union (_, l2)     -> 
+        List.lengthsEqAndForall2 (TypesFeasiblyEquivalent stripMeasures ndeep g amap m) l1 l2 
+
     | TType_measure _, TType_measure _ ->
         true
 
@@ -96,6 +101,7 @@ let TypesFeasiblyEquivStripMeasures g amap m ty1 ty2 =
     TypesFeasiblyEquivalent true 0 g amap m ty1 ty2
 
 /// The feasible coercion relation. Part of the language spec.
+/// Test whether ty2 :> ty1, for erased union (A|B :> A)
 let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 = 
     if ndeep > 100 then error(InternalError("recursive class hierarchy (detected in TypeFeasiblySubsumesType), ty1 = " + (DebugPrint.showType ty1), m))
     let ty1 = stripTyEqns g ty1
@@ -111,6 +117,9 @@ let rec TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce ty2 =
     | TType_fun _, TType_fun _ ->
         TypesFeasiblyEquiv ndeep g amap m ty1 ty2
 
+    | 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/Compiler/CodeGen/IlxGen.fs

@@ -704,6 +704,9 @@ and GenTypeAux cenv m (tyenv: TypeReprEnv) voidOK ptrsOK ty =
     | TType_ucase (ucref, args) ->
         let cuspec, idx = GenUnionCaseSpec cenv m tyenv ucref args
         EraseUnions.GetILTypeForAlternative cuspec idx
+
+    | TType_erased_union (erasedUnionInfo, _) ->
+        GenTypeArgAux amap m tyenv erasedUnionInfo.CommonAncestorTy
 
     | TType_forall (tps, tau) ->
         let tps = DropErasedTypars tps

src/Compiler/FSComp.txt

@@ -330,6 +330,7 @@ csTypeIsNotEnumType,"The type '%s' is not a CLI enum type"
 csTypeHasNonStandardDelegateType,"The type '%s' has a non-standard delegate type"
 csTypeIsNotDelegateType,"The type '%s' is not a CLI delegate type"
 csTypeParameterCannotBeNullable,"This type parameter cannot be instantiated to 'Nullable'. This is a restriction imposed in order to ensure the meaning of 'null' in some CLI languages is not confusing when used in conjunction with 'Nullable' values."
+csErasedUnionTypeNotContained,"The erased union type '%s' is not compatible with the erased union type '%s'"
 csGenericConstructRequiresStructType,"A generic construct requires that the type '%s' is a CLI or F# struct type"
 csGenericConstructRequiresUnmanagedType,"A generic construct requires that the type '%s' is an unmanaged type"
 csTypeNotCompatibleBecauseOfPrintf,"The type '%s' is not compatible with any of the types %s, arising from the use of a printf-style format string"
@@ -1549,6 +1550,7 @@ featureNullableOptionalInterop,"nullable optional interop"
 featureDefaultInterfaceMemberConsumption,"default interface member consumption"
 featureStringInterpolation,"string interpolation"
 featureWitnessPassing,"witness passing for trait constraints in F# quotations"
+featureErasedUnions,"erased unions"
 featureAdditionalImplicitConversions,"additional type-directed conversions"
 featureStructActivePattern,"struct representation for active patterns"
 featureRelaxWhitespace2,"whitespace relaxation v2"

src/Compiler/Facilities/LanguageFeatures.fs

@@ -32,6 +32,7 @@ type LanguageFeature =
     | NullableOptionalInterop
     | DefaultInterfaceMemberConsumption
     | WitnessPassing
+    | ErasedUnions
     | AdditionalTypeDirectedConversions
     | InterfacesWithMultipleGenericInstantiation
     | StringInterpolation
@@ -124,6 +125,7 @@ type LanguageVersion(versionText) =
                 LanguageFeature.SelfTypeConstraints, languageVersion70
 
                 // F# preview
+                LanguageFeature.ErasedUnions, previewVersion
                 LanguageFeature.FromEndSlicing, previewVersion
                 LanguageFeature.MatchNotAllowedForUnionCaseWithNoData, previewVersion
             ]
@@ -210,6 +212,7 @@ type LanguageVersion(versionText) =
         | LanguageFeature.NullableOptionalInterop -> FSComp.SR.featureNullableOptionalInterop ()
         | LanguageFeature.DefaultInterfaceMemberConsumption -> FSComp.SR.featureDefaultInterfaceMemberConsumption ()
         | LanguageFeature.WitnessPassing -> FSComp.SR.featureWitnessPassing ()
+        | LanguageFeature.ErasedUnions -> FSComp.SR.featureErasedUnions()
         | LanguageFeature.AdditionalTypeDirectedConversions -> FSComp.SR.featureAdditionalImplicitConversions ()
         | LanguageFeature.InterfacesWithMultipleGenericInstantiation -> FSComp.SR.featureInterfacesWithMultipleGenericInstantiation ()
         | LanguageFeature.StringInterpolation -> FSComp.SR.featureStringInterpolation ()

src/Compiler/Facilities/LanguageFeatures.fsi

@@ -22,6 +22,7 @@ type LanguageFeature =
     | NullableOptionalInterop
     | DefaultInterfaceMemberConsumption
     | WitnessPassing
+    | ErasedUnions
     | AdditionalTypeDirectedConversions
     | InterfacesWithMultipleGenericInstantiation
     | StringInterpolation

src/Compiler/Service/ItemKey.fs

@@ -40,6 +40,9 @@ module ItemKeyTags =
 
     [<Literal>]
     let typeUnionCase = "#U#"
+
+    [<Literal>]
+    let typeErasedUnionCase = "#G#"
 
     [<Literal>]
     let typeMeasureVar = "#p#"
@@ -262,6 +265,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

src/Compiler/Symbols/Symbols.fs

@@ -2513,6 +2513,7 @@ type FSharpType(cenv, ty:TType) =
             | TType_fun (domainTy, rangeTy, _) -> 10500 + hashType domainTy + hashType rangeTy
             | TType_measure _ -> 10600 
             | TType_anon (_,l1) -> 10800 + List.sumBy hashType l1
+            | TType_erased_union (_,l1) -> 10900 + List.sumBy hashType l1
         hashType ty
 
     member _.Format(context: FSharpDisplayContext) =