File: Symbols\Source\SourceNamedTypeSymbol_GroupClass.vb
Web Access
Project: src\src\Compilers\VisualBasic\Portable\Microsoft.CodeAnalysis.VisualBasic.vbproj (Microsoft.CodeAnalysis.VisualBasic)
' Licensed to the .NET Foundation under one or more agreements.
' The .NET Foundation licenses this file to you under the MIT license.
' See the LICENSE file in the project root for more information.
 
Imports System.Collections.Immutable
Imports System.Runtime.InteropServices
Imports Microsoft.CodeAnalysis.PooledObjects
Imports Microsoft.CodeAnalysis.VisualBasic.Symbols
Imports Microsoft.CodeAnalysis.VisualBasic.Syntax
 
Namespace Microsoft.CodeAnalysis.VisualBasic.Symbols
 
    Partial Friend Class SourceNamedTypeSymbol
 
        Protected Overrides Sub AddGroupClassMembersIfNeeded(membersBuilder As MembersAndInitializersBuilder, diagnostics As BindingDiagnosticBag)
            ' For reference, see Bindable::IsMyGroupCollection and Bindable::CrackAttributesOnAllSymbolsInContainer in native code.
            If Me.TypeKind = TypeKind.Class AndAlso Not Me.IsGenericType Then
 
                Dim binder As Binder = Nothing
                Dim attributeSyntax As AttributeSyntax = Nothing
                Dim attributeData As VisualBasicAttributeData = GetMyGroupCollectionAttributeData(diagnostics, binder, attributeSyntax)
 
                If attributeData IsNot Nothing Then
                    ' Ok, this looks like a group class. Let's inspect the attribute data (Attribute::CrackArgBlob).
 
                    ' Attribute arguments are comma-separated lists.
                    Dim separatorComma = {","c}
                    Dim separatorDot = {"."c}
                    Dim baseTypeNames() As String = If(attributeData.GetConstructorArgument(Of String)(0, SpecialType.System_String), "").Split(separatorComma, StringSplitOptions.None)
                    Dim createMethods() As String = If(attributeData.GetConstructorArgument(Of String)(1, SpecialType.System_String), "").Split(separatorComma, StringSplitOptions.None)
                    Dim disposeMethods() As String = If(attributeData.GetConstructorArgument(Of String)(2, SpecialType.System_String), "").Split(separatorComma, StringSplitOptions.None)
 
                    ' DefaultInstanceAliases are respected only for attributes applied in MyTemplate.
                    Dim defaultInstances() As String
 
                    If attributeSyntax.SyntaxTree.IsMyTemplate Then
                        defaultInstances = If(attributeData.GetConstructorArgument(Of String)(3, Microsoft.CodeAnalysis.SpecialType.System_String), "").Split(separatorComma, StringSplitOptions.None)
                    Else
                        defaultInstances = Array.Empty(Of String)()
                    End If
 
                    ' Types matching each name in baseTypeNames will be grouped together in the builder below and groups will be separated by Nothing item.
                    ' See comment inside the loop about why there could be more than one.
                    Dim baseTypes As ArrayBuilder(Of NamedTypeSymbol) = ArrayBuilder(Of NamedTypeSymbol).GetInstance()
                    Dim haveBaseTypes As Boolean = False
 
                    For i As Integer = 0 To Math.Min(baseTypeNames.Length, createMethods.Length) - 1
                        baseTypeNames(i) = baseTypeNames(i).Trim()
                        createMethods(i) = createMethods(i).Trim()
 
                        If baseTypeNames(i).Length = 0 OrElse createMethods(i).Length = 0 Then
                            ' This might feel strange, but native compiler stops processing arguments
                            ' as soon as it encounters an empty base type name or create method name
                            Exit For
                        Else
                            If i < disposeMethods.Length Then
                                disposeMethods(i) = disposeMethods(i).Trim()
                            End If
 
                            If i < defaultInstances.Length Then
                                defaultInstances(i) = defaultInstances(i).Trim()
                            End If
 
                            ' See if we can locate the base class this group class is associated with. This might feel strange,
                            ' but native compiler does the match by fully qualified name without generic parameters, therefore we might 
                            ' find more than one base type from different assemblies or types with different arities, all are valid candidates.
                            FindGroupClassBaseTypes(baseTypeNames(i).Split(separatorDot, StringSplitOptions.None), DeclaringCompilation.GlobalNamespace, 0, baseTypes)
 
                            If Not haveBaseTypes AndAlso baseTypes.Count > 0 AndAlso baseTypes.Last() IsNot Nothing Then
                                haveBaseTypes = True
                            End If
                        End If
 
                        baseTypes.Add(Nothing)
                    Next
 
                    If haveBaseTypes Then
                        ' Now, iterate over all top level types declared in this module and pick those
                        ' inheriting from the bases we found (Bindable::ScanAndLoadMyGroupCollectionMembers). 
                        Dim collectionTypes = ArrayBuilder(Of KeyValuePair(Of NamedTypeSymbol, Integer)).GetInstance()
                        GetMyGroupCollectionTypes(Me.ContainingModule.GlobalNamespace, baseTypes, binder, collectionTypes)
 
                        If collectionTypes.Count > 0 Then
                            ' See Bindable::GenSyntheticMyGroupCollectionProperties
 
                            ' sort members to handle simple name clashes. Having all the classes with the same simple name
                            ' grouped together helps decide in one step if mangling is necessary.
                            ' It is only a gain of  O(n*n) -> O(n*log(n))
                            collectionTypes.Sort(GroupCollectionComparer.Singleton)
 
                            For i As Integer = 0 To collectionTypes.Count - 1
                                Dim current As KeyValuePair(Of NamedTypeSymbol, Integer) = collectionTypes(i)
 
                                ' members with the same simple name are grouped together.
                                ' if two adjacent members with the same simple name then use name mangling
                                Dim mangleNames As Boolean = (i > 0 AndAlso IdentifierComparison.Equals(current.Key.Name, collectionTypes(i - 1).Key.Name)) OrElse
                                                             (i < collectionTypes.Count - 1 AndAlso IdentifierComparison.Equals(current.Key.Name, collectionTypes(i + 1).Key.Name))
 
                                AddSyntheticMyGroupCollectionProperty(current.Key, mangleNames,
                                                                      createMethods(current.Value),
                                                                      If(current.Value < disposeMethods.Length,
                                                                         disposeMethods(current.Value),
                                                                         ""),
                                                                      If(current.Value < defaultInstances.Length,
                                                                         defaultInstances(current.Value),
                                                                         ""),
                                                                      membersBuilder,
                                                                      binder,
                                                                      attributeSyntax,
                                                                      diagnostics)
                            Next
                        End If
 
                        collectionTypes.Free()
                    End If
 
                    baseTypes.Free()
                End If
            End If
        End Sub
 
        Private Function GetMyGroupCollectionAttributeData(diagnostics As BindingDiagnosticBag, <Out> ByRef binder As Binder, <Out> ByRef attributeSyntax As AttributeSyntax) As VisualBasicAttributeData
 
            ' Calling GetAttributes() here is likely to get us in a cycle. Also, we want this function to be 
            ' as cheap as possible, it is called for every class and we don't want to bind all attributes
            ' attached to the declaration (even when it doesn't cause a cycle) before we able to create symbol's
            ' members. So, we will have to manually bind only those attributes that potentially could be 
            ' MyGroupCollectionAttribute, by examining syntax ourselves.
            Dim attributeLists As ImmutableArray(Of SyntaxList(Of AttributeListSyntax)) = GetAttributeDeclarations()
            Dim attributeData As VisualBasicAttributeData = Nothing
 
            For Each list As SyntaxList(Of AttributeListSyntax) In attributeLists
                If list.Any() Then
                    binder = GetAttributeBinder(list, ContainingSourceModule)
                    Dim quickChecker As QuickAttributeChecker = binder.QuickAttributeChecker
 
                    For Each attrList In list
                        For Each attr In attrList.Attributes
                            If (quickChecker.CheckAttribute(attr) And QuickAttributes.MyGroupCollection) <> 0 Then
                                ' This attribute syntax might be an application of MyGroupCollectionAttribute.
                                ' Let's bind it.
                                Dim attributeType As NamedTypeSymbol = Binder.BindAttributeType(binder, attr, Me, BindingDiagnosticBag.Discarded)
                                If Not attributeType.IsErrorType() Then
                                    If VisualBasicAttributeData.IsTargetEarlyAttribute(attributeType, attr, AttributeDescription.MyGroupCollectionAttribute) Then
                                        ' Calling GetAttribute can still get us into cycle if MyGroupCollectionAttribute is applied to itself.
                                        If attributeType Is Me Then
                                            binder.ReportDiagnostic(diagnostics, attr, ERRID.ERR_MyGroupCollectionAttributeCycle)
                                            Debug.Assert(attributeData Is Nothing)
                                            GoTo DoneWithBindingAttributes
                                        End If
 
                                        ' Or if any argument expression refers to a member of this type. Therefore, as a simple solution,
                                        ' we will allow only literals as the arguments.
                                        For Each argumentSyntax As ArgumentSyntax In attr.ArgumentList.Arguments
                                            Dim expression As ExpressionSyntax
 
                                            Select Case argumentSyntax.Kind
                                                Case SyntaxKind.SimpleArgument
                                                    expression = DirectCast(argumentSyntax, SimpleArgumentSyntax).Expression
 
                                                Case SyntaxKind.OmittedArgument
                                                    expression = Nothing
 
                                                Case Else
                                                    Throw ExceptionUtilities.UnexpectedValue(argumentSyntax.Kind)
                                            End Select
 
                                            If expression IsNot Nothing AndAlso
                                               Not TypeOf expression Is LiteralExpressionSyntax Then
                                                binder.ReportDiagnostic(diagnostics, expression, ERRID.ERR_LiteralExpected)
                                                attributeData = Nothing
                                                GoTo DoneWithBindingAttributes
                                            End If
                                        Next
 
                                        Dim generatedDiagnostics As Boolean = False
                                        Dim data As VisualBasicAttributeData = (New EarlyWellKnownAttributeBinder(Me, binder)).GetAttribute(attr, attributeType, generatedDiagnostics)
                                        If Not data.HasErrors AndAlso Not generatedDiagnostics AndAlso
                                           data.IsTargetAttribute(AttributeDescription.MyGroupCollectionAttribute) Then
                                            ' Looks like we've found MyGroupCollectionAttribute
                                            If attributeData IsNot Nothing Then
                                                ' Ambiguity, the attribute cannot be applied multiple times. Let's ignore all of them,
                                                ' an error about multiple applications will be reported later, when all attributes are 
                                                ' bound and validated.
                                                attributeData = Nothing
                                                GoTo DoneWithBindingAttributes
                                            End If
 
                                            attributeData = data
                                            attributeSyntax = attr
                                        End If
                                    End If
                                End If
                            End If
                        Next
                    Next
                End If
            Next
 
