Make .Is* discriminated union properties visible (#16341)

* Merge? * Fantomas * Fix naming * fixes * Translations + tests fixes * Fixed tests * Fix code formatting * Fix the build * Add backticks test * Remove unused code * Format * Fix test * Fix surface area * Add more tests * Revert rename * Add more tests --------- Co-authored-by: Vlad Zarytovskii <[email protected]> Co-authored-by: Alex Corrado <[email protected]>
dotnet · Dec 7, 2023 · 9123c41 · 9123c41
1 parent af3f2a1
commit 9123c41
Show file tree

Hide file tree

Showing 50 changed files with 1,860 additions and 886 deletions.
diff --git a/src/Compiler/AbstractIL/il.fsi b/src/Compiler/AbstractIL/il.fsi
@@ -1990,6 +1990,7 @@ val internal mkILNonGenericStaticMethSpecInTy: ILType * string * ILType list * I
 
 /// Construct references to constructors.
 val internal mkILCtorMethSpecForTy: ILType * ILType list -> ILMethodSpec
+val internal mkILNonGenericCtorMethSpec: ILTypeRef * ILType list -> ILMethodSpec
 
 /// Construct references to fields.
 val internal mkILFieldRef: ILTypeRef * string * ILType -> ILFieldRef

diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fs b/src/Compiler/Checking/AugmentWithHashCompare.fs
diff --git a/src/Compiler/Checking/AugmentWithHashCompare.fsi b/src/Compiler/Checking/AugmentWithHashCompare.fsi
@@ -1,7 +1,7 @@
 // Copyright (c) Microsoft Corporation.  All Rights Reserved.  See License.txt in the project root for license information.
 
 /// Generate the hash/compare functions we add to user-defined types by default.
-module internal FSharp.Compiler.AugmentWithHashCompare
+module internal FSharp.Compiler.AugmentTypeDefinitions
 
 open FSharp.Compiler
 open FSharp.Compiler.TypedTree
@@ -34,3 +34,7 @@ val MakeBindingsForEqualityWithComparerAugmentation: TcGlobals -> Tycon -> Bindi
 /// This predicate can be used once type inference is complete, before then it is an approximation
 /// that doesn't assert any new constraints
 val TypeDefinitelyHasEquality: TcGlobals -> TType -> bool
+
+val MakeValsForUnionAugmentation: TcGlobals -> TyconRef -> Val list
+
+val MakeBindingsForUnionAugmentation: TcGlobals -> Tycon -> ValRef list -> Binding list
diff --git a/src/Compiler/Checking/CheckDeclarations.fs b/src/Compiler/Checking/CheckDeclarations.fs
diff --git a/src/Compiler/Checking/CheckExpressions.fs b/src/Compiler/Checking/CheckExpressions.fs
@@ -1090,14 +1090,14 @@ let PublishValueDefnPrim (cenv: cenv) env (vspec: Val) =
     UpdateAccModuleOrNamespaceType cenv env (fun _ mty ->
         mty.AddVal vspec)
 
-let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) =
+let PublishValueDefnMaybeInclCompilerGenerated (cenv: cenv) env inclCompilerGenerated declKind (vspec: Val) =
     let g = cenv.g
     let isNamespace =
         let kind = (GetCurrAccumulatedModuleOrNamespaceType env).ModuleOrNamespaceKind
         match kind with
         | Namespace _ -> true
         | _ -> false
-    
+
     if (declKind = ModuleOrMemberBinding) &&
        isNamespace &&
        (Option.isNone vspec.MemberInfo) then
@@ -1116,7 +1116,7 @@ let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) =
 
     match vspec.MemberInfo with
     | Some _ when
