WIP: lint tests

src/GitS-Tests.package/GSLintTest.class/instance/defaultTimeout.st

@@ -0,0 +1,3 @@
+running - timeout
+defaultTimeout
+	^ 60000

src/GitS-Tests.package/GSLintTest.class/instance/expectedUnsentGitAssetLoaderMethods.st

@@ -0,0 +1,5 @@
+expected-unsent
+expectedUnsentGitAssetLoaderMethods
+	^ (#(loadAnimatedImageMorph: loadAnimation: loadImageMorph: loadByteArray: loadString: assetPaths)
+		collect: [:selector | GitAssetLoader>>selector])
+		copyWith: GitAssetLoader class>>#for:basePath:

src/GitS-Tests.package/GSLintTest.class/instance/expectedUnsentMethods.st

@@ -0,0 +1,6 @@
+expected-unsent
+expectedUnsentMethods
+	^
+		self expectedUnsentGitAssetLoaderMethods,
+		self expectedUnsentMethodsForFutureUse,
+		self expectedUnsentMethodsThatHaveHiddenSends

src/GitS-Tests.package/GSLintTest.class/instance/expectedUnsentMethodsForFutureUse.st

@@ -0,0 +1,7 @@
+expected-unsent
+expectedUnsentMethodsForFutureUse
+	^ {
+		GSTonelMapper>>#writeTimestamps:.
+		GSRebaseOperationMerge>>#messageCommit.
+		GSRebaseOperationMerge>>#oneLineMessage.
+	}

src/GitS-Tests.package/GSLintTest.class/instance/expectedUnsentMethodsThatHaveHiddenSends.st

@@ -0,0 +1,5 @@
+expected-unsent
+expectedUnsentMethodsThatHaveHiddenSends
+	^ {
+		GSPreferences class>>#showBase:. "asSimpleSetter used in Preferences class>>addPragmaPreference:"
+	}

src/GitS-Tests.package/GSLintTest.class/instance/findAbstractMethodsInConcreteClasses.st