DoneWithBindingAttributes:
            If attributeData Is Nothing Then
                binder = Nothing
                attributeSyntax = Nothing
            End If
 
            Return attributeData
        End Function
 
        Private Shared Sub FindGroupClassBaseTypes(nameParts() As String, current As NamespaceOrTypeSymbol, nextPart As Integer, candidates As ArrayBuilder(Of NamedTypeSymbol))
            ' Bindable::FindBaseInMyGroupCollection
 
            If nextPart = nameParts.Length Then
                If current.Kind = SymbolKind.NamedType Then
                    Dim named = DirectCast(current, NamedTypeSymbol)
 
                    If named.TypeKind = TypeKind.Class AndAlso Not named.IsNotInheritable Then
                        candidates.Add(named)
                    End If
                End If
 
                Return
            End If
 
            Dim name As String = nameParts(nextPart)
            nextPart += 1
            For Each member As Symbol In current.GetMembers(name)
                Select Case member.Kind
                    Case SymbolKind.Namespace, SymbolKind.NamedType
                        FindGroupClassBaseTypes(nameParts, DirectCast(member, NamespaceOrTypeSymbol), nextPart, candidates)
                End Select
            Next
        End Sub
 
        Private Shared Sub GetMyGroupCollectionTypes(
            ns As NamespaceSymbol,
            baseTypes As ArrayBuilder(Of NamedTypeSymbol),
            binder As Binder,
            collectionTypes As ArrayBuilder(Of KeyValuePair(Of NamedTypeSymbol, Integer))
        )
            For Each member As Symbol In ns.GetMembersUnordered()
                Select Case member.Kind
                    Case SymbolKind.NamedType
                        Dim named = TryCast(member, SourceNamedTypeSymbol)
 
                        ' See Bindable::ScanAndLoadMyGroupCollectionMembers, Bindable::CanBeMyGroupCollectionMember
                        ' CONSIDER: The IsAccessible check is probably redundant because top level types are always accessible within the same module.
                        '           We can remove it if it becomes a perf issue.
                        If named IsNot Nothing AndAlso
                           Not named.IsImplicitlyDeclared AndAlso
                           named.TypeKind = TypeKind.Class AndAlso
                           Not named.IsGenericType AndAlso
                           Not named.IsMustInherit AndAlso
                           binder.IsAccessible(named, useSiteInfo:=CompoundUseSiteInfo(Of AssemblySymbol).Discarded) Then
                            Dim matchingItem As Integer = FindBaseInMyGroupCollection(named, baseTypes)
 
                            If matchingItem >= 0 AndAlso
                               MyGroupCollectionCandidateHasPublicParameterlessConstructor(named) Then
                                collectionTypes.Add(New KeyValuePair(Of NamedTypeSymbol, Integer)(named, matchingItem))
                            End If
                        End If
 
                    Case SymbolKind.Namespace
                        GetMyGroupCollectionTypes(DirectCast(member, NamespaceSymbol), baseTypes, binder, collectionTypes)
                End Select
            Next
        End Sub
 
        Private Shared Function FindBaseInMyGroupCollection(classType As NamedTypeSymbol, bases As ArrayBuilder(Of NamedTypeSymbol)) As Integer
            ' See Bindable::FindBaseInMyGroupCollection
            ' Names in the MyGroupCollectionAttribute are matched from left to right to bases from most derived to the least derived.
            classType = classType.BaseTypeNoUseSiteDiagnostics
 
            While classType IsNot Nothing AndAlso Not classType.IsObjectType()
                Dim result As Integer = 0
                For Each candidate As NamedTypeSymbol In bases
                    If candidate Is Nothing Then
                        ' This means that we are switching to the next item in the comma-separated list of base type names.
                        result += 1
                    ElseIf classType.OriginalDefinition Is candidate Then
                        Return result
                    End If
                Next
 
                classType = classType.BaseTypeNoUseSiteDiagnostics
            End While
 
            Return -1 ' Haven't found a match.
        End Function
 
        Private Shared Function MyGroupCollectionCandidateHasPublicParameterlessConstructor(candidate As SourceNamedTypeSymbol) As Boolean
            ' Simply calling HasPublicParameterlessConstructor might get us in a cycle.
            Debug.Assert(candidate.TypeKind = TypeKind.Class)
            If candidate.MembersHaveBeenCreated Then
                Return HasPublicParameterlessConstructor(candidate) = ConstructorConstraintError.None
            Else
                Return candidate.InferFromSyntaxIfClassWillHavePublicParameterlessConstructor()
            End If
        End Function
 