-        (not vspec.IsCompilerGenerated &&
+        ((not vspec.IsCompilerGenerated || inclCompilerGenerated) &&
          // Extrinsic extensions don't get added to the tcaug
          declKind <> ExtrinsicExtensionBinding) ->
          // // Static initializers don't get published to the tcaug
@@ -1128,6 +1128,9 @@ let PublishValueDefn (cenv: cenv) env declKind (vspec: Val) =
         tcaug.tcaug_adhoc_list.Add (ValRefIsExplicitImpl g vref, vref)
     | _ -> ()
 
+let PublishValueDefn cenv env declKind vspec =
+    PublishValueDefnMaybeInclCompilerGenerated cenv env false declKind vspec
+
 let CombineVisibilityAttribs vis1 vis2 m =
     match vis1 with
     | Some _ ->

diff --git a/src/Compiler/Checking/CheckExpressions.fsi b/src/Compiler/Checking/CheckExpressions.fsi
@@ -578,6 +578,10 @@ val PublishTypeDefn: cenv: TcFileState -> env: TcEnv -> mspec: Tycon -> unit
 /// Publish a value definition to the module/namespace type accumulator.
 val PublishValueDefn: cenv: TcFileState -> env: TcEnv -> declKind: DeclKind -> vspec: Val -> unit
 
+/// Publish a value definition to the module/namespace type accumulator.
+val PublishValueDefnMaybeInclCompilerGenerated:
+    cenv: TcFileState -> env: TcEnv -> inclCompilerGenerated: bool -> declKind: DeclKind -> vspec: Val -> unit
+
 /// Mark a typar as no longer being an inference type variable
 val SetTyparRigid: DisplayEnv -> range -> Typar -> unit
 

diff --git a/src/Compiler/Checking/ConstraintSolver.fs b/src/Compiler/Checking/ConstraintSolver.fs
@@ -2359,7 +2359,7 @@ and SolveTypeSupportsComparison (csenv: ConstraintSolverEnv) ndeep m2 trace ty =
                // Give a good error for structural types excluded from the comparison relation because of their fields
                elif (isAppTy g ty && 
                      let tcref = tcrefOfAppTy g ty 
-                     AugmentWithHashCompare.TyconIsCandidateForAugmentationWithCompare g tcref.Deref && 
+                     AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithCompare g tcref.Deref && 
                      Option.isNone tcref.GeneratedCompareToWithComparerValues) then
 
                    ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportComparison3(NicePrint.minimalStringOfType denv ty), m, m2))
@@ -2389,7 +2389,7 @@ and SolveTypeSupportsEquality (csenv: ConstraintSolverEnv) ndeep m2 trace ty =
                match ty with
                | AppTy g (tcref, tinst) ->
                    // Give a good error for structural types excluded from the equality relation because of their fields
-                   if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tcref.Deref && 
+                   if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tcref.Deref && 
                        Option.isNone tcref.GeneratedHashAndEqualsWithComparerValues 
                    then
                        ErrorD (ConstraintSolverError(FSComp.SR.csTypeDoesNotSupportEquality3(NicePrint.minimalStringOfType denv ty), m, m2))

