WIP RFC FS-1092: Anonymous Type-tagged Union types

src/fsharp/CheckDeclarations.fs

@@ -4120,7 +4120,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(tc, _), tinst) 
                 | TType_app (tc, tinst) -> 

src/fsharp/CheckExpressions.fs

@@ -4303,8 +4303,12 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv
             let item = Item.AnonRecdField(anonInfo, sortedCheckedArgTys, i, x.idRange)
             CallNameResolutionSink cenv.tcSink (x.idRange,env.NameEnv,item,emptyTyparInst,ItemOccurence.UseInType,env.eAccessRights))
         TType_anon(anonInfo, sortedCheckedArgTys),tpenv
+
+    | SynType.ErasedUnion(synCases, m) ->
+        checkLanguageFeatureError cenv.g.langVersion LanguageFeature.ErasedUnions m
+        TcErasedUnionTypeOr cenv env tpenv synCases m
 
-    | SynType.Fun(domainTy, resultTy, _) ->
+    | SynType.Fun(domainTy, resultTy, _) -> 
         let domainTy', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv domainTy
         let resultTy', tpenv = TcTypeAndRecover cenv newOk checkCxs occ env tpenv resultTy
         (domainTy' --> resultTy'), tpenv
@@ -4392,6 +4396,59 @@ and TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv
     | SynType.Paren(innerType, _) ->
         TcTypeOrMeasure optKind cenv newOk checkCxs occ env (tpenv: UnscopedTyparEnv) innerType
 
+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
 

src/fsharp/ConstraintSolver.fs

@@ -739,6 +739,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 (d, r) -> if resultFirst then SimplifyMeasuresInTypes g param [r;d] else SimplifyMeasuresInTypes g param [d;r]        
@@ -777,6 +778,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 (d, r) -> GcdRational (GetMeasureVarGcdInType v d) (GetMeasureVarGcdInType v r)
@@ -993,7 +995,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 = 
@@ -1046,10 +1048,12 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr
         if not (typarsAEquiv g aenv tps1 tps2) then localAbortD else
         SolveTypeEqualsTypeKeepAbbrevs csenv ndeep m2 trace rty1 rty2 
 
-    | 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 = SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace None ty1 ty2
 
 and private SolveTypeEqualsTypeKeepAbbrevsWithCxsln csenv ndeep m2 trace cxsln ty1 ty2 = 
@@ -1147,6 +1151,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/fsharp/FSComp.txt

@@ -324,6 +324,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"
@@ -1529,6 +1530,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"
 3353,fsiInvalidDirective,"Invalid directive '#%s %s'"

src/fsharp/IlxGen.fs

@@ -547,6 +547,9 @@ and GenTypeAux amap m (tyenv: TypeReprEnv) voidOK ptrsOK ty =
     | TType_ucase (ucref, args) ->
         let cuspec, idx = GenUnionCaseSpec amap 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/fsharp/LanguageFeatures.fs

@@ -31,6 +31,7 @@ type LanguageFeature =
     | NullableOptionalInterop
     | DefaultInterfaceMemberConsumption
     | WitnessPassing
+    | ErasedUnions
     | AdditionalTypeDirectedConversions
     | InterfacesWithMultipleGenericInstantiation
     | StringInterpolation
@@ -79,6 +80,7 @@ type LanguageVersion (specifiedVersionAsString) =
             LanguageFeature.StringInterpolation, languageVersion50
 
             // F# preview
+            LanguageFeature.ErasedUnions, previewVersion
             LanguageFeature.AdditionalTypeDirectedConversions, previewVersion
             LanguageFeature.OverloadsForCustomOperations, previewVersion
             LanguageFeature.ExpandedMeasurables, previewVersion
@@ -159,6 +161,7 @@ type LanguageVersion (specifiedVersionAsString) =
         | 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/fsharp/LanguageFeatures.fsi

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

src/fsharp/NicePrint.fs

@@ -799,6 +799,17 @@ module private 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 private layoutTypesWithInfoAndPrec denv env prec sep typl = 

src/fsharp/PostInferenceChecks.fs