@@ -0,0 +1,21 @@
+finding
+findAbstractMethodsInConcreteClasses
+	^ CurrentReadOnlySourceFiles cacheDuring: [
+		(Array streamContents: [:stream | | methodsWithClasses |
+			methodsWithClasses := IdentityDictionary new.
+			(self packageInfo classesAndMetaClasses
+				reject: [:each | each theNonMetaClass isAbstract])
+				do: [:class |
+					class allSelectors do: [:selector | | compiledMethod |
+						compiledMethod := class lookupSelector: selector.
+						(methodsWithClasses
+							at: compiledMethod
+							ifAbsentPut: [OrderedCollection new])
+								add: class]].
+			(methodsWithClasses
+				associationsSelect: [:each |
+					(self ignoredAbstractMethods includes: each key) not])
+				 keysAndValuesDo: [:compiledMethod :classes |
+					(self isAbstractMethod: compiledMethod)
+						ifTrue: [stream nextPut: compiledMethod -> classes]]])
+			sorted: #name ascending]

src/GitS-Tests.package/GSLintTest.class/instance/findUnimplementedAndUnsentMethods.st

@@ -0,0 +1,21 @@
+finding
+findUnimplementedAndUnsentMethods
+	| implemented sent packageImplemented packageSent unimplemented unsent |
+	implemented := Set new.
+	implemented addAll: Smalltalk globals keys.
+	sent := Set new.
+	packageImplemented := OrderedCollection new.
+	packageSent := OrderedCollection new.
+	CurrentReadOnlySourceFiles cacheDuring: [
+		(SystemNavigation default allBehaviors gather: [:each | each methodDict values]) contents
+			do: [:compiledMethod | | included |
+				included := self packageInfo includesMethodReference: compiledMethod methodReference.
+				implemented add: compiledMethod selector.
+				included ifTrue: [packageImplemented add: compiledMethod].
+				self sendsOf: compiledMethod do: [:selector |
+					sent add: selector.
+					included ifTrue: [packageSent add: compiledMethod -> selector]]]
+			displayingProgress: [:each | 'Analyzing ', each methodReference]].
+	unimplemented := packageSent reject: [:each | implemented includes: each value].
+	unsent := (packageImplemented reject: [:each | sent includes: each selector]).
+	^ Dictionary newFrom: {'unimplemented' -> unimplemented. 'unsent' -> unsent}

src/GitS-Tests.package/GSLintTest.class/instance/ignoredAbstractMethods.st

@@ -0,0 +1,7 @@
+ignored-abstract-methods
+ignoredAbstractMethods
+	^ {
+		TextAttribute>>#closeHtmlOn:.
+		TextAttribute>>#openHtmlOn:.
+		Object>>#writeCypressJsonOn:forHtml:indent:.
+	}

src/GitS-Tests.package/GSLintTest.class/instance/ignoredSends.st

@@ -0,0 +1,8 @@
+ignored-sends
+ignoredSends
+	^
+		self ignoredSendsForCommitType,
+		self ignoredSendsForLegacyMetadataLoading,
+		self ignoredSendsForLegacyProjectImporting,
+		self ignoredSendsForTextDiffing,
+		self ignoredSendsForUnmappedPathDialogOptions

src/GitS-Tests.package/GSLintTest.class/instance/ignoredSendsForCommitType.st

@@ -0,0 +1,7 @@
+ignored-sends
+ignoredSendsForCommitType
+	^ {
+		#actionPick:message:windowTitlePrefix:revert:amend:alwaysOpenDialog:.
+		#mergeCommitIntoHead:mergeBase:message:windowTitle:alwaysOpenDialog:commitType:.
+		#openDialogToMergeCommitIntoHead:mergeBase:displayName:.
+	} gather: [:selector | #(commit merge amend) collect: [:symbol | GSBrowser>>selector -> symbol]]

src/GitS-Tests.package/GSLintTest.class/instance/ignoredSendsForLegacyMetadataLoading.st

@@ -0,0 +1,8 @@
+ignored-sends
+ignoredSendsForLegacyMetadataLoading
+	^ {
+		#legacySquotClassMappings -> #(SquotTrackedObjectMetadata).
+		#loadMapperFromLegacySquotContentsReference:fallbackSerializer: -> #(SquotTonelSerializer SquotCypressCodeSerializer).
+		#loadLegacySerializerNameFromSquotContentsReference: -> #(serializer).
+		#legacySquotClassName: -> #(GS Squot).
+	} gather: [:each | each value collect: [:symbol | GSMetadataMapper>>each key -> symbol]]

src/GitS-Tests.package/GSLintTest.class/instance/ignoredSendsForLegacyProjectImporting.st

@@ -0,0 +1,7 @@
+ignored-sends
+ignoredSendsForLegacyProjectImporting
+	^ {
+		#importLegacyGitStandaloneAssetLoaderInstances -> #(GitNamedAssetLoader assets).
+		#importLegacySquotWorkingCopyInstances -> #(SquotWorkingCopy registered).
+		#importLegacySqueakWorkingCopyInstances -> #(SqueakWorkingCopy).
+	} gather: [:each | each value collect: [:symbol | GSBaseWorkingCopy class>>each key -> symbol]]

src/GitS-Tests.package/GSLintTest.class/instance/ignoredSendsForTextDiffing.st

@@ -0,0 +1,4 @@
+ignored-sends
+ignoredSendsForTextDiffing
+	^ #(diffChunksFrom:to: diffFromLines:toLines:) gather: [:selector |
+		#(common different) collect: [:symbol | GSTextUtilities class>>selector -> symbol]]

src/GitS-Tests.package/GSLintTest.class/instance/ignoredSendsForUnmappedPathDialogOptions.st

@@ -0,0 +1,7 @@
+ignored-sends
+ignoredSendsForUnmappedPathDialogOptions
+	^ {
+		GSBaseWorkingCopy>>#requestOptionForUnmappedPath:mapper:additionalOptions:.
+		GSBaseWorkingCopy>>#getUnmappedPathFrom:withTitle:additionalOptions:optionIfMapped:.
+		GSAssetBrowser>>#importDirectory:.
+	} gather: [:compiledMethod | #(different overwrite skip ask) collect: [:symbol | compiledMethod -> symbol]]

src/GitS-Tests.package/GSLintTest.class/instance/isAbstractMethod..st

@@ -0,0 +1,5 @@
+testing
+isAbstractMethod: aCompiledMethod
+	self sendsOf: aCompiledMethod do: [:selector |
+		selector = #subclassResponsibility ifTrue: [^ true]].
+	^ false

src/GitS-Tests.package/GSLintTest.class/instance/isSend.in.enumerator..st

@@ -0,0 +1,10 @@
+testing
+isSend: aSymbol in: aCompiledMethod enumerator: aSendsEnumerator
+	| parent |
+	({self. self class} includes: aCompiledMethod methodClass) ifTrue: [^ false].
+	(self ignoredSends includes: aCompiledMethod -> aSymbol) ifTrue: [^ false].
+	parent := aSendsEnumerator parent ifNil: [^ true].
+	parent isMessageNode ifFalse: [^ true].
+	(parent arguments includes: aSendsEnumerator current) ifFalse: [^ true].
+	(self selectorsWhoseArgumentsToIgnore includes: parent selector key) ifTrue: [^ false].
+	^ true

src/GitS-Tests.package/GSLintTest.class/instance/packageInfo.st

@@ -0,0 +1,3 @@
+accessing
+packageInfo
+	^ PackageInfo named: 'GitS-Core'

src/GitS-Tests.package/GSLintTest.class/instance/selectorsWhoseArgumentsToIgnore.st

@@ -0,0 +1,3 @@
+ignored-sends
+selectorsWhoseArgumentsToIgnore
+	^ #(flag: = ~= changed: hResizing: horizontalResizing: vResizing: verticalResizing: listDirection:)

src/GitS-Tests.package/GSLintTest.class/instance/sendsOf.do..st

@@ -0,0 +1,12 @@
+finding
+sendsOf: aCompiledMethod do: aBlock
+	GSSendsEnumerator new
+		selectBlock: [:symbol :enumerator |
+			self
+				isSend: symbol
+				in: aCompiledMethod
+				enumerator: enumerator];
+		doBlock: aBlock;
+		visit: (Parser new
+				parse: aCompiledMethod getSource
+				class: aCompiledMethod methodClass).

src/GitS-Tests.package/GSLintTest.class/instance/testNoAbstractMethodsInConcreteClasses.st

@@ -0,0 +1,7 @@
+tests
+testNoAbstractMethodsInConcreteClasses
+	| found |
+	found := self findAbstractMethodsInConcreteClasses.
+	self
+		assert: found isEmpty
+		description: 'Found methods on non-abstract classes that call subclassResponsibility'.

src/GitS-Tests.package/GSLintTest.class/instance/testNoUnimplementedAndNoUnsentMethods.st

@@ -0,0 +1,10 @@
+tests
+testNoUnimplementedAndNoUnsentMethods
+	| found |
+	found := self findUnimplementedAndUnsentMethods.
+	self
+		assert: (found at: 'unimplemented') isEmpty
+		description: 'Found unimplemented selectors or references to non-existing globals'.
+	self
+		assert: (found at: 'unsent') asIdentitySet = self expectedUnsentMethods asIdentitySet
+		description: 'Found unsent methods'.

src/GitS-Tests.package/GSLintTest.class/methodProperties.json

@@ -0,0 +1,25 @@
+{
+	"class" : {
+		 },
+	"instance" : {
+		"defaultTimeout" : "mad 10/14/2024 00:00",
+		"expectedUnsentGitAssetLoaderMethods" : "mad 10/13/2024 23:47",
+		"expectedUnsentMethods" : "mad 10/14/2024 00:04",
+		"expectedUnsentMethodsForFutureUse" : "mad 10/14/2024 00:05",
+		"expectedUnsentMethodsThatHaveHiddenSends" : "mad 10/14/2024 00:10",
+		"findAbstractMethodsInConcreteClasses" : "mad 10/14/2024 00:05",
+		"findUnimplementedAndUnsentMethods" : "mad 10/14/2024 00:03",
+		"ignoredAbstractMethods" : "mad 10/14/2024 00:05",
+		"ignoredSends" : "mad 10/14/2024 00:07",
+		"ignoredSendsForCommitType" : "mad 10/14/2024 00:06",
+		"ignoredSendsForLegacyMetadataLoading" : "mad 10/14/2024 00:06",
+		"ignoredSendsForLegacyProjectImporting" : "mad 10/14/2024 00:06",
+		"ignoredSendsForTextDiffing" : "mad 10/14/2024 00:07",
+		"ignoredSendsForUnmappedPathDialogOptions" : "mad 10/14/2024 00:07",
+		"isAbstractMethod:" : "mad 10/13/2024 20:42",
+		"isSend:in:enumerator:" : "mad 10/14/2024 00:06",
+		"packageInfo" : "mad 10/13/2024 19:52",
+		"selectorsWhoseArgumentsToIgnore" : "mad 10/14/2024 00:08",
+		"sendsOf:do:" : "mad 10/13/2024 19:50",
+		"testNoAbstractMethodsInConcreteClasses" : "mad 10/13/2024 21:13",
+		"testNoUnimplementedAndNoUnsentMethods" : "mad 10/14/2024 00:04" } }

src/GitS-Tests.package/GSLintTest.class/properties.json

@@ -0,0 +1,14 @@
+{
+	"category" : "GitS-Tests",
+	"classinstvars" : [
+		 ],
+	"classvars" : [
+		 ],
+	"commentStamp" : "",
+	"instvars" : [
+		 ],
+	"name" : "GSLintTest",
+	"pools" : [
+		 ],
+	"super" : "TestCase",
+	"type" : "normal" }

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/ancestor..st

@@ -0,0 +1,3 @@
+accessing
+ancestor: aNumber
+	^ self ancestors atLast: aNumber ifAbsent: [nil]

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/ancestors..st

@@ -0,0 +1,3 @@
+accessing
+ancestors: aColletion
+	ancestors := aColletion

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/ancestors.st

@@ -0,0 +1,3 @@
+accessing
+ancestors
+	^ ancestors

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/current.st

@@ -0,0 +1,3 @@
+accessing
+current
+	^ self ancestor: 1

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/initialize.st

@@ -0,0 +1,4 @@
+initialize-release
+initialize
+	super initialize.
+	self ancestors: OrderedCollection new.

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/parent.st

@@ -0,0 +1,3 @@
+accessing
+parent
+	^ self ancestor: 2

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/pushAncestor.during..st

@@ -0,0 +1,4 @@
+visiting
+pushAncestor: aParseNode during: aBlock
+	self ancestors addLast: aParseNode.
+	aBlock ensure: [self ancestors removeLast].

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/root.st

@@ -0,0 +1,3 @@
+accessing
+root
+	^ self ancestors first

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visit..st

@@ -0,0 +1,3 @@
+visiting
+visit: aParseNode
+	self pushAncestor: aParseNode during: [aParseNode accept: self].

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitAll..st

@@ -0,0 +1,3 @@
+visiting
+visitAll: aCollection
+	aCollection do: [:each | self visit: each].

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitAssignmentNode..st

@@ -0,0 +1,6 @@
+visiting
+visitAssignmentNode: anAssignmentNode
+	"N.B.  since assigment happens after the value is evaluated the value is visited first."
+	self
+		visit: anAssignmentNode value;
+		visit: anAssignmentNode variable.

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitBlockNode..st

@@ -0,0 +1,3 @@
+visiting
+visitBlockNode: aBlockNode
+	self visitAll: aBlockNode statements.

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitBraceNode..st

@@ -0,0 +1,3 @@
+visiting
+visitBraceNode: aBraceNode
+	self visitAll: aBraceNode elements.

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitCascadeNode..st

@@ -0,0 +1,7 @@
+visiting
+visitCascadeNode: aCascadeNode
+	self visit: aCascadeNode receiver.
+	aCascadeNode messages do: [:message|
+		self
+			pushAncestor: message
+			during: [self visitMessageNodeInCascade: message]].

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitFutureNode..st

@@ -0,0 +1,5 @@
+visiting
+visitFutureNode: aFutureNode
+	self visit: aFutureNode receiver.
+	(aFutureNode originalSelector isKindOf: SelectorNode) ifTrue:
+		[self visit: aFutureNode originalSelector].

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitMessageNode..st

@@ -0,0 +1,6 @@
+visiting
+visitMessageNode: aMessageNode
+	self
+		visit: aMessageNode receiver;
+		visit: aMessageNode selector;
+		visitAll: aMessageNode argumentsInEvaluationOrder.

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitMessageNodeInCascade..st

@@ -0,0 +1,6 @@
+visiting
+visitMessageNodeInCascade: aMessageNode
+	"receiver is nil for cascades"
+	self
+		visit: aMessageNode selector;
+		visitAll: aMessageNode argumentsInEvaluationOrder.

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitMethodNode..st

@@ -0,0 +1,3 @@
+visiting
+visitMethodNode: aMethodNode
+	self visit: aMethodNode block.

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/instance/visitReturnNode..st

@@ -0,0 +1,3 @@
+visiting
+visitReturnNode: aReturnNode
+	self visit: aReturnNode expr.

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/methodProperties.json

@@ -0,0 +1,23 @@
+{
+	"class" : {
+		 },
+	"instance" : {
+		"ancestor:" : "mad 10/13/2024 16:02",
+		"ancestors" : "mad 10/13/2024 15:27",
+		"ancestors:" : "mad 10/13/2024 15:27",
+		"current" : "mad 10/13/2024 16:02",
+		"initialize" : "mad 10/13/2024 15:28",
+		"parent" : "mad 10/13/2024 16:02",
+		"pushAncestor:during:" : "mad 10/13/2024 15:28",
+		"root" : "mad 10/13/2024 16:08",
+		"visit:" : "mad 10/13/2024 15:28",
+		"visitAll:" : "mad 10/13/2024 15:19",
+		"visitAssignmentNode:" : "mad 10/13/2024 15:16",
+		"visitBlockNode:" : "mad 10/13/2024 15:17",
+		"visitBraceNode:" : "mad 10/13/2024 15:19",
+		"visitCascadeNode:" : "mad 10/13/2024 15:40",
+		"visitFutureNode:" : "mad 10/13/2024 15:40",
+		"visitMessageNode:" : "mad 10/13/2024 15:23",
+		"visitMessageNodeInCascade:" : "mad 10/13/2024 15:23",
+		"visitMethodNode:" : "mad 10/13/2024 15:23",
+		"visitReturnNode:" : "mad 10/13/2024 15:23" } }

src/GitS-Tests.package/GSParseNodeVisitorWithAncestors.class/properties.json

@@ -0,0 +1,14 @@
+{
+	"category" : "GitS-Tests",
+	"classinstvars" : [
+		 ],
+	"classvars" : [
+		 ],
+	"commentStamp" : "",
+	"instvars" : [
+		"ancestors" ],
+	"name" : "GSParseNodeVisitorWithAncestors",
+	"pools" : [
+		 ],
+	"super" : "ParseNodeVisitor",
+	"type" : "normal" }