diff --git a/src/Compiler/Checking/MethodOverrides.fs b/src/Compiler/Checking/MethodOverrides.fs
@@ -901,12 +901,12 @@ let FinalTypeDefinitionChecksAtEndOfInferenceScope (infoReader: InfoReader, nenv
        not tycon.IsFSharpInterfaceTycon
      then
         (* Warn when we're doing this for class types *)
-        if AugmentWithHashCompare.TyconIsCandidateForAugmentationWithEquals g tycon then
+        if AugmentTypeDefinitions.TyconIsCandidateForAugmentationWithEquals g tycon then
             warning(Error(FSComp.SR.typrelTypeImplementsIComparableShouldOverrideObjectEquals(tycon.DisplayName), tycon.Range))
         else
             warning(Error(FSComp.SR.typrelTypeImplementsIComparableDefaultObjectEqualsProvided(tycon.DisplayName), tycon.Range))
 
-    AugmentWithHashCompare.CheckAugmentationAttribs isImplementation g amap tycon
+    AugmentTypeDefinitions.CheckAugmentationAttribs isImplementation g amap tycon
     // Check some conditions about generic comparison and hashing. We can only check this condition after we've done the augmentation 
     if isImplementation 
 #if !NO_TYPEPROVIDERS

diff --git a/src/Compiler/Checking/NameResolution.fs b/src/Compiler/Checking/NameResolution.fs
@@ -4317,15 +4317,15 @@ let ResolveCompletionsInType (ncenv: NameResolver) nenv (completionTargets: Reso
             not minfo.IsExtensionMember &&
             match minfo.LogicalName with
             | "GetType"  -> false
-            | "GetHashCode"  -> isObjTy g minfo.ApparentEnclosingType && not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty)
+            | "GetHashCode"  -> isObjTy g minfo.ApparentEnclosingType && not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty)
             | "ToString" -> false
             | "Equals" ->
                 if not (isObjTy g minfo.ApparentEnclosingType) then
                     // declaring type is not System.Object - show it
                     false
                 elif minfo.IsInstance then
                     // System.Object has only one instance Equals method and we want to suppress it unless Augment.TypeDefinitelyHasEquality is true
-                    not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty)
+                    not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty)
                 else
                     // System.Object has only one static Equals method and we always want to suppress it
                     true
@@ -5017,15 +5017,15 @@ let ResolveCompletionsInTypeForItem (ncenv: NameResolver) nenv m ad statics ty (
                     not minfo.IsExtensionMember &&
                     match minfo.LogicalName with
                     | "GetType"  -> false
-                    | "GetHashCode"  -> isObjTy g minfo.ApparentEnclosingType && not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty)
+                    | "GetHashCode"  -> isObjTy g minfo.ApparentEnclosingType && not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty)
                     | "ToString" -> false
                     | "Equals" ->
                         if not (isObjTy g minfo.ApparentEnclosingType) then
                             // declaring type is not System.Object - show it
                             false
                         elif minfo.IsInstance then
                             // System.Object has only one instance Equals method and we want to suppress it unless Augment.TypeDefinitelyHasEquality is true
-                            not (AugmentWithHashCompare.TypeDefinitelyHasEquality g ty)
+                            not (AugmentTypeDefinitions.TypeDefinitelyHasEquality g ty)
                         else
                             // System.Object has only one static Equals method and we always want to suppress it
                             true

diff --git a/src/Compiler/Checking/NicePrint.fs b/src/Compiler/Checking/NicePrint.fs
@@ -1933,6 +1933,9 @@ module TastDefinitionPrinting =
         let props =
             GetImmediateIntrinsicPropInfosOfType (None, ad) g amap m ty
             |> List.filter (fun pinfo -> shouldShow pinfo.ArbitraryValRef)
+            // Filter out 'IsA' properties which are implied by the union cases since they don't need to be displayed
+            // in any printed outputs
+            |> List.filter (fun prop -> not prop.IsUnionCaseTester)
 
         let events = 
             infoReader.GetEventInfosOfType(None, ad, m, ty)
@@ -1960,6 +1963,7 @@ module TastDefinitionPrinting =
                 IsMethInfoAccessible amap m ad minfo &&
                 // Discard method impls such as System.IConvertible.ToBoolean
                 not (minfo.IsILMethod && minfo.DisplayName.Contains(".")) &&
+                not minfo.IsUnionCaseTester &&
                 not (minfo.DisplayName.Split('.') |> Array.exists isDiscard))
 
         let ilFields =
@@ -2017,7 +2021,7 @@ module TastDefinitionPrinting =
         let instanceValLs =
             instanceVals
             |> List.map (fun f -> layoutRecdField (fun l -> WordL.keywordVal ^^ l) true denv infoReader tcref f)
