WIP: Prototyping Erased Union types

src/fsharp/CheckDeclarations.fs

@@ -4124,7 +4124,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

@@ -4269,7 +4269,56 @@ 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
+        // 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 (ErasedUnionCase(typ=ty)) -> TcTypeAndRecover cenv NoNewTypars CheckCxs ItemOccurence.UseInType env tpenv ty |> fst)
+                |> List.iter (fun ty -> addToCases ty unionTypeCases)
+            ResizeArray.toList unionTypeCases
+
+        // 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 m
+
+        let erasedUnionInfo = ErasedUnionInfo.Create(commonAncestorTy, sigma)
+        TType_erased_union(erasedUnionInfo, sortedErasedUnionCases), tpenv
+
     | 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
@@ -4358,6 +4407,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 (ErasedUnionCase(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

@@ -740,6 +740,7 @@ let rec SimplifyMeasuresInType g resultFirst ((generalizable, generalized) as pa
     | 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]        
@@ -778,6 +779,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)
@@ -994,7 +996,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 = 
@@ -1031,6 +1033,7 @@ and SolveTypeEqualsType (csenv: ConstraintSolverEnv) ndeep m2 (trace: OptionalTr
         -> SolveTypeEqualsType csenv ndeep m2 trace None ms (TType_measure Measure.One)
 
     | TType_app (tc1, l1), TType_app (tc2, l2) when tyconRefEq g tc1 tc2  -> SolveTypeEqualsTypeEqns csenv ndeep m2 trace None l1 l2
+
     | TType_app (_, _), TType_app (_, _)   ->  localAbortD
     | TType_tuple (tupInfo1, l1), TType_tuple (tupInfo2, l2)      -> 
         if evalTupInfoIsStruct tupInfo1 <> evalTupInfoIsStruct tupInfo2 then ErrorD (ConstraintSolverError(FSComp.SR.tcTupleStructMismatch(), csenv.m, m2)) else
@@ -1047,10 +1050,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 = 
@@ -1148,6 +1153,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

@@ -323,6 +323,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"
@@ -1521,7 +1522,8 @@ featureNullableOptionalInterop,"nullable optional interop"
 featureDefaultInterfaceMemberConsumption,"default interface member consumption"
 featureStringInterpolation,"string interpolation"
 featureWitnessPassing,"witness passing for trait constraints in F# quotations"
-featureImplicitConversion,"implicit upcasts and other conversions for function returns, bindings and other expressions"
+featureImplicitConversion,"additional implicit conversions"
+featureErasedUnions,"erased unions"
 3353,fsiInvalidDirective,"Invalid directive '#%s %s'"
 3360,typrelInterfaceWithConcreteAndVariable,"'%s' cannot implement the interface '%s' with the two instantiations '%s' and '%s' because they may unify."
 3361,typrelInterfaceWithConcreteAndVariableObjectExpression,"You cannot implement the interface '%s' with the two instantiations '%s' and '%s' because they may unify."

src/fsharp/IlxGen.fs

@@ -537,6 +537,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

@@ -33,6 +33,7 @@ type LanguageFeature =
     | DefaultInterfaceMemberConsumption
     | WitnessPassing
     | ImplicitConversion
+    | ErasedUnions
     | InterfacesWithMultipleGenericInstantiation
     | StringInterpolation
     | OverloadsForCustomOperations
@@ -76,6 +77,7 @@ type LanguageVersion (specifiedVersionAsString) =
 
             // F# preview
             LanguageFeature.ImplicitConversion, previewVersion
+            LanguageFeature.ErasedUnions, previewVersion
             LanguageFeature.OverloadsForCustomOperations, previewVersion
             LanguageFeature.ExpandedMeasurables, previewVersion
             LanguageFeature.FromEndSlicing, previewVersion
@@ -149,6 +151,7 @@ type LanguageVersion (specifiedVersionAsString) =
         | LanguageFeature.DefaultInterfaceMemberConsumption -> FSComp.SR.featureDefaultInterfaceMemberConsumption()
         | LanguageFeature.WitnessPassing -> FSComp.SR.featureWitnessPassing()
         | LanguageFeature.ImplicitConversion -> FSComp.SR.featureImplicitConversion()
+        | LanguageFeature.ErasedUnions -> FSComp.SR.featureErasedUnions()
         | LanguageFeature.InterfacesWithMultipleGenericInstantiation -> FSComp.SR.featureInterfacesWithMultipleGenericInstantiation()
         | LanguageFeature.StringInterpolation -> FSComp.SR.featureStringInterpolation()
         | LanguageFeature.OverloadsForCustomOperations -> FSComp.SR.featureOverloadsForCustomOperations()

src/fsharp/LanguageFeatures.fsi

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

src/fsharp/NicePrint.fs

@@ -714,6 +714,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

@@ -375,6 +375,7 @@ let rec CheckTypeDeep (cenv: cenv) ((visitTy, visitTyconRefOpt, visitAppTyOpt, v
         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

@@ -454,6 +454,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/// 
 
     /// F# syntax: type[]
     | Array of
@@ -527,6 +532,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)
@@ -1667,6 +1673,19 @@ type SynUnionCase =
         match this with
         | UnionCase (range=m) -> m
 
+[<NoEquality; NoComparison>]
+type SynErasedUnionCase =
+
+    /// The untyped, unchecked syntax tree for one case in a union definition.
+    | ErasedUnionCase of
+        typ: SynType *
+        xmlDoc: PreXmlDoc *
+        range: range
+
+    member this.Range =
+        match this with
+        | ErasedUnionCase (range=m) -> m
+
 /// Represents the syntax tree for the right-hand-side of union definition, excluding members,
 /// in either a signature or implementation.
 [<NoEquality; NoComparison>]

src/fsharp/TypeRelations.fs

@@ -9,6 +9,7 @@ open FSharp.Compiler.AbstractIL.Internal.Library
 open FSharp.Compiler.ErrorLogger
 open FSharp.Compiler.Infos
 open FSharp.Compiler.TcGlobals
+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
@@ -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