#If DEBUG Then
        Protected Overrides Sub VerifyMembers()
            If Me.TypeKind = TypeKind.Class Then
                Debug.Assert(MembersHaveBeenCreated)
                Dim constructorConstraintError As ConstructorConstraintError = HasPublicParameterlessConstructor(Me)
                If InferFromSyntaxIfClassWillHavePublicParameterlessConstructor() Then
                    Debug.Assert(constructorConstraintError = ConstructorConstraintError.None OrElse constructorConstraintError = ConstructorConstraintError.HasRequiredMembers)
                Else
                    Debug.Assert(constructorConstraintError = ConstructorConstraintError.NoPublicParameterlessConstructor)
                End If
            End If
        End Sub
#End If
 
        Friend Function InferFromSyntaxIfClassWillHavePublicParameterlessConstructor() As Boolean
            Debug.Assert(Me.TypeKind = TypeKind.Class)
            Dim diagnostics = DiagnosticBag.GetInstance()
            Dim haveInstanceConstructor As Boolean = False
 
            For Each syntaxRef In SyntaxReferences
                Dim node = syntaxRef.GetSyntax()
 
                ' Set up a binder for this part of the type.
                Dim binder As Binder = BinderBuilder.CreateBinderForType(ContainingSourceModule, syntaxRef.SyntaxTree, Me)
 
                Dim typeBlock = DirectCast(node, TypeBlockSyntax)
                For Each memberSyntax In typeBlock.Members
                    Dim constructorSyntax As SubNewStatementSyntax
 
                    Select Case memberSyntax.Kind
                        Case SyntaxKind.ConstructorBlock
                            constructorSyntax = DirectCast(memberSyntax, ConstructorBlockSyntax).SubNewStatement
                        Case SyntaxKind.SubNewStatement
                            constructorSyntax = DirectCast(memberSyntax, SubNewStatementSyntax)
                        Case Else
                            constructorSyntax = Nothing
                    End Select
 
                    If constructorSyntax IsNot Nothing Then
                        Dim modifiers As SourceMemberFlags = SourceMethodSymbol.DecodeConstructorModifiers(constructorSyntax.Modifiers, Me, binder, diagnostics).AllFlags
 
                        If (modifiers And SourceMemberFlags.Shared) = 0 Then
                            If constructorSyntax.ParameterList Is Nothing OrElse constructorSyntax.ParameterList.Parameters.Count = 0 Then
                                diagnostics.Free()
                                Return (modifiers And SourceMemberFlags.AccessibilityMask) = SourceMemberFlags.AccessibilityPublic
                            End If
 
                            haveInstanceConstructor = True
                        End If
                    End If
                Next
            Next
 
            diagnostics.Free()
            Return Not haveInstanceConstructor AndAlso Not Me.IsMustInherit
        End Function
 
        ''' <summary>
        ''' Used to sort types - members of group collection.
        ''' </summary>
        Private Class GroupCollectionComparer
            Implements IComparer(Of KeyValuePair(Of NamedTypeSymbol, Integer))
 
            Public Shared ReadOnly Singleton As New GroupCollectionComparer
 
            Private Sub New()
            End Sub
 
            Public Function Compare(x As KeyValuePair(Of NamedTypeSymbol, Integer), y As KeyValuePair(Of NamedTypeSymbol, Integer)) As Integer Implements IComparer(Of KeyValuePair(Of NamedTypeSymbol, Integer)).Compare
                Return IdentifierComparison.Compare(x.Key.Name, y.Key.Name)
            End Function
        End Class
 
        Private Sub AddSyntheticMyGroupCollectionProperty(
            targetType As NamedTypeSymbol,
            mangleNames As Boolean,
            createMethod As String,
            disposeMethod As String,
            defaultInstanceAlias As String,
            membersBuilder As MembersAndInitializersBuilder,
            binder As Binder,
            attributeSyntax As AttributeSyntax,
            diagnostics As BindingDiagnosticBag
        )
            Dim propertyName As String
 
            If mangleNames Then
                propertyName = targetType.ToDisplayString()
                propertyName = propertyName.Replace("."c, "_"c)
            Else
                propertyName = targetType.Name
            End If
 
            Dim fieldName As String = "m_" & propertyName
 
            ' For now let reject any clash. The new member is a synthetic property and no overloads or other members with the same name should
            ' be allowed
            Dim conflictsWith As Symbol = Nothing
            Dim nestedTypes = GetTypeMembersDictionary()
            Dim isWinMd = Me.IsCompilationOutputWinMdObj()
 
            If ConflictsWithExistingMemberOrType(propertyName, membersBuilder, nestedTypes, conflictsWith) OrElse
               ConflictsWithExistingMemberOrType(binder.GetAccessorName(propertyName, MethodKind.PropertyGet, False), membersBuilder, nestedTypes, conflictsWith) OrElse
               (disposeMethod.Length > 0 AndAlso ConflictsWithExistingMemberOrType(binder.GetAccessorName(propertyName, MethodKind.PropertySet, isWinMd), membersBuilder, nestedTypes, conflictsWith)) OrElse
               ConflictsWithExistingMemberOrType(fieldName, membersBuilder, nestedTypes, conflictsWith) Then
                binder.ReportDiagnostic(diagnostics, attributeSyntax, ERRID.ERR_PropertyNameConflictInMyCollection, conflictsWith, targetType)
                Return
            End If
 
            Dim prop As New SynthesizedMyGroupCollectionPropertySymbol(Me, attributeSyntax, propertyName, fieldName, targetType, createMethod, disposeMethod, defaultInstanceAlias)
 
            AddMember(prop.AssociatedField, binder, membersBuilder, omitDiagnostics:=True)
            AddMember(prop, binder, membersBuilder, omitDiagnostics:=True)
            AddMember(prop.GetMethod, binder, membersBuilder, omitDiagnostics:=True)
 
            If prop.SetMethod IsNot Nothing Then
                AddMember(prop.SetMethod, binder, membersBuilder, omitDiagnostics:=True)
            End If
        End Sub
 
        Private Shared Function ConflictsWithExistingMemberOrType(
            name As String,
            membersBuilder As MembersAndInitializersBuilder,
            nestedTypes As Dictionary(Of String, ImmutableArray(Of NamedTypeSymbol)),
            <Out> ByRef conflictsWith As Symbol
        ) As Boolean
            Dim members As ArrayBuilder(Of Symbol) = Nothing
            Dim types As ImmutableArray(Of NamedTypeSymbol) = Nothing
 
            If membersBuilder.Members.TryGetValue(name, members) Then
                conflictsWith = members(0)
 
            ElseIf nestedTypes.TryGetValue(name, types) Then
                conflictsWith = types(0)
 
            Else
                conflictsWith = Nothing
            End If
 
            Return conflictsWith IsNot Nothing
        End Function
 
    End Class
 
End Namespace