-    
+
         let propLs =
             props
             |> List.collect (fun x ->

diff --git a/src/Compiler/Checking/PostInferenceChecks.fs b/src/Compiler/Checking/PostInferenceChecks.fs
@@ -2178,8 +2178,8 @@ let CheckModuleBinding cenv env (TBind(v, e, _) as bind) =
 
                 // Default augmentation contains the nasty 'Is<UnionCase>' etc.
                 let prefix = "Is"
-                if nm.StartsWithOrdinal prefix && hasDefaultAugmentation then
-                    match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with
+                if not v.IsImplied && nm.StartsWithOrdinal prefix && hasDefaultAugmentation then
+                    match tcref.GetUnionCaseByName(nm[prefix.Length ..]) with 
                     | Some uc -> error(NameClash(nm, kind, v.DisplayName, v.Range, FSComp.SR.chkUnionCaseDefaultAugmentation(), uc.DisplayName, uc.Range))
                     | None -> ()
 

diff --git a/src/Compiler/Checking/infos.fs b/src/Compiler/Checking/infos.fs
@@ -808,6 +808,15 @@ type MethInfo =
         | ProvidedMeth(_, mi, _, m) -> [mi.PUntaint((fun mi -> mi.GetParameters().Length), m)] // Why is this a list? Answer: because the method might be curried
 #endif
 
+    /// Indicates if the property is a IsABC union case tester implied by a union case definition
+    member x.IsUnionCaseTester =
+        let tcref = x.ApparentEnclosingTyconRef
+        tcref.IsUnionTycon &&
+        x.LogicalName.StartsWith("get_Is") &&
+        match x.ArbitraryValRef with 
+        | Some v -> v.IsImplied
+        | None -> false
+
     member x.IsCurried = x.NumArgs.Length > 1
 
     /// Does the method appear to the user as an instance method?
@@ -2016,6 +2025,11 @@ type PropInfo =
 #endif
         | _ -> false
 
+    /// Indicates if the property is a IsABC union case tester implied by a union case definition
+    member x.IsUnionCaseTester =
+        x.HasGetter &&
+        x.GetterMethod.IsUnionCaseTester
+
     /// Calculates a hash code of property info. Must be compatible with ItemsAreEffectivelyEqual relation.
     member pi.ComputeHashCode() =
         match pi with

diff --git a/src/Compiler/Checking/infos.fsi b/src/Compiler/Checking/infos.fsi
@@ -420,6 +420,9 @@ type MethInfo =
     /// Indicates if this is an IL method.
     member IsILMethod: bool
 
+    /// Indicates if the method is a get_IsABC union case tester implied by a union case definition
+    member IsUnionCaseTester: bool
+
     /// Does the method appear to the user as an instance method?
     member IsInstance: bool
 
@@ -821,6 +824,9 @@ type PropInfo =
 
     member ImplementedSlotSignatures: SlotSig list
 
+    /// Indicates if the property is a IsABC union case tester implied by a union case definition
+    member IsUnionCaseTester: bool
+
     /// Indicates if this property is marked 'override' and thus definitely overrides another property.
     member IsDefiniteFSharpOverride: bool
 

diff --git a/src/Compiler/CodeGen/EraseUnions.fs b/src/Compiler/CodeGen/EraseUnions.fs
@@ -8,6 +8,7 @@ open FSharp.Compiler.IlxGenSupport
 open System.Collections.Generic
 open System.Reflection
 open Internal.Utilities.Library
+open FSharp.Compiler.Features
 open FSharp.Compiler.TcGlobals
 open FSharp.Compiler.AbstractIL.IL
 open FSharp.Compiler.AbstractIL.ILX.Types
@@ -843,7 +844,12 @@ let convAlternativeDef
         | SpecialFSharpListHelpers ->
 
             let baseTesterMeths, baseTesterProps =
-                if cud.UnionCases.Length <= 1 then
+                if
+                    g.langVersion.SupportsFeature LanguageFeature.UnionIsPropertiesVisible
+                    && cud.HasHelpers = AllHelpers
+                then
+                    [], []
+                elif cud.UnionCases.Length <= 1 then
                     [], []
                 elif repr.RepresentOneAlternativeAsNull info then
                     [], []

diff --git a/src/Compiler/CodeGen/IlxGen.fs b/src/Compiler/CodeGen/IlxGen.fs
@@ -2140,15 +2140,15 @@ type AnonTypeGenerationTable() =
                     (mkAppTy g.system_GenericIEquatable_tcref [ ty ], true, m)
                 ]
 