@@ -387,6 +387,7 @@ let rec CheckTypeDeep (cenv: cenv) (visitTy, visitTyconRefOpt, visitAppTyOpt, vi
         CheckTypesDeep cenv f g env tys
 
     | 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
     | TType_fun (s, t) -> CheckTypeDeep cenv f g env true s; CheckTypeDeep cenv f g env true t
     | TType_var tp -> 

src/fsharp/SyntaxTree.fs

@@ -371,6 +371,11 @@ type SynType =
         isStruct: bool *
         fields:(Ident * SynType) list *
         range: range
+
+    /// Erased union type definition, type X = (A | B)
+    | ErasedUnion of
+        erasedUnionCases: SynErasedUnionCase list *
+        range: range/// 
 
     | Array of
         rank: int *
@@ -431,6 +436,7 @@ type SynType =
         | SynType.Tuple (range=m)
         | SynType.Array (range=m)
         | SynType.AnonRecd (range=m)
+        | SynType.ErasedUnion (range=m)
         | SynType.Fun (range=m)
         | SynType.Var (range=m)
         | SynType.Anon (range=m)
@@ -1384,6 +1390,18 @@ type SynUnionCase =
         match this with
         | SynUnionCase (range=m) -> m
 
+[<NoEquality; NoComparison>]
+type SynErasedUnionCase =
+
+    | SynErasedUnionCase of
+        typ: SynType *
+        xmlDoc: PreXmlDoc *
+        range: range
+
+    member this.Range =
+        match this with
+        | SynErasedUnionCase (range=m) -> m
+
 [<NoEquality; NoComparison; RequireQualifiedAccess>]
 type SynUnionCaseKind =
 

src/fsharp/SyntaxTree.fsi

@@ -465,6 +465,11 @@ type SynType =
         fields:(Ident * SynType) list *
         range: range
 
+    /// Erased union type definition, type X = (A | B)
+    | ErasedUnion of
+        erasedUnionCases: SynErasedUnionCase list *
+        range: range/// 
+
     /// F# syntax: type[]
     | Array of
         rank: int *
@@ -1546,6 +1551,17 @@ type SynUnionCase =
     /// Gets the syntax range of this construct
     member Range: range
 
+[<NoEquality; NoComparison>]
+type SynErasedUnionCase =
+
+    /// The untyped, unchecked syntax tree for one case in a union definition.
+    | SynErasedUnionCase of
+        typ: SynType *
+        xmlDoc: PreXmlDoc *
+        range: range
+
+    member Range: range
+
 /// Represents the syntax tree for the right-hand-side of union definition, excluding members,
 /// in either a signature or implementation.
 [<NoEquality; NoComparison; RequireQualifiedAccess>]

src/fsharp/TypeRelations.fs

@@ -6,6 +6,7 @@ module internal FSharp.Compiler.TypeRelations
 
 open Internal.Utilities.Collections
 open Internal.Utilities.Library 
+open Internal.Utilities.Library.Extras
 open FSharp.Compiler.ErrorLogger
 open FSharp.Compiler.Infos
 open FSharp.Compiler.TcGlobals
@@ -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
@@ -94,6 +98,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
@@ -107,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_erased_union (_, l1), TType_erased_union (_, l2) ->
+        ListSet.isSupersetOf (fun x1 x2 -> TypeFeasiblySubsumesType ndeep g amap m x1 canCoerce x2) l1 l2
+    | _, TType_erased_union (_, l2) ->
+        List.forall (TypeFeasiblySubsumesType ndeep g amap m ty1 canCoerce) l2
+    | TType_erased_union (_, l1), _ ->
+        List.exists (fun x1 -> TypeFeasiblySubsumesType ndeep g amap m x1 canCoerce ty2) l1
     | TType_measure _, TType_measure _ ->
         true
 

src/fsharp/TypedTree.fs

@@ -3970,6 +3970,9 @@ type TType =
 
     /// Indicates the type is a variable type, whether declared, generalized or an inference type parameter  
     | TType_var of typar: Typar 
+
+    /// Indicates the type is a union type, containing common ancestor type and the disjoint cases
+    | TType_erased_union of unionInfo: ErasedUnionInfo * choices: TTypes
 
     /// Indicates the type is a unit-of-measure expression being used as an argument to a type or member
     | TType_measure of measure: Measure
@@ -3988,6 +3991,7 @@ type TType =
         | TType_ucase (_uc, _tinst) ->
             let (TILObjectReprData(scope, _nesting, _definition)) = _uc.Tycon.ILTyconInfo
             scope.QualifiedName
+        | TType_erased_union _ -> ""
 
     [<DebuggerBrowsable(DebuggerBrowsableState.Never)>]
     member x.DebugText = x.ToString()
@@ -4013,6 +4017,7 @@ type TType =
             | None -> tp.DisplayName
             | Some _ -> tp.DisplayName + " (solved)"
         | TType_measure ms -> ms.ToString()
+        | TType_erased_union (_, l) -> "( " + String.concat " | " (List.map string l) +  " )"
 
 type TypeInst = TType list 
 
@@ -4070,6 +4075,17 @@ type AnonRecdTypeInfo =
 
     member x.IsLinked = (match x.SortedIds with null -> true | _ -> false)
 
+[<RequireQualifiedAccess>]
+type ErasedUnionInfo =
+    { /// Common ancestor type for all cases in this union, used for ILgen
+      CommonAncestorTy: TType
+
+      /// Indices representing order of cases they were defined in
+      UnsortedCaseSourceIndices: int [] }
+    static member Create(commonAncestorTy: TType, unsortedCaseSourceIndices: int[]) =
+        { CommonAncestorTy = commonAncestorTy
+          UnsortedCaseSourceIndices = unsortedCaseSourceIndices }
+
 [<RequireQualifiedAccess>] 
 type TupInfo = 
     /// Some constant, e.g. true or false for tupInfo