-            let vspec1, vspec2 = AugmentWithHashCompare.MakeValsForEqualsAugmentation g tcref
+            let vspec1, vspec2 = AugmentTypeDefinitions.MakeValsForEqualsAugmentation g tcref
 
             let evspec1, evspec2, evspec3 =
-                AugmentWithHashCompare.MakeValsForEqualityWithComparerAugmentation g tcref
+                AugmentTypeDefinitions.MakeValsForEqualityWithComparerAugmentation g tcref
 
-            let cvspec1, cvspec2 = AugmentWithHashCompare.MakeValsForCompareAugmentation g tcref
+            let cvspec1, cvspec2 = AugmentTypeDefinitions.MakeValsForCompareAugmentation g tcref
 
             let cvspec3 =
-                AugmentWithHashCompare.MakeValsForCompareWithComparerAugmentation g tcref
+                AugmentTypeDefinitions.MakeValsForCompareWithComparerAugmentation g tcref
 
             tcaug.SetCompare(mkLocalValRef cvspec1, mkLocalValRef cvspec2)
             tcaug.SetCompareWith(mkLocalValRef cvspec3)
@@ -2191,10 +2191,10 @@ type AnonTypeGenerationTable() =
 
             let extraBindings =
                 [|
-                    yield! AugmentWithHashCompare.MakeBindingsForCompareAugmentation g tycon
-                    yield! AugmentWithHashCompare.MakeBindingsForCompareWithComparerAugmentation g tycon
-                    yield! AugmentWithHashCompare.MakeBindingsForEqualityWithComparerAugmentation g tycon
-                    yield! AugmentWithHashCompare.MakeBindingsForEqualsAugmentation g tycon
+                    yield! AugmentTypeDefinitions.MakeBindingsForCompareAugmentation g tycon
+                    yield! AugmentTypeDefinitions.MakeBindingsForCompareWithComparerAugmentation g tycon
+                    yield! AugmentTypeDefinitions.MakeBindingsForEqualityWithComparerAugmentation g tycon
+                    yield! AugmentTypeDefinitions.MakeBindingsForEqualsAugmentation g tycon
                 |]
 
             let optimizedExtraBindings =

diff --git a/src/Compiler/FSComp.txt b/src/Compiler/FSComp.txt
@@ -1591,6 +1591,7 @@ featurePreferStringGetPinnableReference,"prefer String.GetPinnableReference in f
 featurePreferExtensionMethodOverPlainProperty,"prefer extension method over plain property"
 featureWarningIndexedPropertiesGetSetSameType,"Indexed properties getter and setter must have the same type"
 featureChkTailCallAttrOnNonRec,"Raises warnings if the 'TailCall' attribute is used on non-recursive functions."
+featureUnionIsPropertiesVisible,"Union case test properties"
 3354,tcNotAFunctionButIndexerNamedIndexingNotYetEnabled,"This value supports indexing, e.g. '%s.[index]'. The syntax '%s[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation."
 3354,tcNotAFunctionButIndexerIndexingNotYetEnabled,"This expression supports indexing, e.g. 'expr.[index]'. The syntax 'expr[index]' requires /langversion:preview. See https://aka.ms/fsharp-index-notation."
 3355,tcNotAnIndexerNamedIndexingNotYetEnabled,"The value '%s' is not a function and does not support index notation."

diff --git a/src/Compiler/Facilities/LanguageFeatures.fs b/src/Compiler/Facilities/LanguageFeatures.fs
@@ -43,6 +43,7 @@ type LanguageFeature =
     | IndexerNotationWithoutDot
     | RefCellNotationInformationals
     | UseBindingValueDiscard
+    | UnionIsPropertiesVisible
     | NonVariablePatternsToRightOfAsPatterns
     | AttributesToRightOfModuleKeyword
     | MLCompatRevisions
@@ -193,6 +194,7 @@ type LanguageVersion(versionText) =
                 LanguageFeature.PreferExtensionMethodOverPlainProperty, previewVersion
                 LanguageFeature.WarningIndexedPropertiesGetSetSameType, previewVersion
                 LanguageFeature.WarningWhenTailCallAttrOnNonRec, previewVersion
+                LanguageFeature.UnionIsPropertiesVisible, previewVersion
             ]
 
     static let defaultLanguageVersion = LanguageVersion("default")
@@ -289,6 +291,7 @@ type LanguageVersion(versionText) =
         | LanguageFeature.IndexerNotationWithoutDot -> FSComp.SR.featureIndexerNotationWithoutDot ()
         | LanguageFeature.RefCellNotationInformationals -> FSComp.SR.featureRefCellNotationInformationals ()
         | LanguageFeature.UseBindingValueDiscard -> FSComp.SR.featureDiscardUseValue ()
+        | LanguageFeature.UnionIsPropertiesVisible -> FSComp.SR.featureUnionIsPropertiesVisible ()
         | LanguageFeature.NonVariablePatternsToRightOfAsPatterns -> FSComp.SR.featureNonVariablePatternsToRightOfAsPatterns ()
         | LanguageFeature.AttributesToRightOfModuleKeyword -> FSComp.SR.featureAttributesToRightOfModuleKeyword ()
         | LanguageFeature.MLCompatRevisions -> FSComp.SR.featureMLCompatRevisions ()

diff --git a/src/Compiler/Facilities/LanguageFeatures.fsi b/src/Compiler/Facilities/LanguageFeatures.fsi
@@ -33,6 +33,7 @@ type LanguageFeature =
     | IndexerNotationWithoutDot
     | RefCellNotationInformationals
     | UseBindingValueDiscard
+    | UnionIsPropertiesVisible
     | NonVariablePatternsToRightOfAsPatterns
     | AttributesToRightOfModuleKeyword
     | MLCompatRevisions

diff --git a/src/Compiler/Symbols/Symbols.fs b/src/Compiler/Symbols/Symbols.fs
@@ -1766,6 +1766,13 @@ type FSharpMemberOrFunctionOrValue(cenv, d:FSharpMemberOrValData, item) =
         | P p -> mkMethSym p.SetterMethod
         | E _ | M _ | C _ | V _ -> invalidOp "the value or member doesn't have an associated setter method" 
 
+    member _.IsUnionCaseTester =
+        checkIsResolved()
+        match d with
+        | P p -> p.IsUnionCaseTester
+        | M m -> m.IsUnionCaseTester
+        | E _ | C _ | V _ -> invalidOp "the value or member is not a property"
+
     member _.EventAddMethod =
         checkIsResolved()
         match d with 

diff --git a/src/Compiler/Symbols/Symbols.fsi b/src/Compiler/Symbols/Symbols.fsi
@@ -835,6 +835,9 @@ type FSharpMemberOrFunctionOrValue =
     /// Get an associated setter method of the property
     member SetterMethod: FSharpMemberOrFunctionOrValue
 
+    /// Indicates if the property or getter method is part of a IsABC union case tester implied by a union case definition
+    member IsUnionCaseTester: bool
+
     /// Get an associated add method of an event
     member EventAddMethod: FSharpMemberOrFunctionOrValue