diff --git a/src/BaselineOfMCP/BaselineOfMCP.class.st b/src/BaselineOfMCP/BaselineOfMCP.class.st index 5358615..508d946 100644 --- a/src/BaselineOfMCP/BaselineOfMCP.class.st +++ b/src/BaselineOfMCP/BaselineOfMCP.class.st @@ -19,17 +19,17 @@ BaselineOfMCP >> defineDependencies: spec [ spec baseline: 'PharoCompatibility' with: [ - spec - repository: 'github://Evref-BL/PharoCompatibility:main/src'; - loads: #( 'Pharo13Surface' ) ]; + spec + repository: 'github://Evref-BL/PharoCompatibility:main/src'; + loads: #( 'Pharo13Surface' ) ]; baseline: 'JRPC' with: [ - spec - repository: 'github://juliendelplanque/JRPC:v3.2.1/src'; - loads: #( 'Deployment' ) ]. + spec + repository: 'github://juliendelplanque/JRPC:v3.2.1/src'; + loads: #( 'Deployment' ) ]. spec baseline: 'TinyLogger' with: [ - spec - repository: 'github://jecisc/TinyLogger:v1.x.x/src'; - loads: #( 'Core' ) ] + spec + repository: 'github://jecisc/TinyLogger:v1.x.x/src'; + loads: #( 'Core' ) ] ] { #category : 'baselines' } diff --git a/src/MCP-Spec-Tests/MCPMonitoringStateTest.class.st b/src/MCP-Spec-Tests/MCPMonitoringStateTest.class.st index 912e11d..f7cdcda 100644 --- a/src/MCP-Spec-Tests/MCPMonitoringStateTest.class.st +++ b/src/MCP-Spec-Tests/MCPMonitoringStateTest.class.st @@ -150,12 +150,12 @@ MCPMonitoringStateTest >> testOutlierExplanationUsesPriorAverage [ stats := MCPToolCallStats forToolNamed: 'slow-tool'. start := DateAndTime now. 1 to: 3 do: [ :index | - record := MCPToolCallRecord - id: index - toolName: 'slow-tool' - startedAt: start. - record finishAt: start durationMilliseconds: 10 status: 'ok'. - stats recordCall: record ]. + record := MCPToolCallRecord + id: index + toolName: 'slow-tool' + startedAt: start. + record finishAt: start durationMilliseconds: 10 status: 'ok'. + stats recordCall: record ]. explanation := state outlierExplanationForDurationMilliseconds: 25 diff --git a/src/MCP-Spec/MCPDashboardPresenter.class.st b/src/MCP-Spec/MCPDashboardPresenter.class.st index 842c963..cdd226f 100644 --- a/src/MCP-Spec/MCPDashboardPresenter.class.st +++ b/src/MCP-Spec/MCPDashboardPresenter.class.st @@ -87,9 +87,9 @@ MCPDashboardPresenter >> addSectionLayout: aSectionLayout expanded: expanded to: MCPDashboardPresenter >> applyConfiguration [ [ - | newPort | - newPort := self readPortFromInput. - self model configurePort: newPort debugMode: debugCheckBox state ] + | newPort | + newPort := self readPortFromInput. + self model configurePort: newPort debugMode: debugCheckBox state ] on: Error do: [ :error | UIManager default alert: error messageText ]. @@ -121,9 +121,9 @@ MCPDashboardPresenter >> autoRefreshIntervalSeconds [ MCPDashboardPresenter >> autoRefreshLoop [ [ - [ self shouldAutoRefresh ] whileTrue: [ - (Delay forSeconds: self autoRefreshIntervalSeconds) wait. - self shouldAutoRefresh ifTrue: [ self defer: [ self refreshView ] ] ] ] + [ self shouldAutoRefresh ] whileTrue: [ + (Delay forSeconds: self autoRefreshIntervalSeconds) wait. + self shouldAutoRefresh ifTrue: [ self defer: [ self refreshView ] ] ] ] ensure: [ autoRefreshProcess := nil ] ] @@ -195,11 +195,11 @@ MCPDashboardPresenter >> dashboardWidgetsLayout [ (self isToolsSectionExpanded and: [ self hasExpandedMonitoringSection ]) ifTrue: [ - ^ SpPanedLayout newTopToBottom - positionOfSlider: 42 percent; - first: self toolsWidgetLayout; - second: self monitoringWidgetsLayout; - yourself ]. + ^ SpPanedLayout newTopToBottom + positionOfSlider: 42 percent; + first: self toolsWidgetLayout; + second: self monitoringWidgetsLayout; + yourself ]. ^ self dashboardWidgetsBoxLayout ] @@ -226,14 +226,14 @@ MCPDashboardPresenter >> defaultLayout [ MCPDashboardPresenter >> disclosureLabelFor: title count: count expanded: expanded [ ^ String streamContents: [ :stream | - stream - nextPutAll: (expanded - ifTrue: [ '[-] ' ] - ifFalse: [ '[+] ' ]); - nextPutAll: title; - nextPutAll: ' ('; - print: count; - nextPut: $) ] + stream + nextPutAll: (expanded + ifTrue: [ '[-] ' ] + ifFalse: [ '[+] ' ]); + nextPutAll: title; + nextPutAll: ' ('; + print: count; + nextPut: $) ] ] { #category : 'collapsing' } @@ -535,7 +535,8 @@ MCPDashboardPresenter >> monitoringSectionsLayout [ second: self logsWidgetLayout; yourself); yourself ]. - self expandedMonitoringSectionCount = 2 ifTrue: [ ^ self twoExpandedMonitoringSectionsLayout ]. + self expandedMonitoringSectionCount = 2 ifTrue: [ + ^ self twoExpandedMonitoringSectionsLayout ]. ^ self monitoringWidgetsBoxLayout ] @@ -670,9 +671,9 @@ MCPDashboardPresenter >> restartServer [ MCPDashboardPresenter >> serverStatusIconNameForRunning: isRunning listening: isListening [ isRunning ifFalse: [ - ^ isListening - ifTrue: [ #testRed ] - ifFalse: [ #testNotRun ] ]. + ^ isListening + ifTrue: [ #testRed ] + ifFalse: [ #testNotRun ] ]. ^ isListening ifTrue: [ #testGreen ] ifFalse: [ #testRed ] @@ -690,9 +691,9 @@ MCPDashboardPresenter >> serverStatusLabelForRunning: isRunning listening: isLis MCPDashboardPresenter >> serverStatusValueForRunning: isRunning listening: isListening [ isRunning ifFalse: [ - ^ isListening - ifTrue: [ 'stopped, socket still listening' ] - ifFalse: [ 'stopped' ] ]. + ^ isListening + ifTrue: [ 'stopped, socket still listening' ] + ifFalse: [ 'stopped' ] ]. ^ isListening ifTrue: [ 'running' ] ifFalse: [ 'running, socket not listening' ] @@ -731,9 +732,9 @@ MCPDashboardPresenter >> statusRowLayout [ vAlignCenter; add: statusLabel expand: false; add: statusIcon withConstraints: [ :constraints | - constraints - width: 18; - height: 18 ]; + constraints + width: 18; + height: 18 ]; add: statusValueLabel expand: false; yourself ] @@ -814,12 +815,12 @@ MCPDashboardPresenter >> tracesContextMenu [ ^ self newMenu addGroup: [ :group | - group addItem: [ :item | - item - name: 'Inspect'; - description: 'Inspect the selected trace record'; - enabled: [ tracesTable selectedItem isNotNil ]; - action: [ self inspectSelectedTraceRecord ] ] ]; + group addItem: [ :item | + item + name: 'Inspect'; + description: 'Inspect the selected trace record'; + enabled: [ tracesTable selectedItem isNotNil ]; + action: [ self inspectSelectedTraceRecord ] ] ]; yourself ] diff --git a/src/MCP-Spec/MCPToolsCatalogPresenter.class.st b/src/MCP-Spec/MCPToolsCatalogPresenter.class.st index e4651d9..aaed334 100644 --- a/src/MCP-Spec/MCPToolsCatalogPresenter.class.st +++ b/src/MCP-Spec/MCPToolsCatalogPresenter.class.st @@ -29,12 +29,12 @@ MCPToolsCatalogPresenter >> addToolCatalogGroup: group to: contentLayout [ displayBold: [ :ignored | true ]. contentLayout add: heading expand: false. group value do: [ :toolClass | - contentLayout - add: (self toolCatalogCardFor: toolClass) - withConstraints: [ :constraints | - constraints - expand: false; - fill: true ] ] + contentLayout + add: (self toolCatalogCardFor: toolClass) + withConstraints: [ :constraints | + constraints + expand: false; + fill: true ] ] ] { #category : 'layout' } @@ -87,9 +87,9 @@ MCPToolsCatalogPresenter >> toolCatalogCardFor: toolClass [ width: self toolCatalogLeftColumnWidth; add: (self toolCatalogDescriptionPresenterFor: tool) withConstraints: [ :constraints | - constraints - expand: true; - fill: true ]. + constraints + expand: true; + fill: true ]. card layout: cardLayout. ^ card ] @@ -114,9 +114,9 @@ MCPToolsCatalogPresenter >> toolCatalogDescriptionPresenterFor: tool [ withoutScrollBars. descriptionLayout := SpBoxLayout newTopToBottom yourself. descriptionLayout add: description withConstraints: [ :constraints | - constraints - expand: true; - fill: true ]. + constraints + expand: true; + fill: true ]. descriptionCell layout: descriptionLayout. ^ descriptionCell ] diff --git a/src/MCP-Tests/MCPChangeClassCommentCommandTest.class.st b/src/MCP-Tests/MCPChangeClassCommentCommandTest.class.st index 5efe46a..427a5b7 100644 --- a/src/MCP-Tests/MCPChangeClassCommentCommandTest.class.st +++ b/src/MCP-Tests/MCPChangeClassCommentCommandTest.class.st @@ -25,8 +25,8 @@ MCPChangeClassCommentCommandTest >> ensureTargetClass [ slots: #( ) classSlots: #( ). self withoutEpiceaDuring: [ - (self classNamed: self commentTargetClassName) comment: - 'original comment' ] + (self classNamed: self commentTargetClassName) comment: + 'original comment' ] ] { #category : 'private' } @@ -67,9 +67,9 @@ MCPChangeClassCommentCommandTest >> testMissingClassSignalsCommandError [ | error | error := self captureCommandError: [ - (MCPChangeClassCommentCommand - className: 'MCPChangeClassCommentCommandTestMissing' - classComment: 'ignored') execute ]. + (MCPChangeClassCommentCommand + className: 'MCPChangeClassCommentCommandTestMissing' + classComment: 'ignored') execute ]. self assert: error errorCode equals: #ClassNotFound. self assert: (error structuredDetails at: #className) diff --git a/src/MCP-Tests/MCPClassMutationRequestTest.class.st b/src/MCP-Tests/MCPClassMutationRequestTest.class.st index 444969f..6c78506 100644 --- a/src/MCP-Tests/MCPClassMutationRequestTest.class.st +++ b/src/MCP-Tests/MCPClassMutationRequestTest.class.st @@ -15,22 +15,22 @@ MCPClassMutationRequestTest >> testCreateRequestParsesDefinitionArguments [ | context request | request := MCPClassCreateRequest fromRequest: (MCPToolRequest new - tool: MCPToolCreateClass new; - arguments: { - (#className -> 'MCPGeneratedClass'). - (#superclassName -> 'Object'). - (#packageName -> 'MCP-Generated'). - (#tag -> 'Models'). - (#classComment -> 'Generated comment.'). - (#force -> true). - (#slots -> #( 'firstName' 'lastName' )). - (#classSlots -> #( 'defaultName' )). - (#traits -> #( 'TComparable' )). - (#classTraits -> #( 'TComparable classTrait' )). - (#sharedVariables -> #( 'Current' )). - (#sharedPools -> #( 'ChronologyConstants' )). - (#layout -> 'WeakLayout') } asDictionary; - yourself) + tool: MCPToolCreateClass new; + arguments: { + (#className -> 'MCPGeneratedClass'). + (#superclassName -> 'Object'). + (#packageName -> 'MCP-Generated'). + (#tag -> 'Models'). + (#classComment -> 'Generated comment.'). + (#force -> true). + (#slots -> #( 'firstName' 'lastName' )). + (#classSlots -> #( 'defaultName' )). + (#traits -> #( 'TComparable' )). + (#classTraits -> #( 'TComparable classTrait' )). + (#sharedVariables -> #( 'Current' )). + (#sharedPools -> #( 'ChronologyConstants' )). + (#layout -> 'WeakLayout') } asDictionary; + yourself) tool: MCPToolCreateClass new. self assert: request className equals: 'MCPGeneratedClass'. self assert: request superclassName equals: 'Object'. @@ -63,8 +63,8 @@ MCPClassMutationRequestTest >> testUpdateCommandResolvesOmittedMovePackageName [ request := MCPToolRequest new tool: tool; arguments: { - (#className -> self class name asString). - (#tag -> 'Requests') } asDictionary; + (#className -> self class name asString). + (#tag -> 'Requests') } asDictionary; yourself. mutationRequest := tool parsedRequestFromToolRequest: request. command := tool commandForRequest: mutationRequest. @@ -107,7 +107,6 @@ MCPClassMutationRequestTest >> testUpdateRequestParsesSlotArguments [ self assert: (context at: #slotName) equals: 'oldName'. self assert: (context at: #newSlotName) equals: 'newName'. self assert: (context at: #classSide) - ] { #category : 'tests' } @@ -139,7 +138,6 @@ MCPClassMutationRequestTest >> testUpdateRequestTracksSuppliedProperties [ self assert: (context at: #classComment) equals: ''. self assert: (context at: #slots) equals: #( ). self deny: (context includesKey: #classSlots) - ] { #category : 'tests' } @@ -157,7 +155,6 @@ MCPClassMutationRequestTest >> testUpdateRequestWithNoPatchArgumentsHasNoUpdates context := request requestedContext. self assert: context size equals: 1. self assert: (context at: #className) equals: 'ExistingClass' - ] { #category : 'private' } diff --git a/src/MCP-Tests/MCPCommandErrorTest.class.st b/src/MCP-Tests/MCPCommandErrorTest.class.st index 66afd3d..c952894 100644 --- a/src/MCP-Tests/MCPCommandErrorTest.class.st +++ b/src/MCP-Tests/MCPCommandErrorTest.class.st @@ -13,8 +13,8 @@ Class { MCPCommandErrorTest >> capture: aBlock [ ^ [ - aBlock value. - self fail: 'Expected MCPCommandError' ] + aBlock value. + self fail: 'Expected MCPCommandError' ] on: MCPCommandError do: [ :error | error ] ] @@ -24,8 +24,8 @@ MCPCommandErrorTest >> testClassAlreadyExistsErrorCarriesClassName [ | details error | error := self capture: [ - MCPCommandError signalClassAlreadyExistsNamed: - 'MCPCommandErrorTestExisting' ]. + MCPCommandError signalClassAlreadyExistsNamed: + 'MCPCommandErrorTestExisting' ]. details := error structuredDetails. self assert: error errorCode equals: #ClassAlreadyExists. self @@ -64,11 +64,11 @@ MCPCommandErrorTest >> testMissingMethodErrorCarriesClassSideAndSelector [ | details error | error := self capture: [ - MCPCommandError - signalMissingMethodInClassName: - 'MCPCommandErrorTestTarget' - classSide: true - selector: 'value' ]. + MCPCommandError + signalMissingMethodInClassName: + 'MCPCommandErrorTestTarget' + classSide: true + selector: 'value' ]. details := error structuredDetails. self assert: error errorCode equals: #MethodNotFound. self assert: (details at: #errorClass) equals: 'MCPCommandError'. @@ -108,9 +108,9 @@ MCPCommandErrorTest >> testMissingSuperclassErrorCarriesSuperclassName [ | details error | error := self capture: [ - MCPCommandError - signalMissingSuperclassNamed: 'MCPMissingSuperclass' - forClassNamed: 'MCPNewClass' ]. + MCPCommandError + signalMissingSuperclassNamed: 'MCPMissingSuperclass' + forClassNamed: 'MCPNewClass' ]. details := error structuredDetails. self assert: error errorCode equals: #SuperclassNotFound. self assert: (details at: #className) equals: 'MCPNewClass'. @@ -124,10 +124,10 @@ MCPCommandErrorTest >> testMissingTagErrorCarriesTagAndClassName [ | details error | error := self capture: [ - MCPCommandError - signalMissingTag: 'MissingTag' - packageName: 'MCP-Tests' - forClassNamed: 'MCPCommandErrorTestTarget' ]. + MCPCommandError + signalMissingTag: 'MissingTag' + packageName: 'MCP-Tests' + forClassNamed: 'MCPCommandErrorTestTarget' ]. details := error structuredDetails. self assert: error errorCode equals: #TagNotFound. self diff --git a/src/MCP-Tests/MCPCommandTestCase.class.st b/src/MCP-Tests/MCPCommandTestCase.class.st index 58a2f9d..01ea375 100644 --- a/src/MCP-Tests/MCPCommandTestCase.class.st +++ b/src/MCP-Tests/MCPCommandTestCase.class.st @@ -25,8 +25,8 @@ MCPCommandTestCase >> aroundCommandExecution: aBlock [ MCPCommandTestCase >> captureCommandError: aBlock [ ^ [ - self aroundCommandExecution: [ aBlock value ]. - self fail: 'Expected MCPCommandError' ] + self aroundCommandExecution: [ aBlock value ]. + self fail: 'Expected MCPCommandError' ] on: MCPCommandError do: [ :error | error ] ] diff --git a/src/MCP-Tests/MCPCompiledMethodInfoTest.class.st b/src/MCP-Tests/MCPCompiledMethodInfoTest.class.st index 73f69fd..cac571b 100644 --- a/src/MCP-Tests/MCPCompiledMethodInfoTest.class.st +++ b/src/MCP-Tests/MCPCompiledMethodInfoTest.class.st @@ -26,12 +26,12 @@ MCPCompiledMethodInfoTest >> createTargetClass [ self hasTargetClass ifTrue: [ ^ self ]. self withoutEpiceaDuring: [ - | builder | - builder := Object << self targetClassName asSymbol. - builder package: 'MCP-Tests'. - builder tag: 'Internal'. - builder slots: #( ). - builder install ] + | builder | + builder := Object << self targetClassName asSymbol. + builder package: 'MCP-Tests'. + builder tag: 'Internal'. + builder slots: #( ). + builder install ] ] { #category : 'private' } diff --git a/src/MCP-Tests/MCPCompiledMethodScopeQueryTest.class.st b/src/MCP-Tests/MCPCompiledMethodScopeQueryTest.class.st index d9edad0..0645a40 100644 --- a/src/MCP-Tests/MCPCompiledMethodScopeQueryTest.class.st +++ b/src/MCP-Tests/MCPCompiledMethodScopeQueryTest.class.st @@ -13,12 +13,12 @@ Class { MCPCompiledMethodScopeQueryTest >> methodIdentitiesFor: compiledMethods [ ^ (compiledMethods collect: [ :each | - String streamContents: [ :stream | - stream nextPutAll: each methodClass instanceSide name asString. - each methodClass isMeta ifTrue: [ stream nextPutAll: ' class' ]. - stream - nextPutAll: '>>'; - nextPutAll: each selector asString ] ]) asSet + String streamContents: [ :stream | + stream nextPutAll: each methodClass instanceSide name asString. + each methodClass isMeta ifTrue: [ stream nextPutAll: ' class' ]. + stream + nextPutAll: '>>'; + nextPutAll: each selector asString ] ]) asSet ] { #category : 'tests' } @@ -94,8 +94,8 @@ MCPCompiledMethodScopeQueryTest >> testInvalidSideSignalsErrorWhenQuerying [ side: 'invalid'; yourself. error := [ - query methods. - self fail: 'Expected Error' ] + query methods. + self fail: 'Expected Error' ] on: Error do: [ :caught | caught ]. self diff --git a/src/MCP-Tests/MCPCreateClassCommandTest.class.st b/src/MCP-Tests/MCPCreateClassCommandTest.class.st index 072f514..f8c21e0 100644 --- a/src/MCP-Tests/MCPCreateClassCommandTest.class.st +++ b/src/MCP-Tests/MCPCreateClassCommandTest.class.st @@ -29,10 +29,10 @@ MCPCreateClassCommandTest >> generatedPackageName [ MCPCreateClassCommandTest >> removeGeneratedPackage [ self withoutEpiceaDuring: [ - (self packageOrganizer hasPackage: self generatedPackageName) - ifTrue: [ - self packageOrganizer removePackage: - (self packageOrganizer packageNamed: self generatedPackageName) ] ] + (self packageOrganizer hasPackage: self generatedPackageName) + ifTrue: [ + self packageOrganizer removePackage: + (self packageOrganizer packageNamed: self generatedPackageName) ] ] ] { #category : 'running' } @@ -160,13 +160,13 @@ MCPCreateClassCommandTest >> testExistingClassSignalsCommandError [ slots: nil classSlots: nil). error := self captureCommandError: [ - (MCPCreateClassCommand - className: 'MCPCreateClassCommandTestGenerated' - superclassName: 'Object' - packageName: self generatedPackageName - tag: nil - slots: nil - classSlots: nil) execute ]. + (MCPCreateClassCommand + className: 'MCPCreateClassCommandTestGenerated' + superclassName: 'Object' + packageName: self generatedPackageName + tag: nil + slots: nil + classSlots: nil) execute ]. self assert: error errorCode equals: #ClassAlreadyExists. self assert: (error structuredDetails at: #className) @@ -178,13 +178,13 @@ MCPCreateClassCommandTest >> testMissingSuperclassSignalsCommandError [ | error | error := self captureCommandError: [ - (MCPCreateClassCommand - className: 'MCPCreateClassCommandTestGenerated' - superclassName: 'DefinitelyMissingSuperclass' - packageName: self generatedPackageName - tag: nil - slots: nil - classSlots: nil) execute ]. + (MCPCreateClassCommand + className: 'MCPCreateClassCommandTestGenerated' + superclassName: 'DefinitelyMissingSuperclass' + packageName: self generatedPackageName + tag: nil + slots: nil + classSlots: nil) execute ]. self assert: error errorCode equals: #SuperclassNotFound. self assert: (error structuredDetails at: #superclassName) diff --git a/src/MCP-Tests/MCPDebugToolContractTest.class.st b/src/MCP-Tests/MCPDebugToolContractTest.class.st index e9b9f9f..800534a 100644 --- a/src/MCP-Tests/MCPDebugToolContractTest.class.st +++ b/src/MCP-Tests/MCPDebugToolContractTest.class.st @@ -90,8 +90,8 @@ MCPDebugToolContractTest >> registerSyntheticSession [ { #category : 'private' } MCPDebugToolContractTest >> removeDebugMethodUpdateTestMethods [ - #( #mcpDebugMethodUpdateGeneratedValue #mcpDebugMethodUpdateTemporaryStub ) do: [ - :selector | + #( #mcpDebugMethodUpdateGeneratedValue + #mcpDebugMethodUpdateTemporaryStub ) do: [ :selector | (MCPUpdateDebugMethodTestTarget includesSelector: selector) ifTrue: [ MCPUpdateDebugMethodTestTarget removeSelector: selector ] ]. Smalltalk globals @@ -821,10 +821,12 @@ MCPDebugToolContractTest >> testDebugEvaluateEvaluatesExpressionInSelectedFrame record := self registerSyntheticSession. stateData := self stateDataForRecord: record. frameRef := (stateData at: #selectedFrame) at: #frameRef. - result := self callToolNamed: 'debug_expression_evaluate' withArguments: { - (#sessionId -> record sessionId). - (#frameRef -> frameRef). - (#expression -> 'self class name') } asDictionary. + result := self + callToolNamed: 'debug_expression_evaluate' + withArguments: { + (#sessionId -> record sessionId). + (#frameRef -> frameRef). + (#expression -> 'self class name') } asDictionary. data := self dataFrom: result. self assert: ((self structuredContentFrom: result) at: #status) @@ -852,10 +854,12 @@ MCPDebugToolContractTest >> testDebugEvaluateReadsTemporaryInSelectedFrame [ reason: 'halt'. stateData := self stateDataForRecord: record. frameRef := (stateData at: #selectedFrame) at: #frameRef. - result := self callToolNamed: 'debug_expression_evaluate' withArguments: { - (#sessionId -> record sessionId). - (#frameRef -> frameRef). - (#expression -> 'marker + 1') } asDictionary. + result := self + callToolNamed: 'debug_expression_evaluate' + withArguments: { + (#sessionId -> record sessionId). + (#frameRef -> frameRef). + (#expression -> 'marker + 1') } asDictionary. data := self dataFrom: result. self assert: ((self structuredContentFrom: result) at: #status) @@ -870,13 +874,15 @@ MCPDebugToolContractTest >> testDebugEvaluateRejectsForeignFrameRef [ | error foreignRecord record result | record := self registerSyntheticSession. foreignRecord := self registerSyntheticSession. - result := self callToolNamed: 'debug_expression_evaluate' withArguments: { - (#sessionId -> record sessionId). - (#frameRef - -> - (foreignRecord sessionId , '/' , foreignRecord stateId - , '/frame-0')). - (#expression -> '1') } asDictionary. + result := self + callToolNamed: 'debug_expression_evaluate' + withArguments: { + (#sessionId -> record sessionId). + (#frameRef + -> + (foreignRecord sessionId , '/' , foreignRecord stateId + , '/frame-0')). + (#expression -> '1') } asDictionary. error := self errorFrom: result. self assert: ((self structuredContentFrom: result) at: #status) @@ -895,10 +901,12 @@ MCPDebugToolContractTest >> testDebugEvaluateRejectsStaleFrameRef [ | record result error | record := self registerSyntheticSession. - result := self callToolNamed: 'debug_expression_evaluate' withArguments: { - (#sessionId -> record sessionId). - (#frameRef -> (record sessionId , '/old-state/frame-0')). - (#expression -> '1') } asDictionary. + result := self + callToolNamed: 'debug_expression_evaluate' + withArguments: { + (#sessionId -> record sessionId). + (#frameRef -> (record sessionId , '/old-state/frame-0')). + (#expression -> '1') } asDictionary. error := self errorFrom: result. self assert: ((self structuredContentFrom: result) at: #status) @@ -939,10 +947,12 @@ MCPDebugToolContractTest >> testDebugEvaluateReportsSyntaxFailure [ record := self registerSyntheticSession. stateData := self stateDataForRecord: record. frameRef := (stateData at: #selectedFrame) at: #frameRef. - result := self callToolNamed: 'debug_expression_evaluate' withArguments: { - (#sessionId -> record sessionId). - (#frameRef -> frameRef). - (#expression -> '1 +') } asDictionary. + result := self + callToolNamed: 'debug_expression_evaluate' + withArguments: { + (#sessionId -> record sessionId). + (#frameRef -> frameRef). + (#expression -> '1 +') } asDictionary. error := self errorFrom: result. self assert: ((self structuredContentFrom: result) at: #status) @@ -1503,7 +1513,8 @@ MCPDebugToolContractTest >> testDebugStateOffersMissingMethodRepairAction [ | action arguments data result state | result := self callToolNamed: 'debug_capture' withArguments: { (#expression - -> 'MCPUpdateDebugMethodTestTarget new triggerMissingMethod'). + -> + 'MCPUpdateDebugMethodTestTarget new triggerMissingMethod'). (#name -> 'Captured missing method'). (#timeoutMilliseconds -> 1000) } asDictionary. data := self dataFrom: result. diff --git a/src/MCP-Tests/MCPHaltingTestTool.class.st b/src/MCP-Tests/MCPHaltingTestTool.class.st index 96536bf..1b25d48 100644 --- a/src/MCP-Tests/MCPHaltingTestTool.class.st +++ b/src/MCP-Tests/MCPHaltingTestTool.class.st @@ -25,11 +25,11 @@ MCPHaltingTestTool class >> toolName [ MCPHaltingTestTool >> buildInputSchema [ ^ MCPStructureInputSchema new - type: 'object'; - properties: #( ); - required: #( ); - additionalProperties: false; - yourself + type: 'object'; + properties: #( ); + required: #( ); + additionalProperties: false; + yourself ] { #category : 'metadata' } diff --git a/src/MCP-Tests/MCPJSONSchemaValidatorTest.class.st b/src/MCP-Tests/MCPJSONSchemaValidatorTest.class.st index e0e1ca9..c96f444 100644 --- a/src/MCP-Tests/MCPJSONSchemaValidatorTest.class.st +++ b/src/MCP-Tests/MCPJSONSchemaValidatorTest.class.st @@ -14,9 +14,8 @@ MCPJSONSchemaValidatorTest >> baseRepresentativeArgumentsByToolClass [ ^ { (MCPToolEvaluate -> { (#code -> '1 + 1') } asDictionary). - (MCPToolRunTests -> { (#tests - -> { { (#className -> 'MCPToolContractsTest') } asDictionary }) } - asDictionary). + (MCPToolRunTests + -> { (#classes -> { 'MCPToolContractsTest' }) } asDictionary). (MCPToolGetClass -> { (#className -> 'MCPTool') } asDictionary). (MCPToolGetMethod -> { (#className -> 'MCPTool'). @@ -227,11 +226,10 @@ MCPJSONSchemaValidatorTest >> representativeArgumentsByToolClass [ at: MCPToolLoadBaseline put: { (#baseline -> 'ExampleBaseline') } asDictionary; at: MCPToolRunTestCoverage put: { - (#tests - -> { { (#className -> 'MCPToolContractsTest') } asDictionary }). - (#coverage - -> { (#scope -> { (#classes -> #( 'MCPToolContractsTest' )) } asDictionary) } asDictionary) } - asDictionary; + (#classes -> { 'MCPToolContractsTest' }). + (#coverage -> { (#scope + -> { (#classes -> #( 'MCPToolContractsTest' )) } asDictionary) } + asDictionary) } asDictionary; at: MCPToolApplyChangeHistoryEntries put: { (#latestCount -> 1) } asDictionary; at: MCPToolRevertChangeHistoryEntries @@ -358,9 +356,7 @@ MCPJSONSchemaValidatorTest >> testCurrentToolRequestValidationRejectsOperationSp self should: [ MCPToolRunTestCoverage new requestFromToolCallArguments: - { (#tests - -> { { (#className -> 'MCPToolContractsTest') } asDictionary }) } - asDictionary ] + { (#classes -> { 'MCPToolContractsTest' }) } asDictionary ] raise: MCPInvalidToolInput. self should: [ @@ -427,7 +423,6 @@ MCPJSONSchemaValidatorTest >> testValidatesAllOfAndIfThen [ keywords := self keywordsFrom: (self violationsFor: arguments schema: schema). self assert: keywords equals: #( 'required' ) - ] { #category : 'tests' } @@ -455,7 +450,6 @@ MCPJSONSchemaValidatorTest >> testValidatesArrayItemsEnumAndConst [ self assert: (self keywordsFrom: violations) asBag equals: #( 'enum' 'const' 'type' ) asBag - ] { #category : 'tests' } diff --git a/src/MCP-Tests/MCPMoveClassCommandTest.class.st b/src/MCP-Tests/MCPMoveClassCommandTest.class.st index 169d06c..65a7d5b 100644 --- a/src/MCP-Tests/MCPMoveClassCommandTest.class.st +++ b/src/MCP-Tests/MCPMoveClassCommandTest.class.st @@ -31,10 +31,10 @@ MCPMoveClassCommandTest >> destinationTagName [ MCPMoveClassCommandTest >> ensureDestinationPackage [ self withoutEpiceaDuring: [ - | package | - package := PackageOrganizer default ensurePackage: - self destinationPackageName. - package ensureTag: self destinationTagName ] + | package | + package := PackageOrganizer default ensurePackage: + self destinationPackageName. + package ensureTag: self destinationTagName ] ] { #category : 'private' } @@ -47,11 +47,11 @@ MCPMoveClassCommandTest >> originalPackageName [ MCPMoveClassCommandTest >> removeDestinationPackage [ self withoutEpiceaDuring: [ - (PackageOrganizer default hasPackage: self destinationPackageName) - ifTrue: [ - PackageOrganizer default removePackage: - (PackageOrganizer default packageNamed: - self destinationPackageName) ] ] + (PackageOrganizer default hasPackage: self destinationPackageName) + ifTrue: [ + PackageOrganizer default removePackage: + (PackageOrganizer default packageNamed: + self destinationPackageName) ] ] ] { #category : 'private' } @@ -61,9 +61,9 @@ MCPMoveClassCommandTest >> restoreTargetClassLocation [ and: [ self currentTagOfTargetClass = 'Uncategorized' ]) ifTrue: [ ^ self ]. self withoutEpiceaDuring: [ - (RBMoveClassTransformation - move: self targetClassName - toPackage: self originalPackageName) execute ] + (RBMoveClassTransformation + move: self targetClassName + toPackage: self originalPackageName) execute ] ] { #category : 'running' } diff --git a/src/MCP-Tests/MCPRecordingMetacello.class.st b/src/MCP-Tests/MCPRecordingMetacello.class.st index 8d43974..19c7706 100644 --- a/src/MCP-Tests/MCPRecordingMetacello.class.st +++ b/src/MCP-Tests/MCPRecordingMetacello.class.st @@ -141,8 +141,8 @@ MCPRecordingMetacello >> received: selector [ MCPRecordingMetacello >> received: selector withArguments: arguments [ ^ messages anySatisfy: [ :each | - (each at: #selector) = selector and: [ - (each at: #arguments) = arguments asArray ] ] + (each at: #selector) = selector and: [ + (each at: #arguments) = arguments asArray ] ] ] { #category : 'recording' } diff --git a/src/MCP-Tests/MCPRemoveClassesCommandTest.class.st b/src/MCP-Tests/MCPRemoveClassesCommandTest.class.st index af4e9f9..3a83299 100644 --- a/src/MCP-Tests/MCPRemoveClassesCommandTest.class.st +++ b/src/MCP-Tests/MCPRemoveClassesCommandTest.class.st @@ -30,13 +30,13 @@ MCPRemoveClassesCommandTest >> createClassNamed: aClassName superclassName: aSup MCPRemoveClassesCommandTest >> createClassNamed: aClassName superclassName: aSuperclassName packageName: aPackageName [ ^ self withoutEpiceaDuring: [ - | builder superclass | - superclass := self classNamed: aSuperclassName. - builder := superclass << aClassName asSymbol. - builder package: aPackageName. - builder tag: 'Internal'. - builder slots: #( ). - builder install ] + | builder superclass | + superclass := self classNamed: aSuperclassName. + builder := superclass << aClassName asSymbol. + builder package: aPackageName. + builder tag: 'Internal'. + builder slots: #( ). + builder install ] ] { #category : 'private' } @@ -79,9 +79,9 @@ MCPRemoveClassesCommandTest >> ensureFixtureClasses [ MCPRemoveClassesCommandTest >> ensureMethodSource: aMethodSource onClassNamed: aClassName [ self withoutEpiceaDuring: [ - (self classNamed: aClassName) - compile: aMethodSource - classified: 'tests' ] + (self classNamed: aClassName) + compile: aMethodSource + classified: 'tests' ] ] { #category : 'private' } @@ -188,9 +188,9 @@ MCPRemoveClassesCommandTest >> testMissingClassSignalsCommandError [ | error | error := self captureCommandError: [ - (MCPRemoveClassesCommand classNames: { - self simpleClassName. - self missingClassName }) execute ]. + (MCPRemoveClassesCommand classNames: { + self simpleClassName. + self missingClassName }) execute ]. self assert: error errorCode equals: #ClassNotFound. self assert: (error structuredDetails at: #className) diff --git a/src/MCP-Tests/MCPRenameClassCommandTest.class.st b/src/MCP-Tests/MCPRenameClassCommandTest.class.st index f1bfb06..d36c8e8 100644 --- a/src/MCP-Tests/MCPRenameClassCommandTest.class.st +++ b/src/MCP-Tests/MCPRenameClassCommandTest.class.st @@ -16,14 +16,14 @@ MCPRenameClassCommandTest >> ensureOriginalFixtureState [ originalSymbol := self originalClassName asSymbol. renamedSymbol := self renamedClassName asSymbol. self withoutEpiceaDuring: [ - ((Smalltalk globals includesKey: originalSymbol) and: [ - Smalltalk globals includesKey: renamedSymbol ]) ifTrue: [ - (Smalltalk globals at: renamedSymbol) removeFromSystem ]. - ((Smalltalk globals includesKey: renamedSymbol) and: [ - (Smalltalk globals includesKey: originalSymbol) not ]) ifTrue: [ - (ReRenameClassRefactoring - rename: self renamedClassName - to: self originalClassName) execute ] ] + ((Smalltalk globals includesKey: originalSymbol) and: [ + Smalltalk globals includesKey: renamedSymbol ]) ifTrue: [ + (Smalltalk globals at: renamedSymbol) removeFromSystem ]. + ((Smalltalk globals includesKey: renamedSymbol) and: [ + (Smalltalk globals includesKey: originalSymbol) not ]) ifTrue: [ + (ReRenameClassRefactoring + rename: self renamedClassName + to: self originalClassName) execute ] ] ] { #category : 'private' } @@ -57,9 +57,9 @@ MCPRenameClassCommandTest >> testMissingClassSignalsCommandError [ | error | error := self captureCommandError: [ - (MCPRenameClassCommand - className: 'MCPRenameClassCommandTestMissing' - newClassName: self renamedClassName) execute ]. + (MCPRenameClassCommand + className: 'MCPRenameClassCommandTestMissing' + newClassName: self renamedClassName) execute ]. self assert: error errorCode equals: #ClassNotFound. self assert: (error structuredDetails at: #className) diff --git a/src/MCP-Tests/MCPReparentClassCommandTest.class.st b/src/MCP-Tests/MCPReparentClassCommandTest.class.st index 153c649..55172f7 100644 --- a/src/MCP-Tests/MCPReparentClassCommandTest.class.st +++ b/src/MCP-Tests/MCPReparentClassCommandTest.class.st @@ -28,8 +28,8 @@ MCPReparentClassCommandTest >> ensureFixtureClasses [ protocol: 'testing' on: (self classNamed: self reparentTargetClassName). self withoutEpiceaDuring: [ - (self classNamed: self reparentTargetClassName) comment: - 'reparent comment' ] + (self classNamed: self reparentTargetClassName) comment: + 'reparent comment' ] ] { #category : 'private' } @@ -78,9 +78,9 @@ MCPReparentClassCommandTest >> testMissingClassSignalsCommandError [ | error | error := self captureCommandError: [ - (MCPReparentClassCommand - className: 'MCPReparentClassCommandTestMissing' - superclassName: self reparentSuperclassName) execute ]. + (MCPReparentClassCommand + className: 'MCPReparentClassCommandTestMissing' + superclassName: self reparentSuperclassName) execute ]. self assert: error errorCode equals: #ClassNotFound. self assert: (error structuredDetails at: #className) @@ -92,9 +92,9 @@ MCPReparentClassCommandTest >> testMissingSuperclassSignalsCommandError [ | error | error := self captureCommandError: [ - (MCPReparentClassCommand - className: self reparentTargetClassName - superclassName: 'DefinitelyMissingSuperclass') execute ]. + (MCPReparentClassCommand + className: self reparentTargetClassName + superclassName: 'DefinitelyMissingSuperclass') execute ]. self assert: error errorCode equals: #SuperclassNotFound. self assert: (error structuredDetails at: #superclassName) diff --git a/src/MCP-Tests/MCPRepositorySpecTest.class.st b/src/MCP-Tests/MCPRepositorySpecTest.class.st index ae75df9..7e70f55 100644 --- a/src/MCP-Tests/MCPRepositorySpecTest.class.st +++ b/src/MCP-Tests/MCPRepositorySpecTest.class.st @@ -299,16 +299,16 @@ MCPRepositorySpecTest >> testRepositoryReferenceResolvesByNameAndLocation [ location: FileLocator imageDirectory packageNames: #( 'MCP' ). self withRepositories: { repository } do: [ - reference := MCPRepositoryReferenceSpec - name: 'MCP Reference Repository' - location: FileLocator imageDirectory pathString. - self assert: reference repository identicalTo: repository. - self - assert: (reference requestedContext at: #repositoryName) - equals: 'MCP Reference Repository'. - self - assert: (reference requestedContext at: #location) - equals: FileLocator imageDirectory pathString ] + reference := MCPRepositoryReferenceSpec + name: 'MCP Reference Repository' + location: FileLocator imageDirectory pathString. + self assert: reference repository identicalTo: repository. + self + assert: (reference requestedContext at: #repositoryName) + equals: 'MCP Reference Repository'. + self + assert: (reference requestedContext at: #location) + equals: FileLocator imageDirectory pathString ] ] { #category : 'tests' } @@ -375,15 +375,16 @@ MCPRepositorySpecTest >> testRepositoryVerifyIdentityRequestParsesTypedInput [ | context verifyIdentityRequest | verifyIdentityRequest := MCPRepositoryVerifyIdentityRequest - fromRequest: (self requestWithArguments: { - (#repositoryName -> 'MCP Repo'). - (#location -> '/tmp/MCP'). - (#branchName -> 'main'). - (#subdirectory -> 'src'). - (#packageNames -> #( 'MCP' 'MCP-Tests' )). - (#modifiedPackageNames -> #( 'MCP' )). - (#isModified -> true) } asDictionary) - tool: nil. + fromRequest: (self requestWithArguments: { + (#repositoryName -> 'MCP Repo'). + (#location -> '/tmp/MCP'). + (#branchName -> 'main'). + (#subdirectory -> 'src'). + (#packageNames + -> #( 'MCP' 'MCP-Tests' )). + (#modifiedPackageNames -> #( 'MCP' )). + (#isModified -> true) } asDictionary) + tool: nil. context := verifyIdentityRequest requestedContext. self assert: verifyIdentityRequest operation equals: 'verifyIdentity'. self @@ -431,9 +432,9 @@ MCPRepositorySpecTest >> withRepositories: repositories do: aBlock [ registry := IceRepository registry. previousRepositories := registry copy. [ - registry removeAll. - registry addAll: repositories. - aBlock value ] ensure: [ registry removeAll. - registry addAll: previousRepositories ] + registry addAll: repositories. + aBlock value ] ensure: [ + registry removeAll. + registry addAll: previousRepositories ] ] diff --git a/src/MCP-Tests/MCPTestCase.class.st b/src/MCP-Tests/MCPTestCase.class.st index 1dd9aa0..7c182c9 100644 --- a/src/MCP-Tests/MCPTestCase.class.st +++ b/src/MCP-Tests/MCPTestCase.class.st @@ -25,14 +25,14 @@ MCPTestCase >> classNamed: aClassName [ MCPTestCase >> createClassNamed: aClassName superclassName: aSuperclassName slots: someSlots classSlots: someClassSlots [ ^ self withoutEpiceaDuring: [ - | builder superclass | - superclass := self classNamed: aSuperclassName. - builder := superclass << aClassName asSymbol. - builder package: 'MCP-Tests'. - builder tag: 'Internal'. - builder slots: someSlots. - builder classSlots: someClassSlots. - builder install ] + | builder superclass | + superclass := self classNamed: aSuperclassName. + builder := superclass << aClassName asSymbol. + builder package: 'MCP-Tests'. + builder tag: 'Internal'. + builder slots: someSlots. + builder classSlots: someClassSlots. + builder install ] ] { #category : 'private - methods' } @@ -56,24 +56,24 @@ MCPTestCase >> removeClassNamed: aClassName [ | classSymbol | classSymbol := aClassName asSymbol. self withoutEpiceaDuring: [ - (Smalltalk globals includesKey: classSymbol) ifTrue: [ - (Smalltalk globals at: classSymbol) removeFromSystem ] ] + (Smalltalk globals includesKey: classSymbol) ifTrue: [ + (Smalltalk globals at: classSymbol) removeFromSystem ] ] ] { #category : 'private - packages' } MCPTestCase >> removePackageNamed: aPackageName [ self withoutEpiceaDuring: [ - (PackageOrganizer default hasPackage: aPackageName) ifTrue: [ - PackageOrganizer default removePackage: aPackageName ] ] + (PackageOrganizer default hasPackage: aPackageName) ifTrue: [ + PackageOrganizer default removePackage: aPackageName ] ] ] { #category : 'private - methods' } MCPTestCase >> removeSelector: aSelector from: aBehavior [ self withoutEpiceaDuring: [ - (aBehavior includesSelector: aSelector) ifTrue: [ - aBehavior removeSelector: aSelector ] ] + (aBehavior includesSelector: aSelector) ifTrue: [ + aBehavior removeSelector: aSelector ] ] ] { #category : 'private - execution' } diff --git a/src/MCP-Tests/MCPTestIceRepository.class.st b/src/MCP-Tests/MCPTestIceRepository.class.st index 5d261ec..5d9b88e 100644 --- a/src/MCP-Tests/MCPTestIceRepository.class.st +++ b/src/MCP-Tests/MCPTestIceRepository.class.st @@ -266,10 +266,10 @@ MCPTestIceRepository >> remoteNames: aCollection [ MCPTestIceRepository >> remotes [ ^ self remoteNames collect: [ :each | - MCPTestRepositoryRemote - named: each - repository: self - shouldFail: self failFetch ] + MCPTestRepositoryRemote + named: each + repository: self + shouldFail: self failFetch ] ] { #category : 'private' } diff --git a/src/MCP-Tests/MCPToolChangeHistoryTest.class.st b/src/MCP-Tests/MCPToolChangeHistoryTest.class.st index bc397f2..026b0fa 100644 --- a/src/MCP-Tests/MCPToolChangeHistoryTest.class.st +++ b/src/MCP-Tests/MCPToolChangeHistoryTest.class.st @@ -25,15 +25,18 @@ MCPToolChangeHistoryTest >> callToolWith: someArguments [ toolClass := Dictionary new at: 'listFiles' put: MCPToolListChangeHistoryFiles; at: 'listEntries' put: MCPToolListChangeHistoryEntries; - at: 'applyEntries' put: MCPToolApplyChangeHistoryEntries; - at: 'revertEntries' put: MCPToolRevertChangeHistoryEntries; + at: 'applyEntries' + put: MCPToolApplyChangeHistoryEntries; + at: 'revertEntries' + put: MCPToolRevertChangeHistoryEntries; at: action - ifAbsent: [ Error signal: 'Unknown change history action: ' , action asString ]. + ifAbsent: [ + Error signal: + 'Unknown change history action: ' , action asString ]. tool := toolClass new. request := tool requestFromToolCallArguments: arguments. result := tool executeWithRequest: request. ^ result asJRPCJSON - ] { #category : 'private' } @@ -56,8 +59,8 @@ MCPToolChangeHistoryTest >> latestRecoverableMethodEntryIndexFor: aClass [ | foundIndex | EpMonitor current log refresh. EpMonitor current log entries doWithIndex: [ :entry :index | - (self isRecoverableMethodEntry: entry forClass: aClass) ifTrue: [ - foundIndex := index ] ]. + (self isRecoverableMethodEntry: entry forClass: aClass) ifTrue: [ + foundIndex := index ] ]. foundIndex ifNil: [ self fail: 'Expected recoverable method entry in change history.' ]. ^ foundIndex @@ -67,9 +70,9 @@ MCPToolChangeHistoryTest >> latestRecoverableMethodEntryIndexFor: aClass [ MCPToolChangeHistoryTest >> recordMethodAdditionOn: aClass [ ^ PharoCompatibility withNonInteractiveAuthorNamed: 'MCP' during: [ - aClass compile: 'rescuedValue ^ 42' classified: 'testing'. - EpMonitor current sessionStore flush. - self latestRecoverableMethodEntryIndexFor: aClass ] + aClass compile: 'rescuedValue ^ 42' classified: 'testing'. + EpMonitor current sessionStore flush. + self latestRecoverableMethodEntryIndexFor: aClass ] ] { #category : 'private' } @@ -85,41 +88,41 @@ MCPToolChangeHistoryTest >> recordRecoverableMethodAdditionOn: aClass [ MCPToolChangeHistoryTest >> testApplyEntriesAppliesConfirmedChanges [ self withTemporaryRecoveryClassDo: [ :class | - | data entryIndex result | - entryIndex := self recordRecoverableMethodAdditionOn: class. - self deny: (class includesSelector: #rescuedValue). - result := self callToolWith: { - (#action -> 'applyEntries'). - (#indexes -> { entryIndex }). - (#confirm -> true) } asDictionary. - data := self dataFrom: result. - self deny: (result at: #isError ifAbsent: [ false ]). - self assert: (data at: #action) equals: 'apply'. - self assert: (data at: #performed). - self assert: (data at: #performedCount) equals: 1. - self assert: (class includesSelector: #rescuedValue). - self - assert: (class >> #rescuedValue) sourceCode - equals: 'rescuedValue ^ 42' ] + | data entryIndex result | + entryIndex := self recordRecoverableMethodAdditionOn: class. + self deny: (class includesSelector: #rescuedValue). + result := self callToolWith: { + (#action -> 'applyEntries'). + (#indexes -> { entryIndex }). + (#confirm -> true) } asDictionary. + data := self dataFrom: result. + self deny: (result at: #isError ifAbsent: [ false ]). + self assert: (data at: #action) equals: 'apply'. + self assert: (data at: #performed). + self assert: (data at: #performedCount) equals: 1. + self assert: (class includesSelector: #rescuedValue). + self + assert: (class >> #rescuedValue) sourceCode + equals: 'rescuedValue ^ 42' ] ] { #category : 'tests' } MCPToolChangeHistoryTest >> testApplyEntriesPreviewsChanges [ self withTemporaryRecoveryClassDo: [ :class | - | data entryIndex previewEntry result | - entryIndex := self recordRecoverableMethodAdditionOn: class. - result := self callToolWith: { - (#action -> 'applyEntries'). - (#indexes -> { entryIndex }) } asDictionary. - data := self dataFrom: result. - self deny: (result at: #isError ifAbsent: [ false ]). - self assert: (data at: #action) equals: 'apply'. - self assert: (data at: #selectedCount) equals: 1. - self assert: (data at: #previewCount) equals: 1. - self deny: (data at: #performed). - previewEntry := (data at: #previewEntries) first. - self assert: (previewEntry at: #selector) equals: 'rescuedValue' ] + | data entryIndex previewEntry result | + entryIndex := self recordRecoverableMethodAdditionOn: class. + result := self callToolWith: { + (#action -> 'applyEntries'). + (#indexes -> { entryIndex }) } asDictionary. + data := self dataFrom: result. + self deny: (result at: #isError ifAbsent: [ false ]). + self assert: (data at: #action) equals: 'apply'. + self assert: (data at: #selectedCount) equals: 1. + self assert: (data at: #previewCount) equals: 1. + self deny: (data at: #performed). + previewEntry := (data at: #previewEntries) first. + self assert: (previewEntry at: #selector) equals: 'rescuedValue' ] ] { #category : 'tests' } @@ -171,20 +174,20 @@ MCPToolChangeHistoryTest >> testApplyEntriesRequiresSelectionCriteria [ MCPToolChangeHistoryTest >> testApplyEntriesWithoutConfirmOnlyPreviews [ self withTemporaryRecoveryClassDo: [ :class | - | data entryIndex result | - entryIndex := self recordRecoverableMethodAdditionOn: class. - self deny: (class includesSelector: #rescuedValue). - result := self callToolWith: { - (#action -> 'applyEntries'). - (#indexes -> { entryIndex }). - (#confirm -> false) } asDictionary. - data := self dataFrom: result. - self deny: (result at: #isError ifAbsent: [ false ]). - self assert: (data at: #action) equals: 'apply'. - self deny: (data at: #performed). - self assert: (data at: #performedCount) equals: 0. - self assert: (data at: #previewCount) equals: 1. - self deny: (class includesSelector: #rescuedValue) ] + | data entryIndex result | + entryIndex := self recordRecoverableMethodAdditionOn: class. + self deny: (class includesSelector: #rescuedValue). + result := self callToolWith: { + (#action -> 'applyEntries'). + (#indexes -> { entryIndex }). + (#confirm -> false) } asDictionary. + data := self dataFrom: result. + self deny: (result at: #isError ifAbsent: [ false ]). + self assert: (data at: #action) equals: 'apply'. + self deny: (data at: #performed). + self assert: (data at: #performedCount) equals: 0. + self assert: (data at: #previewCount) equals: 1. + self deny: (class includesSelector: #rescuedValue) ] ] { #category : 'tests' } @@ -370,19 +373,19 @@ MCPToolChangeHistoryTest >> testNonCodeEntryDictionaryOmitsAbsentFields [ MCPToolChangeHistoryTest >> testRevertEntriesRevertsConfirmedChanges [ self withTemporaryRecoveryClassDo: [ :class | - | data entryIndex result | - entryIndex := self recordMethodAdditionOn: class. - self assert: (class includesSelector: #rescuedValue). - result := self callToolWith: { - (#action -> 'revertEntries'). - (#indexes -> { entryIndex }). - (#confirm -> true) } asDictionary. - data := self dataFrom: result. - self deny: (result at: #isError ifAbsent: [ false ]). - self assert: (data at: #action) equals: 'revert'. - self assert: (data at: #performed). - self assert: (data at: #performedCount) equals: 1. - self deny: (class includesSelector: #rescuedValue) ] + | data entryIndex result | + entryIndex := self recordMethodAdditionOn: class. + self assert: (class includesSelector: #rescuedValue). + result := self callToolWith: { + (#action -> 'revertEntries'). + (#indexes -> { entryIndex }). + (#confirm -> true) } asDictionary. + data := self dataFrom: result. + self deny: (result at: #isError ifAbsent: [ false ]). + self assert: (data at: #action) equals: 'revert'. + self assert: (data at: #performed). + self assert: (data at: #performedCount) equals: 1. + self deny: (class includesSelector: #rescuedValue) ] ] { #category : 'tests' } @@ -412,7 +415,6 @@ MCPToolChangeHistoryTest >> testSelectionResultRequestsImageSaveOnlyAfterPerform emptyConfirmedResult). self assert: (tool shouldSaveImageAfterSuccessfulExecutionForResult: confirmedResult) - ] { #category : 'private - calling' } diff --git a/src/MCP-Tests/MCPToolClassMutationTest.class.st b/src/MCP-Tests/MCPToolClassMutationTest.class.st index 8953dc7..02ab439 100644 --- a/src/MCP-Tests/MCPToolClassMutationTest.class.st +++ b/src/MCP-Tests/MCPToolClassMutationTest.class.st @@ -19,8 +19,8 @@ MCPToolClassMutationTest >> aroundToolCall: aBlock [ MCPToolClassMutationTest >> assertIncludesReferencedSlotWarning: warningMessages [ self assert: (warningMessages anySatisfy: [ :each | - (each includesSubstring: 'referencedSlot') and: [ - each includesSubstring: 'referenced' ] ]) + (each includesSubstring: 'referencedSlot') and: [ + each includesSubstring: 'referenced' ] ]) ] { #category : 'private - calling' } @@ -28,7 +28,7 @@ MCPToolClassMutationTest >> callToolWith: someArguments [ | arguments request result slotAction tool toolClass | arguments := someArguments copy. - arguments removeKey: #action ifAbsent: [ ]. + arguments removeKey: #action ifAbsent: [ ]. slotAction := arguments removeKey: #slotAction ifAbsent: [ nil ]. toolClass := self classToolClassForArguments: arguments @@ -42,22 +42,36 @@ MCPToolClassMutationTest >> callToolWith: someArguments [ { #category : 'private - calling' } MCPToolClassMutationTest >> classToolClassForArguments: arguments slotAction: slotAction [ - ((arguments includesKey: #superclassName) and: [ arguments includesKey: #packageName ]) ifTrue: [ ^ MCPToolCreateClass ]. + ((arguments includesKey: #superclassName) and: [ + arguments includesKey: #packageName ]) ifTrue: [ + ^ MCPToolCreateClass ]. slotAction = 'add' ifTrue: [ ^ MCPToolAddClassSlot ]. slotAction = 'remove' ifTrue: [ ^ MCPToolRemoveClassSlot ]. slotAction = 'rename' ifTrue: [ ^ MCPToolUpdateClassSlotName ]. slotAction = 'pullUp' ifTrue: [ ^ MCPToolPullUpClassSlot ]. slotAction = 'pushDown' ifTrue: [ ^ MCPToolPushDownClassSlot ]. - (arguments includesKey: #newClassName) ifTrue: [ ^ MCPToolUpdateClassName ]. - (arguments includesKey: #classComment) ifTrue: [ ^ MCPToolUpdateClassComment ]. - (arguments includesKey: #traits) ifTrue: [ ^ MCPToolUpdateClassTraits ]. - (arguments includesKey: #classTraits) ifTrue: [ ^ MCPToolUpdateClassSideTraits ]. - (arguments includesKey: #sharedVariables) ifTrue: [ ^ MCPToolUpdateClassSharedVariables ]. - (arguments includesKey: #sharedPools) ifTrue: [ ^ MCPToolUpdateClassSharedPools ]. - (arguments includesKey: #layout) ifTrue: [ ^ MCPToolUpdateClassLayout ]. - ((arguments includesKey: #slots) or: [ arguments includesKey: #classSlots ]) ifTrue: [ ^ MCPToolUpdateClassSlots ]. - (arguments includesKey: #superclassName) ifTrue: [ ^ MCPToolUpdateClassSuperclass ]. - ((arguments includesKey: #packageName) or: [ arguments includesKey: #tag ]) ifTrue: [ ^ MCPToolUpdateClassPackage ]. + (arguments includesKey: #newClassName) ifTrue: [ + ^ MCPToolUpdateClassName ]. + (arguments includesKey: #classComment) ifTrue: [ + ^ MCPToolUpdateClassComment ]. + (arguments includesKey: #traits) ifTrue: [ + ^ MCPToolUpdateClassTraits ]. + (arguments includesKey: #classTraits) ifTrue: [ + ^ MCPToolUpdateClassSideTraits ]. + (arguments includesKey: #sharedVariables) ifTrue: [ + ^ MCPToolUpdateClassSharedVariables ]. + (arguments includesKey: #sharedPools) ifTrue: [ + ^ MCPToolUpdateClassSharedPools ]. + (arguments includesKey: #layout) ifTrue: [ + ^ MCPToolUpdateClassLayout ]. + ((arguments includesKey: #slots) or: [ + arguments includesKey: #classSlots ]) ifTrue: [ + ^ MCPToolUpdateClassSlots ]. + (arguments includesKey: #superclassName) ifTrue: [ + ^ MCPToolUpdateClassSuperclass ]. + ((arguments includesKey: #packageName) or: [ + arguments includesKey: #tag ]) ifTrue: [ + ^ MCPToolUpdateClassPackage ]. ^ MCPToolUpdateClassComment ] @@ -89,12 +103,14 @@ MCPToolClassMutationTest >> createRequestArgumentsWith: associations [ { #category : 'private' } MCPToolClassMutationTest >> createdClassNames [ - ^ #( 'MCPToolClassMutationTestGenerated' 'MCPToolClassMutationTestTagged' + ^ #( 'MCPToolClassMutationTestGenerated' + 'MCPToolClassMutationTestTagged' 'MCPToolClassMutationTestClassSlots' 'MCPToolClassMutationTestConfigured' 'MCPToolClassMutationTestTemporaryPackage' 'MCPToolClassMutationTestCommentTarget' - 'MCPToolClassMutationTestCommented' 'MCPToolClassMutationTestReparentTarget' + 'MCPToolClassMutationTestCommented' + 'MCPToolClassMutationTestReparentTarget' 'MCPToolClassMutationTestReparentSuperclass' 'MCPToolClassMutationTestTraitTarget' 'MCPToolClassMutationTestTraitRemovalTarget' @@ -152,10 +168,10 @@ MCPToolClassMutationTest >> destinationTagName [ MCPToolClassMutationTest >> ensureDestinationPackage [ self withoutEpiceaDuring: [ - | package | - package := PackageOrganizer default ensurePackage: - self destinationPackageName. - package ensureTag: self destinationTagName ] + | package | + package := PackageOrganizer default ensurePackage: + self destinationPackageName. + package ensureTag: self destinationTagName ] ] { #category : 'private' } @@ -165,14 +181,14 @@ MCPToolClassMutationTest >> ensureOriginalRenameFixtureState [ originalSymbol := self originalClassName asSymbol. renamedSymbol := self renamedClassName asSymbol. self withoutEpiceaDuring: [ - ((Smalltalk globals includesKey: originalSymbol) and: [ - Smalltalk globals includesKey: renamedSymbol ]) ifTrue: [ - (Smalltalk globals at: renamedSymbol) removeFromSystem ]. - ((Smalltalk globals includesKey: renamedSymbol) and: [ - (Smalltalk globals includesKey: originalSymbol) not ]) ifTrue: [ - (ReRenameClassRefactoring - rename: self renamedClassName - to: self originalClassName) execute ] ] + ((Smalltalk globals includesKey: originalSymbol) and: [ + Smalltalk globals includesKey: renamedSymbol ]) ifTrue: [ + (Smalltalk globals at: renamedSymbol) removeFromSystem ]. + ((Smalltalk globals includesKey: renamedSymbol) and: [ + (Smalltalk globals includesKey: originalSymbol) not ]) ifTrue: [ + (ReRenameClassRefactoring + rename: self renamedClassName + to: self originalClassName) execute ] ] ] { #category : 'private' } @@ -215,21 +231,21 @@ MCPToolClassMutationTest >> referenceClassName [ MCPToolClassMutationTest >> removeDestinationPackage [ self withoutEpiceaDuring: [ - (PackageOrganizer default hasPackage: self destinationPackageName) - ifTrue: [ - PackageOrganizer default removePackage: - (PackageOrganizer default packageNamed: - self destinationPackageName) ] ] + (PackageOrganizer default hasPackage: self destinationPackageName) + ifTrue: [ + PackageOrganizer default removePackage: + (PackageOrganizer default packageNamed: + self destinationPackageName) ] ] ] { #category : 'private' } MCPToolClassMutationTest >> removeGeneratedPackage [ self withoutEpiceaDuring: [ - (self packageOrganizer hasPackage: self generatedPackageName) - ifTrue: [ - self packageOrganizer removePackage: - (self packageOrganizer packageNamed: self generatedPackageName) ] ] + (self packageOrganizer hasPackage: self generatedPackageName) + ifTrue: [ + self packageOrganizer removePackage: + (self packageOrganizer packageNamed: self generatedPackageName) ] ] ] { #category : 'private' } @@ -258,9 +274,9 @@ MCPToolClassMutationTest >> restoreMoveTargetClassLocation [ self currentTagOfMoveTargetClass = 'Uncategorized' ]) ifTrue: [ ^ self ]. self withoutEpiceaDuring: [ - (RBMoveClassTransformation - move: self moveTargetClassName - toPackage: self originalMovePackageName) execute ] + (RBMoveClassTransformation + move: self moveTargetClassName + toPackage: self originalMovePackageName) execute ] ] { #category : 'running' } @@ -396,8 +412,7 @@ MCPToolClassMutationTest >> testCreateAcceptsDefinitionOptions [ as: Array) equals: #( 'ChronologyConstants' ). self assert: createdClass classLayout class name equals: #WeakLayout. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - create' } @@ -419,8 +434,7 @@ MCPToolClassMutationTest >> testCreateAcceptsSlotsAndTag [ self assert: createdClass category asString equals: self generatedPackageName , '-Generated'. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - create' } @@ -439,8 +453,7 @@ MCPToolClassMutationTest >> testCreateCreatesClass [ assert: createdClass packageName asString equals: self generatedPackageName. self assert: createdClass slots isEmpty. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - create' } @@ -544,8 +557,7 @@ MCPToolClassMutationTest >> testCreateSetsClassComment [ createdClass := self classNamed: 'MCPToolClassMutationTestCommented'. self deny: (result at: #isError ifAbsent: [ false ]). self assert: createdClass comment equals: 'Created with a comment.'. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -569,8 +581,7 @@ MCPToolClassMutationTest >> testUpdateAddsClassSideSlot [ self assert: (target classSide slots collect: #name as: Array) equals: #( #addedClassSlot ). - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -593,8 +604,7 @@ MCPToolClassMutationTest >> testUpdateAddsInstanceSlot [ self assert: (target slots collect: #name as: Array) equals: #( #addedSlot ). - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -615,8 +625,7 @@ MCPToolClassMutationTest >> testUpdateCanClearClassComment [ target := self classNamed: self commentTargetClassName. self deny: (result at: #isError ifAbsent: [ false ]). self assert: target comment equals: ''. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -670,8 +679,7 @@ MCPToolClassMutationTest >> testUpdateForcePullUpSlotContinuesPastRefactoringWar self assert: (childOne slots collect: #name as: Array) equals: #( ). self assert: (childTwo slots collect: #name as: Array) equals: #( ). self assert: instance slotProbe equals: 17. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -702,8 +710,7 @@ MCPToolClassMutationTest >> testUpdateForceRemoveSlotContinuesPastRefactoringWar self deny: (result at: #isError ifAbsent: [ false ]). self assertIncludesReferencedSlotWarning: warnings. self assert: (target slots collect: #name as: Array) equals: #( ). - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -720,8 +727,7 @@ MCPToolClassMutationTest >> testUpdateMoveEnsuresMissingDestinationPackage [ self assert: self moveTargetClass packageName asString equals: self destinationPackageName. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -744,8 +750,7 @@ MCPToolClassMutationTest >> testUpdateMoveEnsuresMissingDestinationTag [ self assert: self currentTagOfMoveTargetClass equals: self destinationTagName. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -759,8 +764,7 @@ MCPToolClassMutationTest >> testUpdateMovesClassToAnotherPackage [ self assert: self moveTargetClass packageName asString equals: self destinationPackageName. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -777,8 +781,7 @@ MCPToolClassMutationTest >> testUpdateMovesClassToExistingTag [ self assert: self currentTagOfMoveTargetClass equals: self destinationTagName. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -865,7 +868,8 @@ MCPToolClassMutationTest >> testUpdatePullUpSlotStopsOnRefactoringWarningByDefau classSide: false). structured := self structuredContentFrom: result. error := self errorFrom: result. - target := self classNamed: 'MCPToolClassMutationTestWarningPullUpTarget'. + target := self classNamed: + 'MCPToolClassMutationTestWarningPullUpTarget'. childOne := self classNamed: 'MCPToolClassMutationTestWarningPullUpChildOne'. childTwo := self classNamed: @@ -888,8 +892,8 @@ MCPToolClassMutationTest >> testUpdatePullUpSlotStopsOnRefactoringWarningByDefau self assert: ((error at: #howToProceed) includesSubstring: 'force=true'). self assert: ((error at: #impactMessages) anySatisfy: [ :each | - each includesSubstring: - 'Not all subclasses have an instance variable named' ]). + each includesSubstring: + 'Not all subclasses have an instance variable named' ]). self assert: (target slots collect: #name as: Array) equals: #( ). self assert: (childOne slots collect: #name as: Array) @@ -938,8 +942,7 @@ MCPToolClassMutationTest >> testUpdatePullsUpInstanceSlotAcrossSubclasses [ self assert: (childOne slots collect: #name as: Array) equals: #( ). self assert: (childTwo slots collect: #name as: Array) equals: #( ). self assert: instance slotProbe equals: 41. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -989,8 +992,7 @@ MCPToolClassMutationTest >> testUpdatePushesDownClassSlotToDirectSubclasses [ assert: (childTwo classSide slots collect: #name as: Array) equals: #( #sharedClassSlot ). self assert: childOne slotProbe equals: 23. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1010,8 +1012,7 @@ MCPToolClassMutationTest >> testUpdateRecategorizesWithinCurrentPackageWhenPacka self assert: self currentTagOfMoveTargetClass equals: self destinationTagName. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1026,10 +1027,12 @@ MCPToolClassMutationTest >> testUpdateRemoveSlotStopsOnRefactoringWarningByDefau self ensureMethodSource: 'slotProbe ^ referencedSlot' protocol: 'testing' - on: (self classNamed: 'MCPToolClassMutationTestWarningRemoveSlotTarget'). + on: + (self classNamed: 'MCPToolClassMutationTestWarningRemoveSlotTarget'). result := self callToolWith: (self updateRequestArgumentsForSlotAction: 'remove' - className: 'MCPToolClassMutationTestWarningRemoveSlotTarget' + className: + 'MCPToolClassMutationTestWarningRemoveSlotTarget' slotName: 'referencedSlot' classSide: false). structured := self structuredContentFrom: result. @@ -1055,8 +1058,7 @@ MCPToolClassMutationTest >> testUpdateRemoveSlotStopsOnRefactoringWarningByDefau self assert: (error at: #forceSupported) equals: true. self assert: ((error at: #howToProceed) includesSubstring: 'force=true'). - self assertIncludesReferencedSlotWarning: - (error at: #impactMessages). + self assertIncludesReferencedSlotWarning: (error at: #impactMessages). self assert: (target slots collect: #name as: Array) equals: #( #referencedSlot ) @@ -1084,8 +1086,7 @@ MCPToolClassMutationTest >> testUpdateRemovesClassSideSlot [ self assert: (target classSide slots collect: #name as: Array) equals: #( ). - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1108,8 +1109,7 @@ MCPToolClassMutationTest >> testUpdateRemovesClassSideTraitsWithEmptyArray [ 'MCPToolClassMutationTestClassTraitRemovalTarget'. self deny: (result at: #isError ifAbsent: [ false ]). self assert: targetClass classSide traits isEmpty. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1130,8 +1130,7 @@ MCPToolClassMutationTest >> testUpdateRemovesInstanceSlot [ target := self classNamed: 'MCPToolClassMutationTestRemoveSlotTarget'. self deny: (result at: #isError ifAbsent: [ false ]). self assert: (target slots collect: #name as: Array) equals: #( ). - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1154,8 +1153,7 @@ MCPToolClassMutationTest >> testUpdateRemovesSharedPoolsWithEmptyArray [ 'MCPToolClassMutationTestSharedPoolRemovalTarget'. self deny: (result at: #isError ifAbsent: [ false ]). self assert: targetClass sharedPools isEmpty. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1178,8 +1176,7 @@ MCPToolClassMutationTest >> testUpdateRemovesSharedVariablesWithEmptyArray [ 'MCPToolClassMutationTestSharedVariableRemovalTarget'. self deny: (result at: #isError ifAbsent: [ false ]). self assert: targetClass classVarNames isEmpty. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1202,8 +1199,7 @@ MCPToolClassMutationTest >> testUpdateRemovesTraitsWithEmptyArray [ 'MCPToolClassMutationTestTraitRemovalTarget'. self deny: (result at: #isError ifAbsent: [ false ]). self assert: targetClass traits isEmpty. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1283,8 +1279,7 @@ MCPToolClassMutationTest >> testUpdateRenamesClassAndReturnsStructuredData [ (Smalltalk globals includesKey: self renamedClassName asSymbol). self deny: (Smalltalk globals includesKey: self originalClassName asSymbol). - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1333,8 +1328,7 @@ MCPToolClassMutationTest >> testUpdateRenamesClassSideSlotAndPreservesValue [ self assert: target renamedClassSlot equals: 73. target renamedClassSlot: 91. self assert: target slotProbe equals: 91. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1378,8 +1372,7 @@ MCPToolClassMutationTest >> testUpdateRenamesInstanceSlotAndUpdatesReferences [ self assert: (target includesSelector: #renamedSlot:). self assert: instance renamedSlot equals: 37. self assert: instance slotProbe equals: 37. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1412,8 +1405,7 @@ MCPToolClassMutationTest >> testUpdateReparentsClassAndPreservesExistingState [ equals: self reparentSuperclassName. self assert: target new probeMethod equals: 41. self assert: target comment equals: 'reparent comment'. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1443,8 +1435,7 @@ MCPToolClassMutationTest >> testUpdateReplacesClassSideTraits [ self assert: targetClass classSide traitCompositionString equals: 'TComparable classTrait'. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1465,8 +1456,7 @@ MCPToolClassMutationTest >> testUpdateReplacesLayout [ 'MCPToolClassMutationTestLayoutTarget'. self deny: (result at: #isError ifAbsent: [ false ]). self assert: targetClass classLayout class name equals: #WeakLayout. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1493,8 +1483,7 @@ MCPToolClassMutationTest >> testUpdateReplacesSharedPools [ collect: [ :each | each name asString ] as: Array) equals: #( 'TextConstants' ). - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1517,8 +1506,7 @@ MCPToolClassMutationTest >> testUpdateReplacesSharedVariables [ 'MCPToolClassMutationTestSharedVariableTarget'. self deny: (result at: #isError ifAbsent: [ false ]). self assert: targetClass classVarNames equals: #( #BetaShared ). - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1550,8 +1538,7 @@ MCPToolClassMutationTest >> testUpdateReplacesSlotDefinitionAndPreservesMatching equals: #( #keptClassSlot #newClassSlot ). self assert: (instance instVarNamed: 'keptSlot') equals: 13. self assert: (target instVarNamed: 'keptClassSlot') equals: 17. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1582,8 +1569,7 @@ MCPToolClassMutationTest >> testUpdateReplacesTraits [ self assert: targetClass classSide traitCompositionString equals: 'TComparable classTrait'. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests - update' } @@ -1945,8 +1931,7 @@ MCPToolClassMutationTest >> testUpdateSetsClassComment [ target := self classNamed: self commentTargetClassName. self deny: (result at: #isError ifAbsent: [ false ]). self assert: target comment equals: 'updated comment'. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'private - calling' } diff --git a/src/MCP-Tests/MCPToolContractsTest.class.st b/src/MCP-Tests/MCPToolContractsTest.class.st index 7636de0..65c08b6 100644 --- a/src/MCP-Tests/MCPToolContractsTest.class.st +++ b/src/MCP-Tests/MCPToolContractsTest.class.st @@ -9,6 +9,41 @@ Class { #tag : 'Tools' } +{ #category : 'private' } +MCPToolContractsTest >> addSelfSentNotImplementedCritiquesFrom: aMethod using: aRule to: issues [ + + aRule check: aMethod forCritiquesDo: [ :critique | + issues add: (String streamContents: [ :stream | + stream + nextPutAll: aMethod methodClass name asString; + nextPutAll: '>>'; + nextPutAll: aMethod selector asString. + critique tinyHint ifNotNil: [ :hint | + stream + space; + nextPutAll: hint asString ] ]) ] +] + +{ #category : 'private' } +MCPToolContractsTest >> addUnimplementedResponsibilitiesFor: aClass behavior: aBehavior side: sideName to: issues [ + + aBehavior allSelectors do: [ :selector | + | method | + selector = #subclassResponsibility ifFalse: [ + method := aBehavior lookupSelector: selector. + (method notNil and: [ + self methodSendsSubclassResponsibility: method ]) ifTrue: [ + issues add: (String streamContents: [ :stream | + stream + nextPutAll: aClass name asString; + space; + nextPutAll: sideName; + nextPutAll: ' #'; + nextPutAll: selector asString; + nextPutAll: ' inherited from '; + nextPutAll: method methodClass name asString ]) ] ] ] +] + { #category : 'private' } MCPToolContractsTest >> assertDebugInputPropertyNamed: propertyName inTool: aTool default: defaultValue maximum: maximumValue [ @@ -35,19 +70,19 @@ MCPToolContractsTest >> assertNoCompositionKeywordsIn: aValue path: path [ | compositionKeywords | compositionKeywords := #( oneOf anyOf allOf ). aValue isDictionary ifTrue: [ - compositionKeywords do: [ :keyword | - self deny: (aValue includesKey: keyword). - self deny: (aValue includesKey: keyword asString) ]. - aValue keysAndValuesDo: [ :key :nestedValue | - self - assertNoCompositionKeywordsIn: nestedValue - path: (path copyWith: key) ]. - ^ self ]. + compositionKeywords do: [ :keyword | + self deny: (aValue includesKey: keyword). + self deny: (aValue includesKey: keyword asString) ]. + aValue keysAndValuesDo: [ :key :nestedValue | + self + assertNoCompositionKeywordsIn: nestedValue + path: (path copyWith: key) ]. + ^ self ]. (aValue isCollection and: [ aValue isString not ]) ifTrue: [ - aValue withIndexDo: [ :nestedValue :index | - self - assertNoCompositionKeywordsIn: nestedValue - path: (path copyWith: index) ] ] + aValue withIndexDo: [ :nestedValue :index | + self + assertNoCompositionKeywordsIn: nestedValue + path: (path copyWith: index) ] ] ] { #category : 'private' } @@ -129,9 +164,8 @@ MCPToolContractsTest >> baseToolFlowSpecs [ (#commandClass -> MCPRemoveMethodsCommand) } asDictionary. { (#toolClass -> MCPToolRunTests). - (#arguments -> { (#tests - -> { { (#className -> 'MCPToolContractsTest') } asDictionary }) } - asDictionary). + (#arguments + -> { (#classes -> { 'MCPToolContractsTest' }) } asDictionary). (#requestClass -> MCPRunTestsRequest). (#commandClass -> MCPRunTestsCommand) } asDictionary. { @@ -192,7 +226,6 @@ MCPToolContractsTest >> baseToolFlowSpecs [ (#arguments -> Dictionary new) } asDictionary). (#requestClass -> MCPCallToolRequest). (#commandClass -> MCPCallToolCommand) } asDictionary } - ] { #category : 'private' } @@ -382,8 +415,7 @@ MCPToolContractsTest >> coverageToolFlowSpec [ ^ { (#toolClass -> MCPToolRunTestCoverage). (#arguments -> { - (#tests - -> { { (#className -> 'MCPToolContractsTest') } asDictionary }). + (#classes -> { 'MCPToolContractsTest' }). (#coverage -> { (#scope -> { (#classes -> #( 'MCPToolContractsTest' )) } asDictionary) } asDictionary) } asDictionary). @@ -610,6 +642,17 @@ MCPToolContractsTest >> methodMutationToolFlowSpecs [ (#commandClass -> MCPUpdateMethodCommand) } asDictionary } ] +{ #category : 'private' } +MCPToolContractsTest >> methodSendsSubclassResponsibility: aCompiledMethod [ + + (aCompiledMethod sendsSelector: #subclassResponsibility) ifFalse: [ + ^ false ]. + aCompiledMethod ast nodesDo: [ :node | + (node isMessage and: [ node selector = #subclassResponsibility ]) + ifTrue: [ ^ true ] ]. + ^ false +] + { #category : 'private' } MCPToolContractsTest >> repositoryToolFlowSpecs [ @@ -706,6 +749,27 @@ MCPToolContractsTest >> repositoryToolFlowSpecs [ (#commandClass -> MCPAdoptRepositoryHeadCommand) } asDictionary } ] +{ #category : 'private' } +MCPToolContractsTest >> selfSentNotImplementedCritiquesForMCPMethods [ + + | issues package rule | + rule := ReSelfSentNotImplementedRule new. + package := PackageOrganizer default packageNamed: #MCP. + issues := OrderedCollection new. + package definedClasses do: [ :class | + class localMethods do: [ :method | + self + addSelfSentNotImplementedCritiquesFrom: method + using: rule + to: issues ]. + class class localMethods do: [ :method | + self + addSelfSentNotImplementedCritiquesFrom: method + using: rule + to: issues ] ]. + ^ issues asArray sort +] + { #category : 'private' } MCPToolContractsTest >> signalHaltForMCPMessageProcessorTest [ @@ -716,8 +780,8 @@ MCPToolContractsTest >> signalHaltForMCPMessageProcessorTest [ MCPToolContractsTest >> testAllToolInputSchemasAvoidCompositionKeywords [ MCPTool concreteSubclasses do: [ :toolClass | - self assertNoCompositionKeywordsIn: - (toolClass new asJRPCJSON at: #inputSchema) ] + self assertNoCompositionKeywordsIn: + (toolClass new asJRPCJSON at: #inputSchema) ] ] { #category : 'tests' } @@ -1104,17 +1168,30 @@ MCPToolContractsTest >> testClassToolsOutputSchemaAdvertisesMinimalMutationResul | dataProperties outputSchema | outputSchema := MCPToolUpdateClassName new outputSchema asJRPCJSON. - dataProperties := ((outputSchema at: #properties) at: 'data') at: #properties. + dataProperties := ((outputSchema at: #properties) at: 'data') at: + #properties. self assert: dataProperties isEmpty ] +{ #category : 'tests' } +MCPToolContractsTest >> testConcreteMCPClassesHaveNoUnimplementedResponsibilities [ + + | issues | + issues := self unimplementedResponsibilitiesForConcreteMCPClasses. + self + assert: issues isEmpty + description: (String streamContents: [ :stream | + issues + do: [ :each | stream nextPutAll: each ] + separatedBy: [ stream cr ] ]) +] + { #category : 'tests' } MCPToolContractsTest >> testConfiguredDiscoverableToolsAreNotDirectlyCallable [ | server | server := self mcpWithoutObservabilityExport. - server staticToolNames: - #( 'tool_search' 'tool_get' 'tool_call' ). + server staticToolNames: #( 'tool_search' 'tool_get' 'tool_call' ). self should: [ server @@ -1220,10 +1297,8 @@ MCPToolContractsTest >> testDictionaryShapedCommandResultsUseDTOClasses [ | commandResultClasses | commandResultClasses := { (MCPEvaluateCommand -> MCPEvaluateResult). - (MCPGetClassCommand - -> MCPGetClassResult). - (MCPGetMethodCommand - -> MCPGetMethodResult). + (MCPGetClassCommand -> MCPGetClassResult). + (MCPGetMethodCommand -> MCPGetMethodResult). (MCPRewriteMethodsCommand -> MCPMethodRewriteReport). (MCPRemoveMethodsCommand @@ -1625,6 +1700,19 @@ MCPToolContractsTest >> testInputSchemaJSONOmitsDefaultSchemaNoise [ self assert: (schema at: #additionalProperties) equals: false ] +{ #category : 'tests' } +MCPToolContractsTest >> testMCPMethodsHaveImplementedSelfAndSuperSends [ + + | issues | + issues := self selfSentNotImplementedCritiquesForMCPMethods. + self + assert: issues isEmpty + description: (String streamContents: [ :stream | + issues + do: [ :each | stream nextPutAll: each ] + separatedBy: [ stream cr ] ]) +] + { #category : 'tests' } MCPToolContractsTest >> testMethodMetadataSearchDescriptionPointsToSpecializedReferenceTools [ @@ -1755,18 +1843,31 @@ MCPToolContractsTest >> testMethodMutationSchemaAdvertisesOnlyNonInputOutcomes [ | argumentNamesProperty argumentValuesProperty dataProperties dataProperty permutationProperty propertyNames tool toolPropertyNames | tool := MCPToolUpdateMethodSelector new. - toolPropertyNames := tool inputSchema properties collect: [ :each | each name ]. - permutationProperty := tool inputSchema properties detect: [ :each | each name = 'permutation' ]. - argumentNamesProperty := tool inputSchema properties detect: [ :each | each name = 'argumentNames' ]. - argumentValuesProperty := tool inputSchema properties detect: [ :each | each name = 'argumentValueExpressions' ]. - dataProperty := tool outputSchema properties detect: [ :each | each name = 'data' ]. + toolPropertyNames := tool inputSchema properties collect: [ :each | + each name ]. + permutationProperty := tool inputSchema properties detect: [ :each | + each name = 'permutation' ]. + argumentNamesProperty := tool inputSchema properties detect: [ :each | + each name = 'argumentNames' ]. + argumentValuesProperty := tool inputSchema properties detect: [ :each | + each name = 'argumentValueExpressions' ]. + dataProperty := tool outputSchema properties detect: [ :each | + each name = 'data' ]. dataProperties := dataProperty extraProperties at: #properties. propertyNames := dataProperties collect: [ :each | each name ]. self deny: (toolPropertyNames includes: 'action'). - self assert: (permutationProperty extraProperties at: #items) type equals: 'integer'. - self assert: (argumentNamesProperty extraProperties at: #items) type equals: 'string'. - self assert: (argumentValuesProperty extraProperties at: #items) type equals: 'string'. - self assert: propertyNames asSet equals: #( 'changeKind' 'critiques' ) asSet + self + assert: (permutationProperty extraProperties at: #items) type + equals: 'integer'. + self + assert: (argumentNamesProperty extraProperties at: #items) type + equals: 'string'. + self + assert: (argumentValuesProperty extraProperties at: #items) type + equals: 'string'. + self + assert: propertyNames asSet + equals: #( 'changeKind' 'critiques' ) asSet ] { #category : 'tests' } @@ -1815,6 +1916,7 @@ MCPToolContractsTest >> testMethodToolTraitOwnsSharedMethodHelpers [ methodToolClasses := { MCPToolGetMethod. MCPToolMethodMutation. + MCPToolMethodSearch. MCPToolRewriteMethods. MCPToolRemoveMethods }. sharedSelectors := #( selectorStringFromRequest: @@ -1822,13 +1924,6 @@ MCPToolContractsTest >> testMethodToolTraitOwnsSharedMethodHelpers [ methodReferenceForBehavior:selector: methodReferenceForClassName:selector:isClassSide: methodScopeQueryFromRequest: ). - self assert: - (MCPToolMethodSearch withAllSuperclasses anySatisfy: [ :each | - each traits includes: TMCPMethodTool ]). - self - assert: - (MCPToolMethodSearch >> #methodScopeQueryFromRequest:) origin - equals: MCPToolMethodSearch. methodToolClasses do: [ :toolClass | self assert: (toolClass withAllSuperclasses anySatisfy: [ :each | each traits includes: TMCPMethodTool ]). @@ -1845,8 +1940,8 @@ MCPToolContractsTest >> testMethodToolTraitOwnsSharedMethodHelpers [ { #category : 'tests' } MCPToolContractsTest >> testMutatingToolsRequestImageSaveAfterSuccessfulExecution [ - self deny: - MCPToolSearchMethodMetadata new shouldSaveImageAfterSuccessfulExecution. + self deny: MCPToolSearchMethodMetadata new + shouldSaveImageAfterSuccessfulExecution. self deny: MCPToolGetClass new shouldSaveImageAfterSuccessfulExecution. self assert: @@ -1867,7 +1962,6 @@ MCPToolContractsTest >> testMutatingToolsRequestImageSaveAfterSuccessfulExecutio MCPToolRemoveMethods new shouldSaveImageAfterSuccessfulExecution. self assert: MCPToolEvaluate new shouldSaveImageAfterSuccessfulExecution - ] { #category : 'tests' } @@ -2052,6 +2146,7 @@ MCPToolContractsTest >> testOutputDtoClassesUseResultInfoOrReportSuffixes [ | dtoClasses invalidNames suffixes | dtoClasses := (self mcpClassesInPackageTagNamed: 'DTOs') , (self mcpClassesInPackageTagNamed: 'Results'). + dtoClasses := dtoClasses reject: [ :each | each isAbstract ]. suffixes := #( 'Result' 'Info' 'Report' ). invalidNames := dtoClasses reject: [ :each | suffixes anySatisfy: [ :suffix | @@ -2162,8 +2257,8 @@ MCPToolContractsTest >> testQueryScopeDescriptionsExplainScopeSemantics [ MCPToolContractsTest >> testRPCAdvertisesStaticToolSurfaceOnly [ | discoverableToolNames expectedStaticToolNames toolNames | - toolNames := (self mcpWithoutObservabilityExport rpcToolsList at: #tools) collect: [ :each | - each at: #name ]. + toolNames := (self mcpWithoutObservabilityExport rpcToolsList at: + #tools) collect: [ :each | each at: #name ]. expectedStaticToolNames := #( 'tool_search' 'tool_get' 'tool_call' 'package_search' 'class_search' 'class_get' 'class_create' @@ -2432,9 +2527,9 @@ MCPToolContractsTest >> testRpcToolCallRejectsLegacyScopeArgument [ self should: [ - self - callToolNamed: 'class_search' - withArguments: { (#scope -> 'packages') } asDictionary ] + self + callToolNamed: 'class_search' + withArguments: { (#scope -> 'packages') } asDictionary ] raise: JRPCInvalidParameters ] @@ -2446,7 +2541,8 @@ MCPToolContractsTest >> testRpcToolCallSignalsInvalidParametersForInvalidNestedA self callToolNamed: 'test_run' withArguments: - { (#tests -> #( 'MCPToolContractsTest' )) } asDictionary ] + { (#methods -> { { (#selector -> 'testPasses') } asDictionary }) } + asDictionary ] raise: JRPCInvalidParameters ] @@ -2466,9 +2562,9 @@ MCPToolContractsTest >> testRpcToolCallSignalsInvalidParametersForWrongArgumentT self should: [ - self - callToolNamed: 'class_search' - withArguments: { (#caseSensitive -> 'true') } asDictionary ] + self + callToolNamed: 'class_search' + withArguments: { (#caseSensitive -> 'true') } asDictionary ] raise: JRPCInvalidParameters ] @@ -2477,22 +2573,19 @@ MCPToolContractsTest >> testRpcToolCallSignalsInvalidParametersWhenRequiredArgum self should: [ - self - callDiscoveredToolNamed: 'image_evaluate' - withArguments: Dictionary new ] + self + callDiscoveredToolNamed: 'image_evaluate' + withArguments: Dictionary new ] raise: JRPCInvalidParameters ] { #category : 'tests' } -MCPToolContractsTest >> testRunTestCoverageUsesNestedRequestDTOs [ +MCPToolContractsTest >> testRunTestCoverageParsesCompactSelections [ | command parsedRequest rawRequest tool validatedRequests | tool := MCPToolRunTestCoverage new. rawRequest := tool requestFromToolCallArguments: { - (#tests - -> - { { (#className -> 'MCPToolContractsTest') } - asDictionary }). + (#classes -> #( 'MCPToolContractsTest' )). (#coverage -> { (#scope -> { (#classes -> #( 'MCPToolContractsTest' )) } @@ -2520,144 +2613,160 @@ MCPToolContractsTest >> testRunTestCoverageUsesNestedRequestDTOs [ { #category : 'tests' } MCPToolContractsTest >> testRunTestToolsHaveAccurateNamesAndRequiredArguments [ - | coverageInputProperties coverageInputProperty coverageScopeProperty coverageScopePropertyNames coverageTool inputPropertyNames methodLimitProperty outputSchema dataProperties resultsProperty timeoutMillisecondsProperty tool | + | coverageDataProperties coverageInputProperties coverageInputProperty coverageTool dataProperties inputPropertyNames outputSchema tool | tool := MCPToolRunTests new. self assert: tool name equals: 'test_run'. - self - assert: tool inputSchema required asSet - equals: #( 'tests' ) asSet. - self deny: (tool inputSchema extraProperties includesKey: #oneOf). + self assert: (tool inputSchema required ifNil: [ #( ) ]) isEmpty. inputPropertyNames := tool inputSchema properties collect: [ :each | each name ]. - timeoutMillisecondsProperty := tool inputSchema properties detect: [ - :each | - each name = 'timeoutMilliseconds' ]. - self deny: (inputPropertyNames includes: 'operation'). - self deny: (inputPropertyNames includes: 'coverage'). - self assert: (inputPropertyNames includes: 'timeoutSeconds'). - self assert: (inputPropertyNames includes: 'timeoutMilliseconds'). self - assert: timeoutMillisecondsProperty description - equals: 'Timeout in milliseconds.'. + assert: inputPropertyNames asSet + equals: #( 'packages' 'classes' 'methods' 'timeoutSeconds' ) asSet. + self deny: (inputPropertyNames includes: 'tests'). + self deny: (inputPropertyNames includes: 'timeoutMilliseconds'). + self deny: (inputPropertyNames includes: 'coverage'). outputSchema := tool outputSchema asJRPCJSON. dataProperties := ((outputSchema at: #properties) at: 'data') at: #properties. - resultsProperty := dataProperties at: 'results'. - self assert: (resultsProperty at: #type) equals: 'array'. - self - assert: ((resultsProperty at: #items) at: #type) - equals: 'object'. + self assert: (dataProperties includesKey: 'runCount'). + self assert: (dataProperties includesKey: 'passedCount'). + self assert: (dataProperties includesKey: 'skipped'). + self assert: (dataProperties includesKey: 'failures'). + self assert: (dataProperties includesKey: 'errors'). + self assert: (dataProperties includesKey: 'unrunPackages'). + self assert: (dataProperties includesKey: 'unrunClasses'). + self assert: (dataProperties includesKey: 'unrunMethods'). + self deny: (dataProperties includesKey: 'results'). self deny: (dataProperties includesKey: 'coverage'). - self deny: (dataProperties includesKey: 'tests'). + coverageTool := MCPToolRunTestCoverage new. self assert: coverageTool name equals: 'test_coverage_run'. self assert: coverageTool inputSchema required asSet - equals: #( 'tests' 'coverage' ) asSet. + equals: #( 'coverage' ) asSet. inputPropertyNames := coverageTool inputSchema properties collect: [ :each | each name ]. + self + assert: inputPropertyNames asSet + equals: + #( 'packages' 'classes' 'methods' 'coverage' 'timeoutSeconds' ) + asSet. + self deny: (inputPropertyNames includes: 'tests'). + self deny: (inputPropertyNames includes: 'timeoutMilliseconds'). coverageInputProperty := coverageTool inputSchema properties detect: [ :each | each name = 'coverage' ]. - coverageInputProperties := coverageInputProperty extraProperties at: + coverageInputProperties := coverageInputProperty asJRPCJSON at: #properties. - methodLimitProperty := coverageInputProperties detect: [ :each | - each name = 'methodLimit' ]. - self deny: (inputPropertyNames includes: 'operation'). - self assert: (inputPropertyNames includes: 'coverage'). - self assert: (inputPropertyNames includes: 'timeoutSeconds'). - self assert: (inputPropertyNames includes: 'timeoutMilliseconds'). - self - assert: (methodLimitProperty extraProperties at: #minimum) - equals: 0. self - assert: (methodLimitProperty extraProperties at: #default) - equals: 50. - coverageScopeProperty := coverageInputProperties detect: [ :each | - each name = 'scope' ]. - coverageScopePropertyNames := (coverageScopeProperty extraProperties - at: #properties) collect: [ :each | - each name ]. - self assert: (coverageScopePropertyNames includes: 'packages'). - self assert: (coverageScopePropertyNames includes: 'classes'). - self deny: (coverageScopePropertyNames includes: 'packageNames'). - self deny: (coverageScopePropertyNames includes: 'classNames') + assert: coverageInputProperties keys asSet + equals: + #( 'scope' 'side' 'includeCoveredMethods' 'methodLimit' ) asSet. + outputSchema := coverageTool outputSchema asJRPCJSON. + dataProperties := ((outputSchema at: #properties) at: 'data') at: + #properties. + self assert: (dataProperties includesKey: 'coverage'). + self assert: (dataProperties includesKey: 'runCount'). + self assert: (dataProperties includesKey: 'passedCount'). + self assert: (dataProperties includesKey: 'unrunPackages'). + coverageDataProperties := (dataProperties at: 'coverage') at: + #properties. + self assert: (coverageDataProperties includesKey: 'methodCount'). + self assert: (coverageDataProperties includesKey: 'uncoveredMethods'). + self assert: + (coverageDataProperties includesKey: 'partiallyCoveredMethods') ] { #category : 'tests' } -MCPToolContractsTest >> testRunTestsParsesTimeoutMilliseconds [ +MCPToolContractsTest >> testRunTestsKeepsPackagesAsPackageSelections [ - | parsedRequest rawRequest tool | + | command parsedRequest rawRequest testCases testRequests tool validatedRequests | tool := MCPToolRunTests new. - rawRequest := tool requestFromToolCallArguments: { - (#tests -> { { - (#className -> 'MCPToolContractsTest'). - (#testMethodName - -> - 'testRunTestToolsHaveAccurateNamesAndRequiredArguments') } - asDictionary }). - (#timeoutMilliseconds -> 25) } asDictionary. + rawRequest := tool requestFromToolCallArguments: + { (#packages -> #( 'MCP-Tests' )) } asDictionary. parsedRequest := tool parsedRequestFromToolRequest: rawRequest. - self assert: parsedRequest timeoutMilliseconds equals: 25 + testRequests := parsedRequest testRequests. + self assert: testRequests size equals: 1. + self assert: testRequests first isPackageRequest. + self assert: testRequests first packageName equals: 'MCP-Tests'. + self assert: testRequests first displayName equals: 'MCP-Tests'. + self assert: testRequests first className equals: nil. + self assert: testRequests first testMethodName equals: nil. + command := tool commandForRequest: parsedRequest. + validatedRequests := command validatedRequestsFrom: testRequests. + self assert: validatedRequests first isPackageRequest. + testCases := command testCasesForValidatedRequest: + validatedRequests first. + self assert: testCases notEmpty. + self assert: + (testCases noneSatisfy: [ :each | each class isAbstract ]) ] { #category : 'tests' } -MCPToolContractsTest >> testRunTestsRejectsConflictingTimeoutUnits [ +MCPToolContractsTest >> testRunTestsParsesCompactSelections [ - | rawRequest tool | + | command parsedRequest rawRequest testRequests tool validatedRequests | tool := MCPToolRunTests new. rawRequest := tool requestFromToolCallArguments: { - (#tests -> { { - (#className -> 'MCPToolContractsTest'). - (#testMethodName - -> - 'testRunTestToolsHaveAccurateNamesAndRequiredArguments') } - asDictionary }). - (#timeoutSeconds -> 1). - (#timeoutMilliseconds -> 25) } asDictionary. - self - should: [ tool parsedRequestFromToolRequest: rawRequest ] - raise: Error - whoseDescriptionIncludes: - 'timeoutSeconds and timeoutMilliseconds cannot both be provided' - description: 'Timeout requests should use one unit.' -] - -{ #category : 'tests' } -MCPToolContractsTest >> testRunTestsUsesNestedRequestDTOs [ - - | command parsedRequest rawRequest tool validatedRequests | - tool := MCPToolRunTests new. - rawRequest := tool requestFromToolCallArguments: { (#tests -> { { - (#className -> 'MCPToolContractsTest'). - (#testMethodName - -> - 'testRunTestToolsHaveAccurateNamesAndRequiredArguments') } - asDictionary }) } asDictionary. + (#classes -> #( 'MCPToolContractsTest' )). + (#methods + -> + #( 'MCPToolStructuredOutputTestTarget>>#testPasses' )) } + asDictionary. parsedRequest := tool parsedRequestFromToolRequest: rawRequest. command := tool commandForRequest: parsedRequest. validatedRequests := command validatedRequestsFrom: parsedRequest testRequests. + testRequests := parsedRequest testRequests. self assert: parsedRequest class equals: MCPRunTestsRequest. + self assert: testRequests size equals: 2. self - assert: parsedRequest testRequests first class - equals: MCPTestRunRequest. - self - assert: parsedRequest testRequests first className + assert: testRequests first className equals: 'MCPToolContractsTest'. + self assert: testRequests first testMethodName equals: nil. self - assert: parsedRequest testRequests first testMethodName - equals: 'testRunTestToolsHaveAccurateNamesAndRequiredArguments'. + assert: testRequests second className + equals: 'MCPToolStructuredOutputTestTarget'. + self assert: testRequests second testMethodName equals: 'testPasses'. + self + assert: testRequests second displayName + equals: 'MCPToolStructuredOutputTestTarget>>#testPasses'. self assert: validatedRequests first class equals: MCPValidatedTestRunRequest. self assert: validatedRequests first testRunRequest - equals: parsedRequest testRequests first. + equals: testRequests first. self assert: validatedRequests first testClass equals: MCPToolContractsTest ] +{ #category : 'tests' } +MCPToolContractsTest >> testRunTestsParsesTimeoutSeconds [ + + | parsedRequest rawRequest tool | + tool := MCPToolRunTests new. + rawRequest := tool requestFromToolCallArguments: { + (#classes -> #( 'MCPToolContractsTest' )). + (#timeoutSeconds -> 2) } asDictionary. + parsedRequest := tool parsedRequestFromToolRequest: rawRequest. + self assert: parsedRequest timeoutMilliseconds equals: 2000 +] + +{ #category : 'tests' } +MCPToolContractsTest >> testRunTestsRejectsEmptySelection [ + + | rawRequest tool | + tool := MCPToolRunTests new. + rawRequest := tool requestFromToolCallArguments: Dictionary new. + self + should: [ tool parsedRequestFromToolRequest: rawRequest ] + raise: Error + whoseDescriptionIncludes: + 'Provide at least one package, class, or method' + description: 'test_run requires at least one compact selection.' +] + { #category : 'tests' } MCPToolContractsTest >> testScreenshotCommandPackagesProvidedFormAsImageContent [ @@ -3060,8 +3169,7 @@ MCPToolContractsTest >> testServerCanConfigureStaticToolNames [ self assert: toolNames asSet equals: - #( 'tool_search' 'tool_get' 'tool_call' 'class_search' ) - asSet. + #( 'tool_search' 'tool_get' 'tool_call' 'class_search' ) asSet. self deny: (toolNames includes: 'class_name_update') ] @@ -3120,7 +3228,8 @@ MCPToolContractsTest >> testStaticToolConfigurationRejectsUnknownToolNames [ self should: [ - self mcpWithoutObservabilityExport staticToolNames: #( 'tool_search' 'not-a-tool' ) ] + self mcpWithoutObservabilityExport staticToolNames: + #( 'tool_search' 'not-a-tool' ) ] raise: Error ] @@ -3167,8 +3276,8 @@ MCPToolContractsTest >> testToolFlowSelectorNamesSeparateTransportAndParsedInput refactoringScopeParametersFromRequest: refactoringModelForScopeParameters:anchoredAtBehavior: ). staleSelectors do: [ :selector | - self deny: (MCPTool withAllSubclasses anySatisfy: [ :each | - each includesSelector: selector ]) ] + self deny: (MCPTool withAllSubclasses anySatisfy: [ :each | + each includesSelector: selector ]) ] ] { #category : 'tests' } @@ -3334,7 +3443,9 @@ MCPToolContractsTest >> testToolRegistryNamesUseClassSideMetadata [ assert: MCPToolStepOverDebugSession toolName equals: 'debug_session_step_over'. self assert: MCPToolDebugCapture toolName equals: 'debug_capture'. - self assert: MCPToolUpdateDebugMethod toolName equals: 'debug_method_update' + self + assert: MCPToolUpdateDebugMethod toolName + equals: 'debug_method_update' ] { #category : 'tests' } @@ -3387,5 +3498,26 @@ MCPToolContractsTest >> toolFlowSpecs [ specs addAll: self debugBreakpointToolFlowSpecs. specs add: self debugTestToolFlowSpec. ^ specs asArray +] +{ #category : 'private' } +MCPToolContractsTest >> unimplementedResponsibilitiesForConcreteMCPClasses [ + + | classes issues | + classes := (PackageOrganizer default packageNamed: #MCP) + definedClasses reject: [ :each | each isTrait ]. + issues := OrderedCollection new. + classes do: [ :class | + class isAbstract ifFalse: [ + self + addUnimplementedResponsibilitiesFor: class + behavior: class + side: 'instance' + to: issues. + self + addUnimplementedResponsibilitiesFor: class + behavior: class class + side: 'class' + to: issues ] ]. + ^ issues asArray sort ] diff --git a/src/MCP-Tests/MCPToolGetClassTest.class.st b/src/MCP-Tests/MCPToolGetClassTest.class.st index 427f7cb..4f1acbb 100644 --- a/src/MCP-Tests/MCPToolGetClassTest.class.st +++ b/src/MCP-Tests/MCPToolGetClassTest.class.st @@ -38,18 +38,18 @@ MCPToolGetClassTest >> ensureClassComment: aComment onClassNamed: aClassName [ MCPToolGetClassTest >> ensureClassMethodSource: aMethodSource onClassNamed: aClassName [ self withoutEpiceaDuring: [ - (self classNamed: aClassName) classSide - compile: aMethodSource - classified: 'testing' ] + (self classNamed: aClassName) classSide + compile: aMethodSource + classified: 'testing' ] ] { #category : 'private' } MCPToolGetClassTest >> ensureMethodSource: aMethodSource onClassNamed: aClassName [ self withoutEpiceaDuring: [ - (self classNamed: aClassName) - compile: aMethodSource - classified: 'testing' ] + (self classNamed: aClassName) + compile: aMethodSource + classified: 'testing' ] ] { #category : 'private' } @@ -97,9 +97,9 @@ MCPToolGetClassTest >> restoreFixtureClasses [ slots: #( betaSlot alphaSlot ) classSlots: #( classBeta classAlpha ). self withoutEpiceaDuring: [ - (self classNamed: self baseClassName) - addClassVarNamed: 'BetaShared'; - addClassVarNamed: 'AlphaShared' ]. + (self classNamed: self baseClassName) + addClassVarNamed: 'BetaShared'; + addClassVarNamed: 'AlphaShared' ]. self createClassNamed: self childZClassName superclassName: self baseClassName diff --git a/src/MCP-Tests/MCPToolMethodMutationTest.class.st b/src/MCP-Tests/MCPToolMethodMutationTest.class.st index 53ad973..3828475 100644 --- a/src/MCP-Tests/MCPToolMethodMutationTest.class.st +++ b/src/MCP-Tests/MCPToolMethodMutationTest.class.st @@ -39,10 +39,13 @@ MCPToolMethodMutationTest >> assertCompileForClassName: aClassName methodSource: { #category : 'private' } MCPToolMethodMutationTest >> assertSuccessDataHasMethodShape: data [ - #( selector className classSide packageName isExtension protocol source side action updateAction oldSelector newSelector oldProtocol newProtocol ) do: [ :key | + #( selector className classSide packageName isExtension protocol + source side action updateAction oldSelector newSelector + oldProtocol newProtocol ) do: [ :key | self deny: (data includesKey: key) ]. (data includesKey: #changeKind) ifTrue: [ - self assert: (#( 'created' 'replaced' ) includes: (data at: #changeKind)) ] + self assert: + (#( 'created' 'replaced' ) includes: (data at: #changeKind)) ] ] { #category : 'private - calling' } @@ -113,10 +116,10 @@ MCPToolMethodMutationTest >> compileArgumentsForClassName: aClassName classSide: MCPToolMethodMutationTest >> createRenameScopeFixtureClassNamed: aClassName packageName: aPackageName [ self withoutEpiceaDuring: [ - | builder | - builder := Object << aClassName asSymbol. - builder package: aPackageName. - builder install ] + | builder | + builder := Object << aClassName asSymbol. + builder package: aPackageName. + builder install ] ] { #category : 'private' } @@ -355,7 +358,6 @@ MCPToolMethodMutationTest >> testAddArgumentsUpdatesClassSideSenders [ self assert: MCPToolMethodMutationTestSender new callClassTarget equals: 'Class-value' - ] { #category : 'tests' } @@ -386,7 +388,6 @@ MCPToolMethodMutationTest >> testAddArgumentsUpdatesSendersAndReportsAction [ self assert: MCPToolMethodMutationTestSender new callInstanceTarget equals: 'first-second' - ] { #category : 'tests' } @@ -432,8 +433,7 @@ MCPToolMethodMutationTest >> testChangesClassSideMethodProtocol [ >> self classProtocolSelector) protocol name asString equals: 'instance creation'. self assertSuccessDataHasMethodShape: data. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests' } @@ -449,8 +449,7 @@ MCPToolMethodMutationTest >> testChangesInstanceSideMethodProtocol [ protocol name asString equals: 'accessing'. self assertSuccessDataHasMethodShape: data. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests' } @@ -461,7 +460,9 @@ MCPToolMethodMutationTest >> testChangingExtensionMethodProtocolUpdatesPackageMe data := self dataFrom: result. self deny: (result at: #isError ifAbsent: [ false ]). self - assert: (MCPToolMethodMutationTestTarget >> self extensionProtocolSelector) protocol name asString + assert: + (MCPToolMethodMutationTestTarget >> self extensionProtocolSelector) + protocol name asString equals: 'tests'. self assertSuccessDataHasMethodShape: data ] @@ -636,13 +637,13 @@ MCPToolMethodMutationTest >> testCompileReturnsAllowlistedExcessiveArgumentsCrit selector := #argumentHeavyMethod:with:with:with:with:. self removeSelector: selector from: MCPToolMethodMutationTestTarget. [ - self - assertCompileForClassName: 'MCPToolMethodMutationTestTarget' - methodSource: - 'argumentHeavyMethod: first with: second with: third with: fourth with: fifth ^ first + second + third + fourth + fifth' - protocol: 'tests' - returnsSingleCritiqueRuleClass: 'ReExcessiveArgumentsRule' - titledLike: 'Excessive number of arguments' ] ensure: [ + self + assertCompileForClassName: 'MCPToolMethodMutationTestTarget' + methodSource: + 'argumentHeavyMethod: first with: second with: third with: fourth with: fifth ^ first + second + third + fourth + fifth' + protocol: 'tests' + returnsSingleCritiqueRuleClass: 'ReExcessiveArgumentsRule' + titledLike: 'Excessive number of arguments' ] ensure: [ self removeSelector: selector from: MCPToolMethodMutationTestTarget ] ] @@ -652,18 +653,18 @@ MCPToolMethodMutationTest >> testCompileReturnsAllowlistedMissingSuperSendsCriti self removeSelector: #initialize from: MCPToolHierarchyTestBase. self removeSelector: #initialize from: MCPToolHierarchyTestChild. [ - self - ensureMethodSource: 'initialize super initialize. ^ 1' - protocol: 'initialization' - on: MCPToolHierarchyTestBase. - self - assertCompileForClassName: 'MCPToolHierarchyTestChild' - methodSource: 'initialize 2 + 3' - protocol: 'initialization' - returnsSingleCritiqueRuleClass: 'ReMissingSuperSendsRule' - titledLike: 'Missing super sends' ] ensure: [ - self removeSelector: #initialize from: MCPToolHierarchyTestBase. - self removeSelector: #initialize from: MCPToolHierarchyTestChild ] + self + ensureMethodSource: 'initialize super initialize. ^ 1' + protocol: 'initialization' + on: MCPToolHierarchyTestBase. + self + assertCompileForClassName: 'MCPToolHierarchyTestChild' + methodSource: 'initialize 2 + 3' + protocol: 'initialization' + returnsSingleCritiqueRuleClass: 'ReMissingSuperSendsRule' + titledLike: 'Missing super sends' ] ensure: [ + self removeSelector: #initialize from: MCPToolHierarchyTestBase. + self removeSelector: #initialize from: MCPToolHierarchyTestChild ] ] { #category : 'tests' } @@ -705,12 +706,12 @@ MCPToolMethodMutationTest >> testCompileReturnsAllowlistedReturnInEnsureCritique selector := #returnInEnsure. self removeSelector: selector from: MCPToolMethodMutationTestTarget. [ - self - assertCompileForClassName: 'MCPToolMethodMutationTestTarget' - methodSource: 'returnInEnsure [ 1 ] ensure: [ ^ 2 ]' - protocol: 'tests' - returnsSingleCritiqueRuleClass: 'ReReturnInEnsureRule' - titledLike: 'return in an ensure:' ] ensure: [ + self + assertCompileForClassName: 'MCPToolMethodMutationTestTarget' + methodSource: 'returnInEnsure [ 1 ] ensure: [ ^ 2 ]' + protocol: 'tests' + returnsSingleCritiqueRuleClass: 'ReReturnInEnsureRule' + titledLike: 'return in an ensure:' ] ensure: [ self removeSelector: selector from: MCPToolMethodMutationTestTarget ] ] @@ -721,13 +722,13 @@ MCPToolMethodMutationTest >> testCompileReturnsAllowlistedUnaryAccessingWithoutR selector := #counterValue. self removeSelector: selector from: MCPToolGetMethodTestTarget. [ - self - assertCompileForClassName: 'MCPToolGetMethodTestTarget' - methodSource: 'counterValue instanceCounter + 1' - protocol: 'accessing' - returnsSingleCritiqueRuleClass: - 'ReUnaryAccessingMethodWithoutReturnRule' - titledLike: 'without explicit return' ] ensure: [ + self + assertCompileForClassName: 'MCPToolGetMethodTestTarget' + methodSource: 'counterValue instanceCounter + 1' + protocol: 'accessing' + returnsSingleCritiqueRuleClass: + 'ReUnaryAccessingMethodWithoutReturnRule' + titledLike: 'without explicit return' ] ensure: [ self removeSelector: selector from: MCPToolGetMethodTestTarget ] ] @@ -738,13 +739,13 @@ MCPToolMethodMutationTest >> testCompileReturnsAllowlistedWarningCritiques [ selector := #shadowedCounter:. self removeSelector: selector from: MCPToolGetMethodTestTarget. [ - self - assertCompileForClassName: 'MCPToolGetMethodTestTarget' - methodSource: - 'shadowedCounter: value | instanceCounter | instanceCounter := value. ^ instanceCounter + 1' - protocol: 'tests' - returnsSingleCritiqueRuleClass: 'ReTempVarOverridesInstVarRule' - titledLike: 'Outer variable shadowed' ] ensure: [ + self + assertCompileForClassName: 'MCPToolGetMethodTestTarget' + methodSource: + 'shadowedCounter: value | instanceCounter | instanceCounter := value. ^ instanceCounter + 1' + protocol: 'tests' + returnsSingleCritiqueRuleClass: 'ReTempVarOverridesInstVarRule' + titledLike: 'Outer variable shadowed' ] ensure: [ self removeSelector: selector from: MCPToolGetMethodTestTarget ] ] @@ -951,6 +952,32 @@ MCPToolMethodMutationTest >> testCompileReturnsStructuredCommandErrorForUndeclar (MCPToolMethodMutationTestTarget includesSelector: #brokenMethod) ] +{ #category : 'tests' } +MCPToolMethodMutationTest >> testCompileStoresMethodSourceWithoutFormatterCorruption [ + + | result selector source storedSource | + selector := #sourceIntegrityProbe. + source := 'sourceIntegrityProbe + | values | + values := #(1 2) collect: [ :each | each asString ]. + ^ '','' join: values'. + [ + result := self callToolWith: (self + compileArgumentsForClassName: + 'MCPToolMethodMutationTestTarget' + classSide: false + methodSource: source + protocol: 'tests'). + storedSource := (MCPToolMethodMutationTestTarget >> selector) + sourceCode. + self deny: (result at: #isError ifAbsent: [ false ]). + self assert: (storedSource includesSubstring: 'each asString'). + self + assert: (MCPToolMethodMutationTestTarget new perform: selector) + equals: '1,2' ] ensure: [ + self removeSelector: selector from: MCPToolMethodMutationTestTarget ] +] + { #category : 'tests' } MCPToolMethodMutationTest >> testCompilesClassSideMethod [ @@ -969,8 +996,7 @@ MCPToolMethodMutationTest >> testCompilesClassSideMethod [ protocol name equals: #tests. self assertSuccessDataHasMethodShape: data. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests' } @@ -992,8 +1018,7 @@ MCPToolMethodMutationTest >> testCompilesInstanceSideMethod [ (MCPToolMethodMutationTestTarget >> #instanceAnswer) protocol name equals: #tests. self assertSuccessDataHasMethodShape: data. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests' } @@ -1011,8 +1036,8 @@ MCPToolMethodMutationTest >> testMCPPackageMethodSourcesDoNotContainLineFeeds [ MCPToolMethodMutationTest >> testMethodToolSchemasDeclareExpectedInputs [ | classSideProperty createPropertyNames protocolPropertyNames selectorPropertyNames | - createPropertyNames := MCPToolCompileMethod new inputSchema properties - collect: [ :each | each name ]. + createPropertyNames := MCPToolCompileMethod new inputSchema + properties collect: [ :each | each name ]. selectorPropertyNames := MCPToolUpdateMethodSelector new inputSchema properties collect: [ :each | each name ]. protocolPropertyNames := MCPToolUpdateMethodProtocol new inputSchema @@ -1021,8 +1046,7 @@ MCPToolMethodMutationTest >> testMethodToolSchemasDeclareExpectedInputs [ detect: [ :each | each name = 'classSide' ]. self assert: createPropertyNames asArray - equals: - #( 'className' 'classSide' 'force' 'source' 'protocol' ). + equals: #( 'className' 'classSide' 'force' 'source' 'protocol' ). self assert: selectorPropertyNames asArray equals: #( 'className' 'classSide' 'force' 'selector' 'newSelector' @@ -1056,8 +1080,8 @@ MCPToolMethodMutationTest >> testNormalizesLineEndingsBeforeCompilation [ classSide: false methodSource: source protocol: 'tests'). - normalizedSource := (MCPToolMethodMutationTestTarget >> #multilineAnswer) - sourceCode. + normalizedSource := (MCPToolMethodMutationTestTarget + >> #multilineAnswer) sourceCode. self deny: (normalizedSource includes: Character lf). self assert: (normalizedSource includes: Character cr). self @@ -1091,25 +1115,6 @@ MCPToolMethodMutationTest >> testNormalizesLineFeedStringLiteralBeforeCompilatio from: MCPToolMethodMutationTestTarget ] ] -{ #category : 'tests' } -MCPToolMethodMutationTest >> testReformatsMethod [ - - | data reformattedSource result source | - source := 'uglyAnswer ^ 1+2'. - result := self callToolWith: (self - compileArgumentsForClassName: - 'MCPToolMethodMutationTestTarget' - classSide: false - methodSource: source - protocol: 'tests'). - data := self dataFrom: result. - reformattedSource := (MCPToolMethodMutationTestTarget >> #uglyAnswer) - sourceCode. - self deny: (result at: #isError ifAbsent: [ false ]). - self assert: (reformattedSource includesSubstring: '1 + 2'). - self assert: MCPToolMethodMutationTestTarget new uglyAnswer equals: 3 -] - { #category : 'tests' } MCPToolMethodMutationTest >> testRemoveArgumentsFailsWhenRemovedArgumentIsReferenced [ @@ -1117,35 +1122,39 @@ MCPToolMethodMutationTest >> testRemoveArgumentsFailsWhenRemovedArgumentIsRefere oldSelector := ('referencedRemove:' , 'unused:') asSymbol. newSelector := #referencedRemove:. [ - self - ensureMethodSource: - 'referencedRemove: first unused: ignored ^ ignored' - protocol: 'tests' - on: MCPToolMethodMutationTestTarget. - result := self callToolWith: { - (#action -> 'update'). - (#className -> 'MCPToolMethodMutationTestTarget'). - (#classSide -> false). - (#selector -> oldSelector asString). - (#newSelector -> newSelector asString) } asDictionary. - structured := self structuredContentFrom: result. - error := self errorFrom: result. - self assert: (result at: #isError). - self assert: (structured at: #status) equals: 'error'. - self assert: (error at: #action) equals: 'update'. - self assert: (error at: #updateAction) equals: 'removeArguments'. - self - assert: (error at: #className) - equals: 'MCPToolMethodMutationTestTarget'. - self assert: (error at: #selector) equals: oldSelector asString. - self assert: (error at: #newSelector) equals: newSelector asString. - self assert: - (MCPToolMethodMutationTestTarget includesSelector: oldSelector). - self deny: - (MCPToolMethodMutationTestTarget includesSelector: newSelector) ] + self + ensureMethodSource: + 'referencedRemove: first unused: ignored ^ ignored' + protocol: 'tests' + on: MCPToolMethodMutationTestTarget. + result := self callToolWith: { + (#action -> 'update'). + (#className -> 'MCPToolMethodMutationTestTarget'). + (#classSide -> false). + (#selector -> oldSelector asString). + (#newSelector -> newSelector asString) } asDictionary. + structured := self structuredContentFrom: result. + error := self errorFrom: result. + self assert: (result at: #isError). + self assert: (structured at: #status) equals: 'error'. + self assert: (error at: #action) equals: 'update'. + self assert: (error at: #updateAction) equals: 'removeArguments'. + self + assert: (error at: #className) + equals: 'MCPToolMethodMutationTestTarget'. + self assert: (error at: #selector) equals: oldSelector asString. + self assert: (error at: #newSelector) equals: newSelector asString. + self assert: + (MCPToolMethodMutationTestTarget includesSelector: oldSelector). + self deny: + (MCPToolMethodMutationTestTarget includesSelector: newSelector) ] ensure: [ - self removeSelector: oldSelector from: MCPToolMethodMutationTestTarget. - self removeSelector: newSelector from: MCPToolMethodMutationTestTarget ] + self + removeSelector: oldSelector + from: MCPToolMethodMutationTestTarget. + self + removeSelector: newSelector + from: MCPToolMethodMutationTestTarget ] ] { #category : 'tests' } @@ -1192,7 +1201,6 @@ MCPToolMethodMutationTest >> testRemoveArgumentsUpdatesSendersAndReportsAction [ self removeSelector: #callRemoveArgumentTarget from: MCPToolMethodMutationTestSender ] - ] { #category : 'tests' } @@ -1273,15 +1281,15 @@ MCPToolMethodMutationTest >> testRenameCanLimitRefactoringToNamedPackages [ ] { #category : 'tests' } -MCPToolMethodMutationTest >> testRenameReturnsFormattedSourceForRenamedMethod [ +MCPToolMethodMutationTest >> testRenameKeepsRenamedMethodCallable [ - | data newSelector oldSelector renamedSource result | + | newSelector oldSelector result target | oldSelector := ('uglyRename:' , 'with:') asSymbol. newSelector := ('with:' , 'uglyRename:') asSymbol. [ self ensureMethodSource: - 'uglyRename: first with:second ^first,''-'',second' + 'uglyRename: first with: second ^ first , ''-'' , second' protocol: 'tests' on: MCPToolMethodMutationTestTarget. result := self callToolWith: { @@ -1291,22 +1299,21 @@ MCPToolMethodMutationTest >> testRenameReturnsFormattedSourceForRenamedMethod [ (#selector -> oldSelector asString). (#newSelector -> newSelector asString). (#permutation -> #( 2 1 )) } asDictionary. - data := self dataFrom: result. - renamedSource := (MCPToolMethodMutationTestTarget >> newSelector) - sourceCode. + target := MCPToolMethodMutationTestTarget new. self deny: (result at: #isError ifAbsent: [ false ]). + self deny: + (MCPToolMethodMutationTestTarget includesSelector: oldSelector). self assert: - (renamedSource includesSubstring: 'with: second uglyRename: first'). - self assert: - (renamedSource includesSubstring: '^ first , ''-'' , second') ] - ensure: [ - self - removeSelector: oldSelector - from: MCPToolMethodMutationTestTarget. - self - removeSelector: newSelector - from: MCPToolMethodMutationTestTarget ] - + (MCPToolMethodMutationTestTarget includesSelector: newSelector). + self + assert: (target perform: newSelector with: 'right' with: 'left') + equals: 'left-right' ] ensure: [ + self + removeSelector: oldSelector + from: MCPToolMethodMutationTestTarget. + self + removeSelector: newSelector + from: MCPToolMethodMutationTestTarget ] ] { #category : 'tests' } @@ -1391,8 +1398,8 @@ MCPToolMethodMutationTest >> testRenameUpdatesSendersAndPermutesArguments [ self assert: MCPToolMethodMutationTestSender new callInstanceTarget equals: 'first-second'. - senderSource := (MCPToolMethodMutationTestSender >> #callInstanceTarget) - sourceCode. + senderSource := (MCPToolMethodMutationTestSender + >> #callInstanceTarget) sourceCode. self assert: (senderSource includesSubstring: 'with: ''second'' combine: ''first''') @@ -1415,8 +1422,7 @@ MCPToolMethodMutationTest >> testRenamesClassSideMethodWithDefaultPermutation [ assert: MCPToolMethodMutationTestSender new callClassTarget equals: 'Class-value'. self assertSuccessDataHasMethodShape: data. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'tests' } @@ -1431,8 +1437,7 @@ MCPToolMethodMutationTest >> testRenamesInstanceMethodAndReturnsStructuredData [ self assert: (MCPToolMethodMutationTestTarget includesSelector: self renamedInstanceSelector). self assertSuccessDataHasMethodShape: data. - self deny: (result at: #isError ifAbsent: [ false ]). - + self deny: (result at: #isError ifAbsent: [ false ]) ] { #category : 'private - calling' } @@ -1461,51 +1466,52 @@ MCPToolMethodMutationTest >> withRenameScopeFixturesDo: aBlock [ packageAName. packageBName } do: [ :eachName | self removePackageNamed: eachName ]. [ - self - createRenameScopeFixtureClassNamed: targetAClassName - packageName: packageAName. - self - createRenameScopeFixtureClassNamed: targetBClassName - packageName: packageBName. - self - createRenameScopeFixtureClassNamed: senderAClassName - packageName: packageAName. - self - createRenameScopeFixtureClassNamed: senderBClassName - packageName: packageBName. - self - ensureMethodSource: 'scopeSharedTarget ^ ''A''' - protocol: 'tests' - on: (Smalltalk globals at: targetAClassName asSymbol). - self - ensureMethodSource: 'scopeSharedTarget ^ ''B''' - protocol: 'tests' - on: (Smalltalk globals at: targetBClassName asSymbol). - self - ensureMethodSource: - 'callScopedTarget ^ MCPToolMethodMutationScopeTargetA new scopeSharedTarget' - protocol: 'tests' - on: (Smalltalk globals at: senderAClassName asSymbol). - self - ensureMethodSource: - 'callScopedTarget ^ MCPToolMethodMutationScopeTargetB new scopeSharedTarget' - protocol: 'tests' - on: (Smalltalk globals at: senderBClassName asSymbol). - fixtures := { - (#packageAName -> packageAName). - (#packageBName -> packageBName). - (#targetAClassName -> targetAClassName). - (#targetBClassName -> targetBClassName). - (#senderAClassName -> senderAClassName). - (#senderBClassName -> senderBClassName) } asDictionary. - aBlock value: fixtures ] ensure: [ - { - targetAClassName. - targetBClassName. - senderAClassName. - senderBClassName } do: [ :eachName | - self removeClassNamed: eachName ]. - { - packageAName. - packageBName } do: [ :eachName | self removePackageNamed: eachName ] ] + self + createRenameScopeFixtureClassNamed: targetAClassName + packageName: packageAName. + self + createRenameScopeFixtureClassNamed: targetBClassName + packageName: packageBName. + self + createRenameScopeFixtureClassNamed: senderAClassName + packageName: packageAName. + self + createRenameScopeFixtureClassNamed: senderBClassName + packageName: packageBName. + self + ensureMethodSource: 'scopeSharedTarget ^ ''A''' + protocol: 'tests' + on: (Smalltalk globals at: targetAClassName asSymbol). + self + ensureMethodSource: 'scopeSharedTarget ^ ''B''' + protocol: 'tests' + on: (Smalltalk globals at: targetBClassName asSymbol). + self + ensureMethodSource: + 'callScopedTarget ^ MCPToolMethodMutationScopeTargetA new scopeSharedTarget' + protocol: 'tests' + on: (Smalltalk globals at: senderAClassName asSymbol). + self + ensureMethodSource: + 'callScopedTarget ^ MCPToolMethodMutationScopeTargetB new scopeSharedTarget' + protocol: 'tests' + on: (Smalltalk globals at: senderBClassName asSymbol). + fixtures := { + (#packageAName -> packageAName). + (#packageBName -> packageBName). + (#targetAClassName -> targetAClassName). + (#targetBClassName -> targetBClassName). + (#senderAClassName -> senderAClassName). + (#senderBClassName -> senderBClassName) } asDictionary. + aBlock value: fixtures ] ensure: [ + { + targetAClassName. + targetBClassName. + senderAClassName. + senderBClassName } do: [ :eachName | + self removeClassNamed: eachName ]. + { + packageAName. + packageBName } do: [ :eachName | + self removePackageNamed: eachName ] ] ] diff --git a/src/MCP-Tests/MCPToolRemoveClassesTest.class.st b/src/MCP-Tests/MCPToolRemoveClassesTest.class.st index 2f52851..81f39fa 100644 --- a/src/MCP-Tests/MCPToolRemoveClassesTest.class.st +++ b/src/MCP-Tests/MCPToolRemoveClassesTest.class.st @@ -66,18 +66,18 @@ MCPToolRemoveClassesTest >> ensureClassNamed: aClassName superclassName: aSuperc (self class environment includesKey: symbol) ifTrue: [ ^ self ]. superclass := self class environment at: aSuperclassName asSymbol. self withoutEpiceaDuring: [ - (superclass << symbol) - package: aPackageName; - install ] + (superclass << symbol) + package: aPackageName; + install ] ] { #category : 'private' } MCPToolRemoveClassesTest >> ensureMethodSource: aMethodSource onClassNamed: aClassName [ self withoutEpiceaDuring: [ - (self classNamed: aClassName) - compile: aMethodSource - classified: 'tests' ] + (self classNamed: aClassName) + compile: aMethodSource + classified: 'tests' ] ] { #category : 'private' } @@ -219,34 +219,48 @@ MCPToolRemoveClassesTest >> tearDown [ MCPToolRemoveClassesTest >> testForceRemovesNonEmptyClassAndReparentsSubclassesWithWarnings [ | data result structured warnings | - result := self callToolWith: (self argumentsForClassNames: { self nonEmptyParentClassName } force: true). + result := self callToolWith: (self + argumentsForClassNames: { self nonEmptyParentClassName } + force: true). structured := self structuredContentFrom: result. data := self dataFrom: result. warnings := structured at: #warnings. self deny: (result at: #isError ifAbsent: [ false ]). - self deny: (self class environment includesKey: self nonEmptyParentClassName asSymbol). + self deny: (self class environment includesKey: + self nonEmptyParentClassName asSymbol). self - assert: (self classNamed: self nonEmptyChildClassName) superclass name asString + assert: + (self classNamed: self nonEmptyChildClassName) superclass name + asString equals: 'Object'. self assert: (data at: #reparentedSubclassNames ifAbsent: [ #( ) ]) equals: { self nonEmptyChildClassName } asArray. self assert: warnings size equals: 1. - self assert: (warnings first includesSubstring: self nonEmptyParentClassName) + self assert: + (warnings first includesSubstring: self nonEmptyParentClassName) ] { #category : 'tests' } MCPToolRemoveClassesTest >> testForceRemovesReferencedClassAndReturnsWarnings [ | result structured warnings | - result := self callToolWith: (self argumentsForClassNames: { self referencedClassName } force: true). + result := self callToolWith: + (self + argumentsForClassNames: { self referencedClassName } + force: true). structured := self structuredContentFrom: result. warnings := structured at: #warnings. self deny: (result at: #isError ifAbsent: [ false ]). - self deny: (self class environment includesKey: self referencedClassName asSymbol). - self assert: ((self classNamed: self senderClassName) includesSelector: #useReferencedClass). + self deny: + (self class environment includesKey: + self referencedClassName asSymbol). + self assert: + ((self classNamed: self senderClassName) includesSelector: + #useReferencedClass). self assert: warnings size equals: 1. - self assert: (warnings first includesSubstring: self referencedClassName) + self assert: + (warnings first includesSubstring: self referencedClassName) ] { #category : 'tests' } @@ -312,12 +326,16 @@ MCPToolRemoveClassesTest >> testReturnsStructuredErrorWhenNonEmptyClassHasSubcla MCPToolRemoveClassesTest >> testSafelyRemovesEmptyClassAndReparentsDirectSubclasses [ | data result | - result := self callToolWith: (self argumentsForClassNames: { self emptyParentClassName }). + result := self callToolWith: + (self argumentsForClassNames: + { self emptyParentClassName }). data := self dataFrom: result. self deny: (result at: #isError ifAbsent: [ false ]). - self deny: (self class environment includesKey: self emptyParentClassName asSymbol). + self deny: (self class environment includesKey: + self emptyParentClassName asSymbol). self - assert: (self classNamed: self emptyChildClassName) superclass name asString + assert: + (self classNamed: self emptyChildClassName) superclass name asString equals: 'Object'. self assert: (data at: #reparentedSubclassNames ifAbsent: [ #( ) ]) @@ -328,12 +346,16 @@ MCPToolRemoveClassesTest >> testSafelyRemovesEmptyClassAndReparentsDirectSubclas MCPToolRemoveClassesTest >> testSafelyRemovesSimpleClass [ | data result | - result := self callToolWith: (self argumentsForClassNames: self batchClassNames). + result := self callToolWith: + (self argumentsForClassNames: self batchClassNames). data := self dataFrom: result. self deny: (result at: #isError ifAbsent: [ false ]). - self deny: (self class environment includesKey: self simpleClassName asSymbol). - self deny: (self class environment includesKey: self packageCleanupClassName asSymbol). - self deny: (PackageOrganizer default hasPackage: self packageCleanupPackageName). + self deny: + (self class environment includesKey: self simpleClassName asSymbol). + self deny: (self class environment includesKey: + self packageCleanupClassName asSymbol). + self deny: + (PackageOrganizer default hasPackage: self packageCleanupPackageName). self assert: (data at: #removedPackageNames ifAbsent: [ #( ) ]) equals: { self packageCleanupPackageName } asArray diff --git a/src/MCP-Tests/MCPToolRemoveMethodsTest.class.st b/src/MCP-Tests/MCPToolRemoveMethodsTest.class.st index 61f4def..41b494b 100644 --- a/src/MCP-Tests/MCPToolRemoveMethodsTest.class.st +++ b/src/MCP-Tests/MCPToolRemoveMethodsTest.class.st @@ -223,11 +223,14 @@ MCPToolRemoveMethodsTest >> testDefaultsToRemovingInstanceSideMethodsWhenClassSi | result | result := self callToolWith: { - (#className -> 'MCPToolRemoveMethodsTestTarget'). - (#selectors -> self instanceBatchSelectors) } asDictionary. + (#className -> 'MCPToolRemoveMethodsTestTarget'). + (#selectors -> self instanceBatchSelectors) } + asDictionary. self deny: (result at: #isError ifAbsent: [ false ]). - self deny: (MCPToolRemoveMethodsTestTarget includesSelector: self firstInstanceBatchSelector). - self deny: (MCPToolRemoveMethodsTestTarget includesSelector: self secondInstanceBatchSelector) + self deny: (MCPToolRemoveMethodsTestTarget includesSelector: + self firstInstanceBatchSelector). + self deny: (MCPToolRemoveMethodsTestTarget includesSelector: + self secondInstanceBatchSelector) ] { #category : 'tests' } @@ -235,18 +238,27 @@ MCPToolRemoveMethodsTest >> testForceRemovesMethodsEvenWhenExternalSendersExistA | result structured text warnings | result := self callToolWith: { - (#className -> 'MCPToolRemoveMethodsTestTarget'). - (#classSide -> false). - (#selectors -> { self protectedSelector }) } asDictionary. + (#className -> 'MCPToolRemoveMethodsTestTarget'). + (#classSide -> false). + (#selectors -> { self protectedSelector }) } asDictionary. structured := self structuredContentFrom: result. text := self firstTextFrom: result. warnings := structured at: #warnings. self deny: (result at: #isError ifAbsent: [ false ]). self deny: (text includesSubstring: 'Warning:'). - self assert: warnings equals: { 'This bypasses sender checks and may leave broken senders.' } asArray. - self deny: (MCPToolRemoveMethodsTestTarget includesSelector: self protectedSelectorSymbol). - self assert: (MCPToolRemoveMethodsTestSender includesSelector: #sendProtectedRemovalTarget). - self should: [ MCPToolRemoveMethodsTestSender new sendProtectedRemovalTarget ] raise: MessageNotUnderstood + self + assert: warnings + equals: + { 'This bypasses sender checks and may leave broken senders.' } + asArray. + self deny: (MCPToolRemoveMethodsTestTarget includesSelector: + self protectedSelectorSymbol). + self assert: (MCPToolRemoveMethodsTestSender includesSelector: + #sendProtectedRemovalTarget). + self + should: [ + MCPToolRemoveMethodsTestSender new sendProtectedRemovalTarget ] + raise: MessageNotUnderstood ] { #category : 'tests' } @@ -277,8 +289,12 @@ MCPToolRemoveMethodsTest >> testRemovesBatchOfClassSideMethods [ | result | result := self callToolWith: self classBatchArguments. self deny: (result at: #isError ifAbsent: [ false ]). - self deny: (MCPToolRemoveMethodsTestTarget classSide includesSelector: self firstClassBatchSelector). - self deny: (MCPToolRemoveMethodsTestTarget classSide includesSelector: self secondClassBatchSelector) + self deny: + (MCPToolRemoveMethodsTestTarget classSide includesSelector: + self firstClassBatchSelector). + self deny: + (MCPToolRemoveMethodsTestTarget classSide includesSelector: + self secondClassBatchSelector) ] { #category : 'tests' } @@ -287,8 +303,10 @@ MCPToolRemoveMethodsTest >> testRemovesBatchOfInstanceMethods [ | result | result := self callToolWith: self instanceBatchArguments. self deny: (result at: #isError ifAbsent: [ false ]). - self deny: (MCPToolRemoveMethodsTestTarget includesSelector: self firstInstanceBatchSelector). - self deny: (MCPToolRemoveMethodsTestTarget includesSelector: self secondInstanceBatchSelector) + self deny: (MCPToolRemoveMethodsTestTarget includesSelector: + self firstInstanceBatchSelector). + self deny: (MCPToolRemoveMethodsTestTarget includesSelector: + self secondInstanceBatchSelector) ] { #category : 'tests' } @@ -296,9 +314,11 @@ MCPToolRemoveMethodsTest >> testReturnsStructuredErrorWhenAnyMethodIsMissing [ | error result structured | result := self callToolWith: { - (#className -> 'MCPToolRemoveMethodsTestTarget'). - (#classSide -> false). - (#selectors -> { self firstInstanceBatchSelectorString. self missingSelectorString }) } asDictionary. + (#className -> 'MCPToolRemoveMethodsTestTarget'). + (#classSide -> false). + (#selectors -> { + self firstInstanceBatchSelectorString. + self missingSelectorString }) } asDictionary. structured := self structuredContentFrom: result. error := self errorFrom: result. self assert: (result at: #isError). @@ -306,7 +326,8 @@ MCPToolRemoveMethodsTest >> testReturnsStructuredErrorWhenAnyMethodIsMissing [ self assert: (error at: #errorClass) equals: 'MCPCommandError'. self assert: (error at: #errorCode) equals: 'MethodNotFound'. self assert: (error at: #selector) equals: self missingSelectorString. - self assert: (MCPToolRemoveMethodsTestTarget includesSelector: self firstInstanceBatchSelector) + self assert: (MCPToolRemoveMethodsTestTarget includesSelector: + self firstInstanceBatchSelector) ] { #category : 'tests' } diff --git a/src/MCP-Tests/MCPToolRepositoryOperationTest.class.st b/src/MCP-Tests/MCPToolRepositoryOperationTest.class.st index c287e72..b801339 100644 --- a/src/MCP-Tests/MCPToolRepositoryOperationTest.class.st +++ b/src/MCP-Tests/MCPToolRepositoryOperationTest.class.st @@ -74,11 +74,11 @@ MCPToolRepositoryOperationTest >> commitAllIn: aRepositoryLocation message: aMes MCPToolRepositoryOperationTest >> createClassNamed: aClassName inPackageNamed: aPackageName [ ^ self withoutEpiceaDuring: [ - | builder | - builder := Object << aClassName asSymbol. - builder package: aPackageName. - builder tag: 'Generated'. - builder install ] + | builder | + builder := Object << aClassName asSymbol. + builder package: aPackageName. + builder tag: 'Generated'. + builder install ] ] { #category : 'private' } @@ -148,7 +148,7 @@ MCPToolRepositoryOperationTest >> removeRegisteredRepositoriesNamed: aRepository registry := IceRepository registry. repositories := registry select: [ :each | each name asString = aRepositoryName ]. - repositories do: [ :each | registry remove: each ifAbsent: [ ] ] + repositories do: [ :each | registry remove: each ifAbsent: [ ] ] ] { #category : 'private - calling' } @@ -235,7 +235,6 @@ MCPToolRepositoryOperationTest >> testAdoptHeadOperationRequiresRepositoryAndPar self assert: parsedRequest operation equals: 'adoptHead'. self assert: parsedRequest branchName equals: 'main'. self assert: command class equals: MCPAdoptRepositoryHeadCommand - ] { #category : 'tests' } @@ -278,7 +277,6 @@ MCPToolRepositoryOperationTest >> testAttachParsesAndDispatchesToAttachCommand [ self assert: parsedRequest class equals: MCPRepositoryAttachRequest. self assert: parsedRequest operation equals: 'attach'. self assert: command class equals: MCPAttachRepositoryCommand - ] { #category : 'tests' } @@ -534,7 +532,6 @@ MCPToolRepositoryOperationTest >> testCommitParsesAndDispatchesToCommitCommand [ self assert: parsedRequest message equals: 'Commit from test'. self assert: parsedRequest operation equals: 'commit'. self assert: command class equals: MCPCommitRepositoryCommand - ] { #category : 'tests' } @@ -549,27 +546,27 @@ MCPToolRepositoryOperationTest >> testCommitReportsIcebergRefusalErrors [ withExportPackageNamed: packageName className: 'MCPToolRepositoryOperationRefusedCommitClass' do: [ - self - withCleanRepositoryNamed: repositoryName - location: location - do: [ - self callToolWith: { - (#action -> 'create'). - (#name -> repositoryName). - (#location -> location pathString). - (#packageNames -> { packageName }) } asDictionary. - self callToolWith: { - (#action -> 'commit'). - (#repositoryName -> repositoryName). - (#message -> 'Initial commit from MCP test') } asDictionary. - result := self callToolWith: { - (#action -> 'commit'). - (#repositoryName -> repositoryName). - (#message -> 'Second commit from MCP test') } - asDictionary. - self assert: (result at: #isError ifAbsent: [ false ]). - self assert: ((self summaryFrom: result) includesSubstring: - 'Failed to commit repository') ] ] + self + withCleanRepositoryNamed: repositoryName + location: location + do: [ + self callToolWith: { + (#action -> 'create'). + (#name -> repositoryName). + (#location -> location pathString). + (#packageNames -> { packageName }) } asDictionary. + self callToolWith: { + (#action -> 'commit'). + (#repositoryName -> repositoryName). + (#message -> 'Initial commit from MCP test') } asDictionary. + result := self callToolWith: { + (#action -> 'commit'). + (#repositoryName -> repositoryName). + (#message -> 'Second commit from MCP test') } + asDictionary. + self assert: (result at: #isError ifAbsent: [ false ]). + self assert: ((self summaryFrom: result) includesSubstring: + 'Failed to commit repository') ] ] ] { #category : 'tests' } @@ -610,8 +607,8 @@ MCPToolRepositoryOperationTest >> testCommitUsesFallbackGitIdentityWhenGitSignat | data location packageName repository repositoryName result | PharoCompatibility isPharo13OrLater ifTrue: [ - self skip: - 'Pharo 13 commits use the Author API; forcing empty libgit2 config can crash the VM in CI.' ]. + self skip: + 'Pharo 13 commits use the Author API; forcing empty libgit2 config can crash the VM in CI.' ]. repositoryName := 'MCP Repository Command Commit Fallback Identity Test'. packageName := 'MCPToolRepositoryOperationCommitFallbackIdentityPackage'. location := self temporaryRepositoryLocationNamed: @@ -620,32 +617,32 @@ MCPToolRepositoryOperationTest >> testCommitUsesFallbackGitIdentityWhenGitSignat withExportPackageNamed: packageName className: 'MCPToolRepositoryOperationCommitFallbackIdentityClass' do: [ - self - withCleanRepositoryNamed: repositoryName - location: location - do: [ - self callToolWith: { - (#action -> 'create'). - (#name -> repositoryName). - (#location -> location pathString). - (#packageNames -> { packageName }) } asDictionary. - repository := IceRepository repositories detect: [ :each | - each name asString = repositoryName ]. - repository repositoryHandle config - username: ''; - email: ''. - result := self callToolWith: { - (#action -> 'commit'). - (#repositoryName -> repositoryName). - (#message - -> 'Commit with fallback identity from MCP test') } - asDictionary. - self deny: (result at: #isError ifAbsent: [ false ]). - data := self dataFrom: result. - self - assert: (data at: #commitDescription) - equals: 'Commit with fallback identity from MCP test'. - self assert: repository headCommit author equals: 'MCP' ] ] + self + withCleanRepositoryNamed: repositoryName + location: location + do: [ + self callToolWith: { + (#action -> 'create'). + (#name -> repositoryName). + (#location -> location pathString). + (#packageNames -> { packageName }) } asDictionary. + repository := IceRepository repositories detect: [ :each | + each name asString = repositoryName ]. + repository repositoryHandle config + username: ''; + email: ''. + result := self callToolWith: { + (#action -> 'commit'). + (#repositoryName -> repositoryName). + (#message + -> 'Commit with fallback identity from MCP test') } + asDictionary. + self deny: (result at: #isError ifAbsent: [ false ]). + data := self dataFrom: result. + self + assert: (data at: #commitDescription) + equals: 'Commit with fallback identity from MCP test'. + self assert: repository headCommit author equals: 'MCP' ] ] ] { #category : 'tests' } @@ -781,7 +778,6 @@ MCPToolRepositoryOperationTest >> testDiffParsesAndDispatchesToDiffCommand [ self assert: parsedRequest class equals: MCPRepositoryDiffRequest. self assert: parsedRequest operation equals: 'diff'. self assert: command class equals: MCPRepositoryDiffCommand - ] { #category : 'tests' } @@ -1024,34 +1020,34 @@ MCPToolRepositoryOperationTest >> testPullReportsIcebergMergeAndLoadErrors [ repository failPull: IceMergeAborted -> 'Iceberg merge failed for test repository'. self withRegisteredRepository: repository do: [ - mergeErrorResult := self callToolWith: { - (#action -> 'pull'). - (#repositoryName -> repository name) } - asDictionary. - self assert: (mergeErrorResult at: #isError ifAbsent: [ false ]). - self assert: - ((self summaryFrom: mergeErrorResult) includesSubstring: - 'Failed to pull repository'). - self assert: - ((self summaryFrom: mergeErrorResult) includesSubstring: - 'Iceberg merge failed') ]. + mergeErrorResult := self callToolWith: { + (#action -> 'pull'). + (#repositoryName -> repository name) } + asDictionary. + self assert: (mergeErrorResult at: #isError ifAbsent: [ false ]). + self assert: + ((self summaryFrom: mergeErrorResult) includesSubstring: + 'Failed to pull repository'). + self assert: + ((self summaryFrom: mergeErrorResult) includesSubstring: + 'Iceberg merge failed') ]. repository := self newTestRepositoryNamed: 'MCP Pull Load Error Test Repository'. repository failPull: IceCheckoutConflictError -> 'Iceberg load failed for test repository'. self withRegisteredRepository: repository do: [ - loadErrorResult := self callToolWith: { - (#action -> 'pull'). - (#repositoryName -> repository name) } - asDictionary. - self assert: (loadErrorResult at: #isError ifAbsent: [ false ]). - self assert: - ((self summaryFrom: loadErrorResult) includesSubstring: - 'Failed to pull repository'). - self assert: - ((self summaryFrom: loadErrorResult) includesSubstring: - 'Iceberg load failed') ] + loadErrorResult := self callToolWith: { + (#action -> 'pull'). + (#repositoryName -> repository name) } + asDictionary. + self assert: (loadErrorResult at: #isError ifAbsent: [ false ]). + self assert: + ((self summaryFrom: loadErrorResult) includesSubstring: + 'Failed to pull repository'). + self assert: + ((self summaryFrom: loadErrorResult) includesSubstring: + 'Iceberg load failed') ] ] { #category : 'tests' } @@ -1103,33 +1099,33 @@ MCPToolRepositoryOperationTest >> testPushReportsRemoteAndAuthenticationErrors [ repository failPush: IceRemoteNotFoundError -> 'Iceberg remote not found for test repository'. self withRegisteredRepository: repository do: [ - remoteErrorResult := self callToolWith: { - (#action -> 'push'). - (#repositoryName -> repository name) } - asDictionary. - self assert: (remoteErrorResult at: #isError ifAbsent: [ false ]). - self assert: - ((self summaryFrom: remoteErrorResult) includesSubstring: - 'Failed to push repository'). - self assert: - ((self summaryFrom: remoteErrorResult) includesSubstring: - 'Iceberg remote not found') ]. + remoteErrorResult := self callToolWith: { + (#action -> 'push'). + (#repositoryName -> repository name) } + asDictionary. + self assert: (remoteErrorResult at: #isError ifAbsent: [ false ]). + self assert: + ((self summaryFrom: remoteErrorResult) includesSubstring: + 'Failed to push repository'). + self assert: + ((self summaryFrom: remoteErrorResult) includesSubstring: + 'Iceberg remote not found') ]. repository := self newTestRepositoryNamed: 'MCP Push Authentication Error Test Repository'. repository failPush: IceAuthenticationError -> 'Iceberg authentication failed for test repository'. self withRegisteredRepository: repository do: [ - authErrorResult := self callToolWith: { - (#action -> 'push'). - (#repositoryName -> repository name) } - asDictionary. - self assert: (authErrorResult at: #isError ifAbsent: [ false ]). - self assert: - ((self summaryFrom: authErrorResult) includesSubstring: - 'Failed to push repository'). - self assert: - ((self summaryFrom: authErrorResult) includesSubstring: - 'Iceberg authentication failed') ] + authErrorResult := self callToolWith: { + (#action -> 'push'). + (#repositoryName -> repository name) } + asDictionary. + self assert: (authErrorResult at: #isError ifAbsent: [ false ]). + self assert: + ((self summaryFrom: authErrorResult) includesSubstring: + 'Failed to push repository'). + self assert: + ((self summaryFrom: authErrorResult) includesSubstring: + 'Iceberg authentication failed') ] ] { #category : 'tests' } @@ -1240,15 +1236,14 @@ MCPToolRepositoryOperationTest >> testRepositoryErrorDetailsUseActionNotOperatio 'MCP Repository Error Action Test Repository'. repository failPush: true. self withRegisteredRepository: repository do: [ - result := self callToolWith: { - (#action -> 'push'). - (#repositoryName -> repository name) } asDictionary. - self assert: (result at: #isError ifAbsent: [ false ]). - errorDetails := self errorFrom: result. - self assert: (errorDetails at: #action) equals: 'push'. - self deny: (errorDetails includesKey: #operation). - self deny: (errorDetails includesKey: #updateAction) ] - + result := self callToolWith: { + (#action -> 'push'). + (#repositoryName -> repository name) } asDictionary. + self assert: (result at: #isError ifAbsent: [ false ]). + errorDetails := self errorFrom: result. + self assert: (errorDetails at: #action) equals: 'push'. + self deny: (errorDetails includesKey: #operation). + self deny: (errorDetails includesKey: #updateAction) ] ] { #category : 'tests' } @@ -1415,34 +1410,36 @@ MCPToolRepositoryOperationTest >> testUpdateCanReplacePackageMembership [ | data repository result | repository := self - newRepositoryNamed: 'MCP Repository Command Replace Test' + newRepositoryNamed: + 'MCP Repository Command Replace Test' location: FileLocator imageDirectory packageNames: #( 'MCPToolRepositoryOperationOldA' 'MCPToolRepositoryOperationOldB' ). self withRegisteredRepository: repository do: [ - result := self callToolWith: { - (#action -> 'update'). - (#repositoryName -> repository name). - (#packageNames - -> - #( 'MCPToolRepositoryOperationNewC' - 'MCPToolRepositoryOperationOldB' )) } asDictionary. - data := self dataFrom: result. - self deny: (result at: #isError ifAbsent: [ false ]). - self - assert: (self packageNamesIn: repository) - equals: - #( 'MCPToolRepositoryOperationNewC' 'MCPToolRepositoryOperationOldB' ). - self - assert: (data at: #updateActions) - equals: #( 'replacePackages' ). - self - assert: (data at: #addedPackageNames) - equals: #( 'MCPToolRepositoryOperationNewC' ). - self - assert: (data at: #removedPackageNames) - equals: #( 'MCPToolRepositoryOperationOldA' ) ] + result := self callToolWith: { + (#action -> 'update'). + (#repositoryName -> repository name). + (#packageNames + -> + #( 'MCPToolRepositoryOperationNewC' + 'MCPToolRepositoryOperationOldB' )) } asDictionary. + data := self dataFrom: result. + self deny: (result at: #isError ifAbsent: [ false ]). + self + assert: (self packageNamesIn: repository) + equals: + #( 'MCPToolRepositoryOperationNewC' + 'MCPToolRepositoryOperationOldB' ). + self + assert: (data at: #updateActions) + equals: #( 'replacePackages' ). + self + assert: (data at: #addedPackageNames) + equals: #( 'MCPToolRepositoryOperationNewC' ). + self + assert: (data at: #removedPackageNames) + equals: #( 'MCPToolRepositoryOperationOldA' ) ] ] { #category : 'tests' } @@ -1510,12 +1507,13 @@ MCPToolRepositoryOperationTest >> testVerifyIdentityOperationRequiresRepositoryA parsedRequest := tool parsedRequestFromToolRequest: rawRequest. command := tool commandForRequest: parsedRequest. - self assert: parsedRequest class equals: MCPRepositoryVerifyIdentityRequest. + self + assert: parsedRequest class + equals: MCPRepositoryVerifyIdentityRequest. self assert: parsedRequest operation equals: 'verifyIdentity'. self assert: parsedRequest branchName equals: 'main'. self assert: parsedRequest isModified equals: false. self assert: command class equals: MCPRepositoryVerifyIdentityCommand - ] { #category : 'tests' } @@ -1584,24 +1582,24 @@ MCPToolRepositoryOperationTest >> testVerifyIdentityReportsWrongLocationAsIdenti repository := self newTestRepositoryNamed: 'MCP VerifyIdentity Location Mismatch Test Repository'. self withRegisteredRepository: repository do: [ - result := self callToolWith: { - (#action -> 'verifyIdentity'). - (#repositoryName -> repository name). - (#location -> 'memory://different-location') } - asDictionary. - self assert: (result at: #isError ifAbsent: [ false ]). - errorDetails := self errorFrom: result. - self - assert: (errorDetails at: #errorCode) - equals: 'RepositoryIdentityMismatch'. - locationMismatch := (errorDetails at: #mismatches) detect: [ - :each | (each at: #field) = 'location' ]. - self - assert: (locationMismatch at: #expected) - equals: 'memory://different-location'. - self - assert: (locationMismatch at: #actual) - equals: repository location ] + result := self callToolWith: { + (#action -> 'verifyIdentity'). + (#repositoryName -> repository name). + (#location -> 'memory://different-location') } + asDictionary. + self assert: (result at: #isError ifAbsent: [ false ]). + errorDetails := self errorFrom: result. + self + assert: (errorDetails at: #errorCode) + equals: 'RepositoryIdentityMismatch'. + locationMismatch := (errorDetails at: #mismatches) detect: [ :each | + (each at: #field) = 'location' ]. + self + assert: (locationMismatch at: #expected) + equals: 'memory://different-location'. + self + assert: (locationMismatch at: #actual) + equals: repository location ] ] { #category : 'tests' } @@ -1611,17 +1609,16 @@ MCPToolRepositoryOperationTest >> testVerifyIdentityRequiresExpectedIdentityFiel repository := self newTestRepositoryNamed: 'MCP VerifyIdentity Missing Expected Field Test Repository'. self withRegisteredRepository: repository do: [ - result := self callToolWith: { - (#action -> 'verifyIdentity'). - (#repositoryName -> repository name) } asDictionary. - self assert: (result at: #isError ifAbsent: [ false ]). - errorDetails := self errorFrom: result. - self - assert: (errorDetails at: #errorCode) - equals: 'RepositoryIdentityExpectationRequired'. - self assert: - ((self summaryFrom: result) includesSubstring: - 'requires at least one expected identity field') ] + result := self callToolWith: { + (#action -> 'verifyIdentity'). + (#repositoryName -> repository name) } asDictionary. + self assert: (result at: #isError ifAbsent: [ false ]). + errorDetails := self errorFrom: result. + self + assert: (errorDetails at: #errorCode) + equals: 'RepositoryIdentityExpectationRequired'. + self assert: ((self summaryFrom: result) includesSubstring: + 'requires at least one expected identity field') ] ] { #category : 'private - fixtures' } @@ -1668,23 +1665,23 @@ MCPToolRepositoryOperationTest >> toolName [ MCPToolRepositoryOperationTest >> withCleanRepositoryNamed: aRepositoryName location: aFileReference do: aBlock [ [ - self removeRegisteredRepositoriesNamed: aRepositoryName. - self deleteDirectoryIfExists: aFileReference. - aBlock value ] ensure: [ self removeRegisteredRepositoriesNamed: aRepositoryName. - self deleteDirectoryIfExists: aFileReference ] + self deleteDirectoryIfExists: aFileReference. + aBlock value ] ensure: [ + self removeRegisteredRepositoriesNamed: aRepositoryName. + self deleteDirectoryIfExists: aFileReference ] ] { #category : 'private - classes' } MCPToolRepositoryOperationTest >> withExportPackageNamed: aPackageName className: aClassName do: aBlock [ [ - self removeClassNamed: aClassName. - self removePackageNamed: aPackageName. - self createClassNamed: aClassName inPackageNamed: aPackageName. - aBlock value ] ensure: [ self removeClassNamed: aClassName. - self removePackageNamed: aPackageName ] + self removePackageNamed: aPackageName. + self createClassNamed: aClassName inPackageNamed: aPackageName. + aBlock value ] ensure: [ + self removeClassNamed: aClassName. + self removePackageNamed: aPackageName ] ] { #category : 'private' } diff --git a/src/MCP-Tests/MCPToolRequestTest.class.st b/src/MCP-Tests/MCPToolRequestTest.class.st index 26b4c33..49a0cfc 100644 --- a/src/MCP-Tests/MCPToolRequestTest.class.st +++ b/src/MCP-Tests/MCPToolRequestTest.class.st @@ -26,9 +26,9 @@ MCPToolRequestTest >> testInvalidRequestRaisesInvalidParameters [ self should: [ - MCPToolRequest - tool: MCPToolSearchClasses new - arguments: { (#caseSensitive -> 'true') } asDictionary ] + MCPToolRequest + tool: MCPToolSearchClasses new + arguments: { (#caseSensitive -> 'true') } asDictionary ] raise: JRPCInvalidParameters ] @@ -37,9 +37,9 @@ MCPToolRequestTest >> testInvalidRequestRaisesToolInputErrorWithViolations [ | error violation | [ - MCPToolRequest - tool: MCPToolSearchClasses new - arguments: { (#caseSensitive -> 'true') } asDictionary ] + MCPToolRequest + tool: MCPToolSearchClasses new + arguments: { (#caseSensitive -> 'true') } asDictionary ] on: MCPInvalidToolInput do: [ :signalledError | error := signalledError ]. self assert: error isNotNil. @@ -57,9 +57,9 @@ MCPToolRequestTest >> testInvalidToolInputErrorResponseIncludesViolations [ | data error errorJson firstViolation response violations | [ - MCPToolRequest - tool: MCPToolSearchClasses new - arguments: { (#caseSensitive -> 'true') } asDictionary ] + MCPToolRequest + tool: MCPToolSearchClasses new + arguments: { (#caseSensitive -> 'true') } asDictionary ] on: MCPInvalidToolInput do: [ :signalledError | error := signalledError ]. response := (error asJRPCResponseWithId: 7) asJRPCJSON. diff --git a/src/MCP-Tests/MCPToolSearchPackagesTest.class.st b/src/MCP-Tests/MCPToolSearchPackagesTest.class.st index 6613614..d1f79a6 100644 --- a/src/MCP-Tests/MCPToolSearchPackagesTest.class.st +++ b/src/MCP-Tests/MCPToolSearchPackagesTest.class.st @@ -13,11 +13,11 @@ Class { MCPToolSearchPackagesTest >> createFixtureClassNamed: aClassName packageName: aPackageName tag: aTag [ ^ self withoutEpiceaDuring: [ - | builder | - builder := Object << aClassName asSymbol. - builder package: aPackageName. - builder tag: aTag. - builder install ] + | builder | + builder := Object << aClassName asSymbol. + builder package: aPackageName. + builder tag: aTag. + builder install ] ] { #category : 'private' } @@ -234,31 +234,31 @@ MCPToolSearchPackagesTest >> withTemporaryTaggedPackagesDo: aBlock [ self removePackageNamed: alphaPackageName. self removePackageNamed: betaPackageName. [ - self - createFixtureClassNamed: alphaClassName - packageName: alphaPackageName - tag: 'FixtureAlphaTag'. - self - createFixtureClassNamed: betaClassName - packageName: betaPackageName - tag: 'FixtureBetaTag'. - alphaPackage := PackageOrganizer default packageNamed: - alphaPackageName asSymbol. - betaPackage := PackageOrganizer default packageNamed: - betaPackageName asSymbol. - packageProjectNames := Dictionary new - at: alphaPackageName - put: #( 'FixtureProject' ); - at: betaPackageName - put: #( 'FixtureProject' ); - yourself. - aBlock - value: { - alphaPackage. - betaPackage } asArray - value: packageProjectNames ] ensure: [ - self removeClassNamed: alphaClassName. - self removeClassNamed: betaClassName. - self removePackageNamed: alphaPackageName. - self removePackageNamed: betaPackageName ] + self + createFixtureClassNamed: alphaClassName + packageName: alphaPackageName + tag: 'FixtureAlphaTag'. + self + createFixtureClassNamed: betaClassName + packageName: betaPackageName + tag: 'FixtureBetaTag'. + alphaPackage := PackageOrganizer default packageNamed: + alphaPackageName asSymbol. + betaPackage := PackageOrganizer default packageNamed: + betaPackageName asSymbol. + packageProjectNames := Dictionary new + at: alphaPackageName + put: #( 'FixtureProject' ); + at: betaPackageName + put: #( 'FixtureProject' ); + yourself. + aBlock + value: { + alphaPackage. + betaPackage } asArray + value: packageProjectNames ] ensure: [ + self removeClassNamed: alphaClassName. + self removeClassNamed: betaClassName. + self removePackageNamed: alphaPackageName. + self removePackageNamed: betaPackageName ] ] diff --git a/src/MCP-Tests/MCPToolSearchRepositoriesTest.class.st b/src/MCP-Tests/MCPToolSearchRepositoriesTest.class.st index 0e64c5a..bad3e49 100644 --- a/src/MCP-Tests/MCPToolSearchRepositoriesTest.class.st +++ b/src/MCP-Tests/MCPToolSearchRepositoriesTest.class.st @@ -219,9 +219,9 @@ MCPToolSearchRepositoriesTest >> withRepositories: repositories do: aBlock [ registry := IceRepository registry. previousRepositories := registry copy. [ - registry removeAll. - registry addAll: repositories. - aBlock value ] ensure: [ registry removeAll. - registry addAll: previousRepositories ] + registry addAll: repositories. + aBlock value ] ensure: [ + registry removeAll. + registry addAll: previousRepositories ] ] diff --git a/src/MCP-Tests/MCPToolStructuredOutputTest.class.st b/src/MCP-Tests/MCPToolStructuredOutputTest.class.st index 17d5221..6689dbe 100644 --- a/src/MCP-Tests/MCPToolStructuredOutputTest.class.st +++ b/src/MCP-Tests/MCPToolStructuredOutputTest.class.st @@ -290,90 +290,64 @@ MCPToolStructuredOutputTest >> testRemoveClassReturnsStructuredError [ { #category : 'tests' } MCPToolStructuredOutputTest >> testRunTestClassReturnsStructuredIssues [ - | data firstIssue issueMethodNames result singleResult | - result := self callToolNamed: 'test_run' withArguments: { (#tests - -> - { { (#className -> 'MCPToolStructuredOutputTestTarget') } - asDictionary }) } asDictionary. + | data error failure result skipped | + result := self + callToolNamed: 'test_run' + withArguments: + { (#classes -> #( 'MCPToolStructuredOutputTestTarget' )) } + asDictionary. data := self dataFrom: result. - singleResult := (data at: #results) first. - issueMethodNames := (singleResult at: #issues) collect: [ :each | - each at: #testMethodName ]. - firstIssue := (singleResult at: #issues) first. self assert: ((self structuredContentFrom: result) at: #status) equals: 'ok'. - self assert: data keys asSet equals: #( #results ) asSet. - self assert: (data at: #results) size equals: 1. - self - assert: (singleResult at: #className) - equals: 'MCPToolStructuredOutputTestTarget'. - self assert: (singleResult at: #selectedTestCount) equals: 4. - self assert: (singleResult at: #runCount) equals: 3. - self assert: (singleResult at: #passedCount) equals: 1. - self assert: (singleResult at: #skippedCount) equals: 1. - self assert: (singleResult at: #failureCount) equals: 1. - self assert: (singleResult at: #errorCount) equals: 1. - self assert: (singleResult at: #issues) size equals: 3. - self assert: (issueMethodNames includes: 'testFails'). - self assert: (issueMethodNames includes: 'testErrors'). - self assert: (issueMethodNames includes: 'testSkips'). - self assert: (firstIssue includesKey: #message). - self - assert: (firstIssue at: #className) - equals: 'MCPToolStructuredOutputTestTarget'. - self deny: (firstIssue includesKey: #testName). - self deny: (data includesKey: #tests). - self deny: (data includesKey: #selectionCount). - self deny: (data includesKey: #runCount). - self deny: (data includesKey: #passedCount). - self deny: (data includesKey: #skippedCount). - self deny: (data includesKey: #failureCount). - self deny: (data includesKey: #errorCount). - self deny: (data includesKey: #failingTestNames). + self assert: (data at: #runCount) equals: 3. + self assert: (data at: #passedCount) equals: 1. + skipped := data at: #skipped. + failure := (data at: #failures) first. + error := (data at: #errors) first. + self + assert: skipped + equals: #( 'MCPToolStructuredOutputTestTarget>>#testSkips' ). + self + assert: (failure at: #test) + equals: 'MCPToolStructuredOutputTestTarget>>#testFails'. + self assert: + ((failure at: #message) includesSubstring: 'boom failure'). + self + assert: (error at: #test) + equals: 'MCPToolStructuredOutputTestTarget>>#testErrors'. + self assert: (error at: #errorClass) equals: 'Error'. + self assert: ((error at: #message) includesSubstring: 'boom error'). + self deny: (data includesKey: #results). self deny: (data includesKey: #issues) ] { #category : 'tests' } MCPToolStructuredOutputTest >> testRunTestMethodReturnsStructuredIssues [ - | data firstIssue methodResult result | + | data failure result | result := self callToolNamed: 'test_run' - withArguments: { (#tests -> { { - (#className -> 'MCPToolStructuredOutputTestTarget'). - (#testMethodName -> 'testFails') } asDictionary }) } + withArguments: + { (#methods + -> #( 'MCPToolStructuredOutputTestTarget>>#testFails' )) } asDictionary. data := self dataFrom: result. - methodResult := (data at: #results) first. - firstIssue := (methodResult at: #issues) first. + failure := (data at: #failures) first. self assert: ((self structuredContentFrom: result) at: #status) equals: 'ok'. - self assert: data keys asSet equals: #( #results ) asSet. - self assert: (data at: #results) size equals: 1. - self assert: (methodResult at: #selectedTestCount) equals: 1. - self assert: (methodResult at: #runCount) equals: 1. - self assert: (methodResult at: #passedCount) equals: 0. - self assert: (methodResult at: #skippedCount) equals: 0. - self assert: (methodResult at: #failureCount) equals: 1. - self assert: (methodResult at: #errorCount) equals: 0. - self assert: (methodResult at: #testMethodName) equals: 'testFails'. - self assert: (methodResult at: #issues) size equals: 1. - self assert: (firstIssue at: #testMethodName) equals: 'testFails'. - self - assert: (firstIssue at: #className) - equals: 'MCPToolStructuredOutputTestTarget'. - self deny: (firstIssue includesKey: #testName). - self deny: (data includesKey: #tests). - self deny: (data includesKey: #selectionCount). - self deny: (data includesKey: #runCount). - self deny: (data includesKey: #passedCount). - self deny: (data includesKey: #skippedCount). - self deny: (data includesKey: #failureCount). - self deny: (data includesKey: #errorCount). - self deny: (data includesKey: #failingTestNames). - self deny: (data includesKey: #issues) + self assert: (data at: #runCount) equals: 1. + self assert: (data at: #passedCount) equals: 0. + self assert: (data at: #failures) size equals: 1. + self + assert: (failure at: #test) + equals: 'MCPToolStructuredOutputTestTarget>>#testFails'. + self assert: + ((failure at: #message) includesSubstring: 'boom failure'). + self deny: (data includesKey: #results). + self deny: (data includesKey: #skipped). + self deny: (data includesKey: #errors) ] { #category : 'tests' } @@ -381,10 +355,7 @@ MCPToolStructuredOutputTest >> testRunTestsCoverageCanIncludeCoveredMethodsAndCa | coverage coveredSelectors data result | result := self callToolNamed: 'test_coverage_run' withArguments: { - (#tests - -> - { { (#className -> 'MCPToolCoverageTargetTest') } - asDictionary }). + (#classes -> #( 'MCPToolCoverageTargetTest' )). (#coverage -> { (#scope -> @@ -399,6 +370,8 @@ MCPToolStructuredOutputTest >> testRunTestsCoverageCanIncludeCoveredMethodsAndCa self assert: ((self structuredContentFrom: result) at: #status) equals: 'ok'. + self assert: (data at: #runCount) equals: 2. + self assert: (data at: #passedCount) equals: 2. self assert: (coverage at: #coveredMethodCount) equals: 2. self assert: (coverage at: #coveredMethods) size equals: 1. self assert: (coverage at: #coveredMethodsTruncated). @@ -410,10 +383,7 @@ MCPToolStructuredOutputTest >> testRunTestsCoverageRequiresExplicitScope [ | error result | result := self callToolNamed: 'test_coverage_run' withArguments: { - (#tests - -> - { { (#className -> 'MCPToolCoverageTargetTest') } - asDictionary }). + (#classes -> #( 'MCPToolCoverageTargetTest' )). (#coverage -> Dictionary new) } asDictionary. error := self errorFrom: result. self assert: (result at: #isError). @@ -428,12 +398,9 @@ MCPToolStructuredOutputTest >> testRunTestsCoverageRequiresExplicitScope [ { #category : 'tests' } MCPToolStructuredOutputTest >> testRunTestsCoverageReturnsStructuredCoverage [ - | coverage data partialSelectors result singleResult uncoveredSelectors | + | coverage data partialSelectors result uncoveredSelectors | result := self callToolNamed: 'test_coverage_run' withArguments: { - (#tests - -> - { { (#className -> 'MCPToolCoverageTargetTest') } - asDictionary }). + (#classes -> #( 'MCPToolCoverageTargetTest' )). (#coverage -> { (#scope -> @@ -442,7 +409,6 @@ MCPToolStructuredOutputTest >> testRunTestsCoverageReturnsStructuredCoverage [ (#methodLimit -> 10) } asDictionary) } asDictionary. data := self dataFrom: result. coverage := data at: #coverage. - singleResult := (data at: #results) first. uncoveredSelectors := (coverage at: #uncoveredMethods) collect: [ :each | each at: #selector ]. partialSelectors := (coverage at: #partiallyCoveredMethods) collect: [ @@ -452,7 +418,9 @@ MCPToolStructuredOutputTest >> testRunTestsCoverageReturnsStructuredCoverage [ equals: 'ok'. self assert: ((self summaryFrom: result) includesSubstring: 'Coverage:'). - self assert: (singleResult at: #runCount) equals: 2. + self assert: (data at: #runCount) equals: 2. + self assert: (data at: #passedCount) equals: 2. + self deny: (data includesKey: #results). self assert: (coverage at: #methodCount) equals: 3. self assert: (coverage at: #coveredMethodCount) equals: 2. self assert: (coverage at: #fullyCoveredMethodCount) equals: 1. @@ -468,94 +436,71 @@ MCPToolStructuredOutputTest >> testRunTestsCoverageReturnsStructuredCoverage [ { #category : 'tests' } MCPToolStructuredOutputTest >> testRunTestsDeduplicatesConcreteCasesAcrossSelections [ - | data result singleResult | - result := self - callToolNamed: 'test_run' - withArguments: { (#tests -> { - { (#className -> 'MCPToolStructuredOutputTestTarget') } - asDictionary. - { - (#className -> 'MCPToolStructuredOutputTestTarget'). - (#testMethodName -> 'testFails') } asDictionary. - { (#className -> 'MCPToolStructuredOutputTestTarget') } - asDictionary }) } asDictionary. + | data result | + result := self callToolNamed: 'test_run' withArguments: { + (#classes -> #( 'MCPToolStructuredOutputTestTarget' )). + (#methods + -> #( 'MCPToolStructuredOutputTestTarget>>#testFails' )) } + asDictionary. data := self dataFrom: result. - singleResult := (data at: #results) first. self assert: ((self structuredContentFrom: result) at: #status) equals: 'ok'. - self assert: (data at: #results) size equals: 1. - self - assert: (singleResult at: #className) - equals: 'MCPToolStructuredOutputTestTarget'. - self assert: (singleResult at: #selectedTestCount) equals: 4. - self assert: (singleResult at: #runCount) equals: 3. - self assert: (singleResult at: #passedCount) equals: 1. - self assert: (singleResult at: #skippedCount) equals: 1. - self assert: (singleResult at: #failureCount) equals: 1. - self assert: (singleResult at: #errorCount) equals: 1 + self assert: (data at: #runCount) equals: 3. + self assert: (data at: #passedCount) equals: 1. + self assert: (data at: #skipped) size equals: 1. + self assert: (data at: #failures) size equals: 1. + self assert: (data at: #errors) size equals: 1 ] { #category : 'tests' } MCPToolStructuredOutputTest >> testRunTestsDeduplicatesUnrunCasesAcrossSelections [ - | data result unrunMethodNames | + | data result | result := self callToolNamed: 'test_run' withArguments: { - (#tests -> { - { (#className -> 'MCPToolStructuredOutputTestTarget') } - asDictionary. - { - (#className -> 'MCPToolStructuredOutputTestTarget'). - (#testMethodName -> 'testFails') } asDictionary. - { (#className -> 'MCPToolStructuredOutputTestTarget') } - asDictionary }). + (#classes -> #( 'MCPToolStructuredOutputTestTarget' )). + (#methods + -> #( 'MCPToolStructuredOutputTestTarget>>#testFails' )). (#timeoutSeconds -> 0) } asDictionary. data := self dataFrom: result. - unrunMethodNames := ((data at: #unrunTests) collect: [ :each | - each at: #testMethodName ]) asSet. self assert: ((self structuredContentFrom: result) at: #status) equals: 'ok'. self assert: (data at: #timedOut) equals: true. - self assert: (data at: #results) isEmpty. - self assert: (data at: #unrunTests) size equals: 4. + self assert: (data at: #runCount) equals: 0. + self assert: (data at: #passedCount) equals: 0. self - assert: unrunMethodNames - equals: #( 'testErrors' 'testFails' 'testPasses' 'testSkips' ) asSet + assert: (data at: #unrunClasses) + equals: #( 'MCPToolStructuredOutputTestTarget' ). + self deny: (data includesKey: #unrunMethods). + self deny: (data includesKey: #results) ] { #category : 'tests' } MCPToolStructuredOutputTest >> testRunTestsParameterizedMethodFailureIncludesCaseDetails [ - | data issue methodResult result | - result := self - callToolNamed: 'test_run' - withArguments: { (#tests -> { { - (#className -> 'MCPToolRunTestsParameterizedTarget'). - (#testMethodName -> 'testFailsOnlyForUTF16') } - asDictionary }) } asDictionary. + | data issue result | + result := self callToolNamed: 'test_run' withArguments: { (#methods + -> + #( 'MCPToolRunTestsParameterizedTarget>>#testFailsOnlyForUTF16' )) } + asDictionary. data := self dataFrom: result. - methodResult := (data at: #results) first. - issue := (methodResult at: #issues) first. + issue := (data at: #failures) first. self assert: ((self structuredContentFrom: result) at: #status) equals: 'ok'. - self assert: (methodResult at: #runCount) equals: 3. - self - assert: (methodResult at: #testMethodName) - equals: 'testFailsOnlyForUTF16'. - self assert: (methodResult at: #issues) size equals: 1. + self assert: (data at: #runCount) equals: 3. + self assert: (data at: #passedCount) equals: 2. + self assert: (data at: #failures) size equals: 1. self - assert: (issue at: #testMethodName) - equals: 'testFailsOnlyForUTF16'. - self - assert: (issue at: #testCaseName) - equals: 'testFailsOnlyForUTF16(#encoding->''UTF-16'')'. + assert: (issue at: #test) + equals: 'MCPToolRunTestsParameterizedTarget>>#testFailsOnlyForUTF16'. self assert: (issue at: #parameters) equals: #( '#encoding->''UTF-16''' ). self assert: ((issue at: #message) includesSubstring: 'UTF-16'). - self deny: (issue includesKey: #testName) + self deny: (issue includesKey: #testName). + self deny: (issue includesKey: #testCaseName) ] { #category : 'tests' } @@ -565,109 +510,108 @@ MCPToolStructuredOutputTest >> testRunTestsParseErrorReturnsStructuredToolError result := self callToolNamed: 'test_run' withArguments: - { (#tests -> { { (#className -> '') } asDictionary }) } - asDictionary. + { (#methods -> #( 'NotAMethodReference' )) } asDictionary. structured := self structuredContentFrom: result. error := self errorFrom: result. self assert: (result at: #isError). self assert: (structured at: #status) equals: 'error'. self assert: (error at: #errorClass) equals: #Error. - self assert: (error at: #tests) equals: #( '' ). - self assert: ((error at: #message) includesSubstring: - 'tests must contain only non-empty class names') + self deny: (error includesKey: #tests). + self assert: + ((error at: #message) includesSubstring: 'Class>>#selector') ] { #category : 'tests' } -MCPToolStructuredOutputTest >> testRunTestsSkippedMethodReportsExplicitCounts [ +MCPToolStructuredOutputTest >> testRunTestsSkippedMethodReportsCompactList [ - | data issue result singleResult | + | data result | result := self callToolNamed: 'test_run' - withArguments: { (#tests -> { { - (#className -> 'MCPToolStructuredOutputTestTarget'). - (#testMethodName -> 'testSkips') } asDictionary }) } + withArguments: + { (#methods + -> #( 'MCPToolStructuredOutputTestTarget>>#testSkips' )) } asDictionary. data := self dataFrom: result. - singleResult := (data at: #results) first. - issue := (singleResult at: #issues) first. self assert: ((self structuredContentFrom: result) at: #status) equals: 'ok'. - self assert: (data at: #results) size equals: 1. - self assert: (singleResult at: #selectedTestCount) equals: 1. - self assert: (singleResult at: #runCount) equals: 0. - self assert: (singleResult at: #passedCount) equals: 0. - self assert: (singleResult at: #skippedCount) equals: 1. - self assert: (singleResult at: #failureCount) equals: 0. - self assert: (singleResult at: #errorCount) equals: 0. - self assert: (singleResult at: #testMethodName) equals: 'testSkips'. - self assert: (issue at: #kind) equals: 'skipped'. - self assert: (issue at: #testMethodName) equals: 'testSkips' + self assert: (data at: #runCount) equals: 0. + self assert: (data at: #passedCount) equals: 0. + self + assert: (data at: #skipped) + equals: #( 'MCPToolStructuredOutputTestTarget>>#testSkips' ). + self deny: (data includesKey: #failures). + self deny: (data includesKey: #errors) ] { #category : 'tests' } -MCPToolStructuredOutputTest >> testRunTestsSuccessfulResultOmitsEmptyIssues [ +MCPToolStructuredOutputTest >> testRunTestsSuccessfulResultOmitsEmptyIssueLists [ - | data result singleResult | + | data result | result := self callToolNamed: 'test_run' - withArguments: { (#tests -> { { - (#className -> 'MCPToolStructuredOutputTestTarget'). - (#testMethodName -> 'testPasses') } asDictionary }) } + withArguments: + { (#methods + -> #( 'MCPToolStructuredOutputTestTarget>>#testPasses' )) } asDictionary. data := self dataFrom: result. - singleResult := (data at: #results) first. self assert: ((self structuredContentFrom: result) at: #status) equals: 'ok'. - self assert: (singleResult at: #runCount) equals: 1. - self deny: (singleResult includesKey: #issues) + self assert: (data at: #runCount) equals: 1. + self assert: (data at: #passedCount) equals: 1. + self deny: (data includesKey: #skipped). + self deny: (data includesKey: #failures). + self deny: (data includesKey: #errors). + self deny: (data includesKey: #results) ] { #category : 'tests' } -MCPToolStructuredOutputTest >> testRunTestsTimeoutReturnsPartialResultsAndUnrunTestsCanResume [ - - | data partialResult resumedData resumedResult result unrunTests | - result := self callToolNamed: 'test_run' withArguments: { - (#tests -> { - { (#className -> 'MCPToolRunTestsTimeoutTarget') } - asDictionary. - { - (#className -> 'MCPToolRequestTest'). - (#testMethodName - -> 'testValidRequestProvidesTypedAccessors') } - asDictionary }). - (#timeoutMilliseconds -> 100) } asDictionary. - data := self dataFrom: result. - self - assert: ((self structuredContentFrom: result) at: #status) - equals: 'ok'. +MCPToolStructuredOutputTest >> testRunTestsTimeoutReturnsPartialResultsAndUnrunSelectionsCanResume [ + + | data request resumedData resumedResult result runTestsRequest tool | + tool := MCPToolRunTests new. + runTestsRequest := MCPRunTestsRequest new + initializeTestRequests: { + (MCPTestRunRequest className: + 'MCPToolRunTestsTimeoutTarget'). + (MCPTestRunRequest className: + 'MCPToolCoverageTargetTest'). + (MCPTestRunRequest packageName: + 'MCP-Spec-Tests') } + timeoutMilliseconds: 100 + operation: 'run' + coverageRequest: nil. + result := (tool commandForRequest: runTestsRequest) execute. + data := result asDictionary. self assert: (data at: #timedOut). - partialResult := (data at: #results) first. - self - assert: (partialResult at: #className) - equals: 'MCPToolRunTestsTimeoutTarget'. - self assert: (partialResult at: #runCount) equals: 1. - unrunTests := data at: #unrunTests. - self assert: (unrunTests anySatisfy: [ :each | - (each at: #className) = 'MCPToolRunTestsTimeoutTarget' and: [ - (each at: #testMethodName) = 'testSlowPass' ] ]). - self assert: (unrunTests anySatisfy: [ :each | - (each at: #className) = 'MCPToolRequestTest' and: [ - (each at: #testMethodName) - = 'testValidRequestProvidesTypedAccessors' ] ]). - resumedResult := self callToolNamed: 'test_run' withArguments: { - (#tests -> unrunTests). - (#timeoutMilliseconds -> 1000) } asDictionary. + self assert: (data at: #runCount) equals: 1. + self assert: (data at: #passedCount) equals: 1. + self + assert: (data at: #unrunMethods) + equals: #( 'MCPToolRunTestsTimeoutTarget>>#testSlowPass' ). + self + assert: (data at: #unrunClasses) + equals: #( 'MCPToolCoverageTargetTest' ). + self assert: (data at: #unrunPackages) equals: #( 'MCP-Spec-Tests' ). + request := Dictionary new + at: #methods put: (data at: #unrunMethods); + at: #classes put: (data at: #unrunClasses); + at: #packages put: (data at: #unrunPackages); + at: #timeoutSeconds put: 30; + yourself. + resumedResult := self + callToolNamed: 'test_run' + withArguments: request. resumedData := self dataFrom: resumedResult. self assert: ((self structuredContentFrom: resumedResult) at: #status) equals: 'ok'. self deny: (resumedData includesKey: #timedOut). self - assert: - ((resumedData at: #results) sum: [ :each | each at: #runCount ]) - equals: unrunTests size + assert: (resumedData at: #passedCount) + equals: (resumedData at: #runCount). + self assert: (resumedData at: #runCount) > 3 ] { #category : 'tests' } diff --git a/src/MCP-Tests/MCPUpdateClassCommandTest.class.st b/src/MCP-Tests/MCPUpdateClassCommandTest.class.st index 2fdce20..9fd9478 100644 --- a/src/MCP-Tests/MCPUpdateClassCommandTest.class.st +++ b/src/MCP-Tests/MCPUpdateClassCommandTest.class.st @@ -12,22 +12,36 @@ Class { { #category : 'private' } MCPUpdateClassCommandTest >> classToolClassForArguments: arguments slotAction: slotAction [ - ((arguments includesKey: #superclassName) and: [ arguments includesKey: #packageName ]) ifTrue: [ ^ MCPToolCreateClass ]. + ((arguments includesKey: #superclassName) and: [ + arguments includesKey: #packageName ]) ifTrue: [ + ^ MCPToolCreateClass ]. slotAction = 'add' ifTrue: [ ^ MCPToolAddClassSlot ]. slotAction = 'remove' ifTrue: [ ^ MCPToolRemoveClassSlot ]. slotAction = 'rename' ifTrue: [ ^ MCPToolUpdateClassSlotName ]. slotAction = 'pullUp' ifTrue: [ ^ MCPToolPullUpClassSlot ]. slotAction = 'pushDown' ifTrue: [ ^ MCPToolPushDownClassSlot ]. - (arguments includesKey: #newClassName) ifTrue: [ ^ MCPToolUpdateClassName ]. - (arguments includesKey: #classComment) ifTrue: [ ^ MCPToolUpdateClassComment ]. - (arguments includesKey: #traits) ifTrue: [ ^ MCPToolUpdateClassTraits ]. - (arguments includesKey: #classTraits) ifTrue: [ ^ MCPToolUpdateClassSideTraits ]. - (arguments includesKey: #sharedVariables) ifTrue: [ ^ MCPToolUpdateClassSharedVariables ]. - (arguments includesKey: #sharedPools) ifTrue: [ ^ MCPToolUpdateClassSharedPools ]. - (arguments includesKey: #layout) ifTrue: [ ^ MCPToolUpdateClassLayout ]. - ((arguments includesKey: #slots) or: [ arguments includesKey: #classSlots ]) ifTrue: [ ^ MCPToolUpdateClassSlots ]. - (arguments includesKey: #superclassName) ifTrue: [ ^ MCPToolUpdateClassSuperclass ]. - ((arguments includesKey: #packageName) or: [ arguments includesKey: #tag ]) ifTrue: [ ^ MCPToolUpdateClassPackage ]. + (arguments includesKey: #newClassName) ifTrue: [ + ^ MCPToolUpdateClassName ]. + (arguments includesKey: #classComment) ifTrue: [ + ^ MCPToolUpdateClassComment ]. + (arguments includesKey: #traits) ifTrue: [ + ^ MCPToolUpdateClassTraits ]. + (arguments includesKey: #classTraits) ifTrue: [ + ^ MCPToolUpdateClassSideTraits ]. + (arguments includesKey: #sharedVariables) ifTrue: [ + ^ MCPToolUpdateClassSharedVariables ]. + (arguments includesKey: #sharedPools) ifTrue: [ + ^ MCPToolUpdateClassSharedPools ]. + (arguments includesKey: #layout) ifTrue: [ + ^ MCPToolUpdateClassLayout ]. + ((arguments includesKey: #slots) or: [ + arguments includesKey: #classSlots ]) ifTrue: [ + ^ MCPToolUpdateClassSlots ]. + (arguments includesKey: #superclassName) ifTrue: [ + ^ MCPToolUpdateClassSuperclass ]. + ((arguments includesKey: #packageName) or: [ + arguments includesKey: #tag ]) ifTrue: [ + ^ MCPToolUpdateClassPackage ]. ^ MCPToolUpdateClassComment ] @@ -36,7 +50,7 @@ MCPUpdateClassCommandTest >> commandForArguments: arguments [ | mutationRequest rawArguments slotAction tool toolClass toolRequest | rawArguments := arguments copy. - rawArguments removeKey: #action ifAbsent: [ ]. + rawArguments removeKey: #action ifAbsent: [ ]. slotAction := rawArguments removeKey: #slotAction ifAbsent: [ nil ]. toolClass := self classToolClassForArguments: rawArguments @@ -52,15 +66,15 @@ MCPUpdateClassCommandTest >> testAppliedChangeResultWrapsPlanAndResult [ | appliedChange changeResult data plan | plan := MCPClassUpdatePlanInfo - updateAction: 'setComment' - requestedContext: { (#className -> 'Object') } asDictionary. + updateAction: 'setComment' + requestedContext: { (#className -> 'Object') } asDictionary. changeResult := MCPChangeClassCommentResult - classInfo: (MCPClassInfo fromClass: Object) - oldClassComment: 'old' - newClassComment: 'new'. + classInfo: (MCPClassInfo fromClass: Object) + oldClassComment: 'old' + newClassComment: 'new'. appliedChange := MCPClassAppliedChangeResult - updatePlan: plan - changeResult: changeResult. + updatePlan: plan + changeResult: changeResult. data := appliedChange asDictionary. self assert: data isEmpty ] @@ -264,9 +278,9 @@ MCPUpdateClassCommandTest >> testToolBuildsUpdateClassCommand [ | command mutationRequest tool toolRequest | tool := MCPToolUpdateClassComment new. - toolRequest := tool requestFromToolCallArguments: - { (#className -> 'Object'). (#classComment -> 'updated') } - asDictionary. + toolRequest := tool requestFromToolCallArguments: { + (#className -> 'Object'). + (#classComment -> 'updated') } asDictionary. mutationRequest := tool parsedRequestFromToolRequest: toolRequest. command := tool commandForRequest: mutationRequest. self assert: mutationRequest class equals: MCPClassUpdateRequest. diff --git a/src/MCP/MCP.class.st b/src/MCP/MCP.class.st index 57d0de3..52c3959 100644 --- a/src/MCP/MCP.class.st +++ b/src/MCP/MCP.class.st @@ -29,26 +29,26 @@ MCP >> configurePort: aPortNumber debugMode: aBoolean [ wasRunning := self isRunning. wasRunning ifFalse: [ - self port: aPortNumber. - self debugMode: aBoolean. - ^ self ]. + self port: aPortNumber. + self debugMode: aBoolean. + ^ self ]. currentPort = aPortNumber ifTrue: [ - self debugMode: aBoolean. - ^ self ]. + self debugMode: aBoolean. + ^ self ]. self stop. [ - self port: aPortNumber. - self debugMode: aBoolean. - self start ] + self port: aPortNumber. + self debugMode: aBoolean. + self start ] on: Error do: [ :error | - self port: currentPort. - self debugMode: aBoolean. - self start. - error pass ] + self port: currentPort. + self debugMode: aBoolean. + self start. + error pass ] ] { #category : 'accessing' } diff --git a/src/MCP/MCPAddSlotCommand.class.st b/src/MCP/MCPAddSlotCommand.class.st index 41bedfa..dffa2df 100644 --- a/src/MCP/MCPAddSlotCommand.class.st +++ b/src/MCP/MCPAddSlotCommand.class.st @@ -3,12 +3,7 @@ Adds a slot to a class or metaclass through the refactoring engine. " Class { #name : 'MCPAddSlotCommand', - #superclass : 'Object', - #instVars : [ - 'className', - 'slotName', - 'classSide' - ], + #superclass : 'MCPClassSlotCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' @@ -24,36 +19,6 @@ MCPAddSlotCommand class >> className: aClassName slotName: aSlotName classSide: yourself ] -{ #category : 'accessing' } -MCPAddSlotCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPAddSlotCommand >> className: aClassName [ - - className := aClassName -] - -{ #category : 'accessing' } -MCPAddSlotCommand >> classSide [ - - ^ classSide -] - -{ #category : 'accessing' } -MCPAddSlotCommand >> classSide: aBoolean [ - - classSide := aBoolean -] - -{ #category : 'private' } -MCPAddSlotCommand >> currentClass [ - - ^ MCPImageLookup classNamed: self className -] - { #category : 'executing' } MCPAddSlotCommand >> execute [ @@ -68,14 +33,6 @@ MCPAddSlotCommand >> execute [ classSide: self classSide ] -{ #category : 'private' } -MCPAddSlotCommand >> refactoringBehaviorForClass: aClass [ - - ^ self classSide - ifTrue: [ aClass classSide ] - ifFalse: [ aClass ] -] - { #category : 'private' } MCPAddSlotCommand >> refactoringForBehavior: aBehavior [ @@ -83,15 +40,3 @@ MCPAddSlotCommand >> refactoringForBehavior: aBehavior [ variable: self slotName class: aBehavior ] - -{ #category : 'accessing' } -MCPAddSlotCommand >> slotName [ - - ^ slotName -] - -{ #category : 'accessing' } -MCPAddSlotCommand >> slotName: aSlotName [ - - slotName := aSlotName -] diff --git a/src/MCP/MCPAdoptRepositoryHeadCommand.class.st b/src/MCP/MCPAdoptRepositoryHeadCommand.class.st index 6e816fe..1934db2 100644 --- a/src/MCP/MCPAdoptRepositoryHeadCommand.class.st +++ b/src/MCP/MCPAdoptRepositoryHeadCommand.class.st @@ -3,22 +3,12 @@ Command wrapper for repository_head_adopt. It asks the Iceberg working copy to a " Class { #name : 'MCPAdoptRepositoryHeadCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPAdoptRepositoryHeadCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private' } MCPAdoptRepositoryHeadCommand >> commit: leftCommit equals: rightCommit [ @@ -37,10 +27,8 @@ MCPAdoptRepositoryHeadCommand >> commitIdFrom: aCommit [ MCPAdoptRepositoryHeadCommand >> execute [ | beforeInfo didAdopt headCommit previousReferenceCommit repository result | - ^ self tool - executeMutationAction: 'adoptHead' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'adoptHead' work: [ repository := self request repository. self validateExpectedBranchFor: repository. @@ -63,33 +51,19 @@ MCPAdoptRepositoryHeadCommand >> execute [ successResultText: 'Adopted repository HEAD for ' , result repositoryInfo name , '.' - data: (self tool dataForRepositoryAdoptHeadResult: result) + data: (self tool dataForRepositoryResult: result) warnings: warningMessages ] failureSummary: [ :error | - 'Failed to adopt repository HEAD: ' + 'Failed adopt repository HEAD: ' , (error messageText ifNil: [ error asString ]) ] ] -{ #category : 'initialization' } -MCPAdoptRepositoryHeadCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - { #category : 'private' } MCPAdoptRepositoryHeadCommand >> referenceCommitFor: aRepository [ ^ aRepository workingCopy referenceCommit ] -{ #category : 'accessing' } -MCPAdoptRepositoryHeadCommand >> request [ - - ^ request -] - { #category : 'private - validation' } MCPAdoptRepositoryHeadCommand >> signalMissingHeadCommitFor: aRepository [ @@ -102,12 +76,6 @@ MCPAdoptRepositoryHeadCommand >> signalMissingHeadCommitFor: aRepository [ yourself) ] -{ #category : 'accessing' } -MCPAdoptRepositoryHeadCommand >> tool [ - - ^ tool -] - { #category : 'private - validation' } MCPAdoptRepositoryHeadCommand >> validateExpectedBranchFor: aRepository [ diff --git a/src/MCP/MCPAppliedChangeResult.class.st b/src/MCP/MCPAppliedChangeResult.class.st new file mode 100644 index 0000000..d362cb7 --- /dev/null +++ b/src/MCP/MCPAppliedChangeResult.class.st @@ -0,0 +1,61 @@ +" +Abstract result for a planned update that has been applied. + +Subclasses decide how much of the applied change to expose in #asDictionary. +" +Class { + #name : 'MCPAppliedChangeResult', + #superclass : 'MCPResult', + #instVars : [ + 'updatePlan', + 'changeResult' + ], + #category : 'MCP-Results', + #package : 'MCP', + #tag : 'Results' +} + +{ #category : 'testing' } +MCPAppliedChangeResult class >> isAbstract [ + + ^ self == MCPAppliedChangeResult +] + +{ #category : 'instance creation' } +MCPAppliedChangeResult class >> updatePlan: anUpdatePlan changeResult: aChangeResult [ + + ^ self new + updatePlan: anUpdatePlan; + changeResult: aChangeResult; + yourself +] + +{ #category : 'accessing' } +MCPAppliedChangeResult >> changeResult [ + + ^ changeResult +] + +{ #category : 'accessing' } +MCPAppliedChangeResult >> changeResult: aResult [ + + changeResult := aResult +] + +{ #category : 'accessing' } +MCPAppliedChangeResult >> updateAction [ + + ^ self updatePlan updateAction +] + +{ #category : 'accessing' } +MCPAppliedChangeResult >> updatePlan [ + + ^ updatePlan +] + +{ #category : 'accessing' } +MCPAppliedChangeResult >> updatePlan: anUpdatePlan [ + + updatePlan := anUpdatePlan +] diff --git a/src/MCP/MCPAttachRepositoryCommand.class.st b/src/MCP/MCPAttachRepositoryCommand.class.st index 14b9649..4dc683a 100644 --- a/src/MCP/MCPAttachRepositoryCommand.class.st +++ b/src/MCP/MCPAttachRepositoryCommand.class.st @@ -31,10 +31,8 @@ MCPAttachRepositoryCommand >> createRepository [ MCPAttachRepositoryCommand >> execute [ | repository result | - ^ self tool - executeMutationAction: 'attach' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'attach' work: [ repository := self createRepository. self addRequestedPackagesTo: repository. @@ -43,7 +41,7 @@ MCPAttachRepositoryCommand >> execute [ self tool successResultText: 'Attached repository ' , self request name , '.' - data: (self tool dataForRepositoryAttachResult: result) + data: (self tool dataForRepositoryResult: result) warnings: warningMessages ] failureSummary: [ :error | 'Failed to attach repository ' , self request name , ': ' diff --git a/src/MCP/MCPCallToolCommand.class.st b/src/MCP/MCPCallToolCommand.class.st index 7a0a251..cbb0417 100644 --- a/src/MCP/MCPCallToolCommand.class.st +++ b/src/MCP/MCPCallToolCommand.class.st @@ -5,51 +5,14 @@ This command is the dynamic dispatch path behind tool_call: it validates the req " Class { #name : 'MCPCallToolCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPCallToolCommand class >> tool: aTool request: aRequest [ - - ^ self new - tool: aTool; - request: aRequest; - yourself -] - { #category : 'executing' } MCPCallToolCommand >> execute [ Error signal: 'tool_call requires MCP server call context.' ] - -{ #category : 'accessing' } -MCPCallToolCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPCallToolCommand >> request: anObject [ - - request := anObject -] - -{ #category : 'accessing' } -MCPCallToolCommand >> tool [ - - ^ tool -] - -{ #category : 'accessing' } -MCPCallToolCommand >> tool: anObject [ - - tool := anObject -] diff --git a/src/MCP/MCPChangeClassCommentCommand.class.st b/src/MCP/MCPChangeClassCommentCommand.class.st index c938200..b83e3fe 100644 --- a/src/MCP/MCPChangeClassCommentCommand.class.st +++ b/src/MCP/MCPChangeClassCommentCommand.class.st @@ -5,9 +5,8 @@ It records the previous comment and returns an MCPChangeClassCommentResult so cl " Class { #name : 'MCPChangeClassCommentCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'classComment' ], #category : 'MCP-Commands', @@ -36,18 +35,6 @@ MCPChangeClassCommentCommand >> classComment: aString [ classComment := aString ifNil: [ '' ] ifNotNil: [ aString asString ] ] -{ #category : 'accessing' } -MCPChangeClassCommentCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPChangeClassCommentCommand >> className: aString [ - - className := aString -] - { #category : 'executing' } MCPChangeClassCommentCommand >> execute [ @@ -55,10 +42,10 @@ MCPChangeClassCommentCommand >> execute [ targetClass := self targetClass. oldClassComment := targetClass comment. oldClassComment = self classComment ifTrue: [ - ^ MCPChangeClassCommentResult - classInfo: (MCPClassInfo fromClass: targetClass) - oldClassComment: oldClassComment - newClassComment: oldClassComment ]. + ^ MCPChangeClassCommentResult + classInfo: (MCPClassInfo fromClass: targetClass) + oldClassComment: oldClassComment + newClassComment: oldClassComment ]. targetClass comment: self classComment. updatedClass := Smalltalk globals at: self className asSymbol. ^ MCPChangeClassCommentResult diff --git a/src/MCP/MCPChangeClassCommentResult.class.st b/src/MCP/MCPChangeClassCommentResult.class.st index ea034f5..cccd222 100644 --- a/src/MCP/MCPChangeClassCommentResult.class.st +++ b/src/MCP/MCPChangeClassCommentResult.class.st @@ -5,7 +5,7 @@ It carries the updated class info and both the old and new comments so the tool " Class { #name : 'MCPChangeClassCommentResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldClassComment', @@ -30,7 +30,7 @@ MCPChangeClassCommentResult class >> classInfo: aClassInfo oldClassComment: anOl MCPChangeClassCommentResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldClassComment put: self oldClassComment. data at: #newClassComment put: self newClassComment. ^ data diff --git a/src/MCP/MCPChangeHistoryCommand.class.st b/src/MCP/MCPChangeHistoryCommand.class.st index b00d2e0..9d302b5 100644 --- a/src/MCP/MCPChangeHistoryCommand.class.st +++ b/src/MCP/MCPChangeHistoryCommand.class.st @@ -5,11 +5,7 @@ It centralizes command construction, current Epicea log access, history-file loa " Class { #name : 'MCPChangeHistoryCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' @@ -21,14 +17,6 @@ MCPChangeHistoryCommand class >> isAbstract [ ^ self = MCPChangeHistoryCommand ] -{ #category : 'instance creation' } -MCPChangeHistoryCommand class >> tool: aTool request: aRequest [ - - ^ self new - initializeTool: aTool request: aRequest; - yourself -] - { #category : 'private - log' } MCPChangeHistoryCommand >> currentHistoryFileReference [ @@ -64,13 +52,6 @@ MCPChangeHistoryCommand >> historyDirectoryForCurrentFile: aFileReference [ do: [ :error | FileLocator localDirectory asFileReference ] ] -{ #category : 'initialization' } -MCPChangeHistoryCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest -] - { #category : 'private - entries' } MCPChangeHistoryCommand >> isCodeChangeEntry: anEntry [ @@ -150,12 +131,6 @@ MCPChangeHistoryCommand >> logAndFileNameFromFileReference: aFileReference [ aFileReference basename } ] -{ #category : 'accessing' } -MCPChangeHistoryCommand >> request [ - - ^ request -] - { #category : 'private - files' } MCPChangeHistoryCommand >> sameFileReference: firstFile as: secondFile [ @@ -163,9 +138,3 @@ MCPChangeHistoryCommand >> sameFileReference: firstFile as: secondFile [ secondFile ifNil: [ ^ false ]. ^ firstFile fullName = secondFile fullName ] - -{ #category : 'accessing' } -MCPChangeHistoryCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPChangeHistoryEntryInfo.class.st b/src/MCP/MCPChangeHistoryEntryInfo.class.st index e9b16b3..31c050f 100644 --- a/src/MCP/MCPChangeHistoryEntryInfo.class.st +++ b/src/MCP/MCPChangeHistoryEntryInfo.class.st @@ -3,7 +3,7 @@ Structured metadata for one entry in image change history. " Class { #name : 'MCPChangeHistoryEntryInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'index', 'eventClassName', diff --git a/src/MCP/MCPChangeHistoryListEntriesResult.class.st b/src/MCP/MCPChangeHistoryListEntriesResult.class.st index ba196df..fd4c673 100644 --- a/src/MCP/MCPChangeHistoryListEntriesResult.class.st +++ b/src/MCP/MCPChangeHistoryListEntriesResult.class.st @@ -3,7 +3,7 @@ Result DTO for listing entries from a change history source. " Class { #name : 'MCPChangeHistoryListEntriesResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'historyFileName', 'entries', diff --git a/src/MCP/MCPChangeHistoryListLogsResult.class.st b/src/MCP/MCPChangeHistoryListLogsResult.class.st index fd98d7c..20fa4e7 100644 --- a/src/MCP/MCPChangeHistoryListLogsResult.class.st +++ b/src/MCP/MCPChangeHistoryListLogsResult.class.st @@ -3,7 +3,7 @@ Result DTO for listing change history files and the directory that was scanned. " Class { #name : 'MCPChangeHistoryListLogsResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'logs', 'directoryPath', diff --git a/src/MCP/MCPChangeHistoryLogInfo.class.st b/src/MCP/MCPChangeHistoryLogInfo.class.st index 67affb3..240b463 100644 --- a/src/MCP/MCPChangeHistoryLogInfo.class.st +++ b/src/MCP/MCPChangeHistoryLogInfo.class.st @@ -3,7 +3,7 @@ Structured metadata for one change history file. " Class { #name : 'MCPChangeHistoryLogInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'fileName', 'exists', diff --git a/src/MCP/MCPChangeHistorySelectionCommand.class.st b/src/MCP/MCPChangeHistorySelectionCommand.class.st index f0c0166..4384db2 100644 --- a/src/MCP/MCPChangeHistorySelectionCommand.class.st +++ b/src/MCP/MCPChangeHistorySelectionCommand.class.st @@ -13,9 +13,9 @@ Class { MCPChangeHistorySelectionCommand >> addIndexSelectionsTo: pairs fromLog: aLog [ request indexes do: [ :index | - pairs add: { - index. - (self entryAtIndex: index inLog: aLog) } ]. + pairs add: { + index. + (self entryAtIndex: index inLog: aLog) } ]. ^ pairs ] @@ -26,8 +26,8 @@ MCPChangeHistorySelectionCommand >> addLatestSelectionTo: pairs fromLog: aLog [ request latestCount ifNil: [ ^ pairs ]. allPairs := self entryPairsFromLog: aLog. request codeChangesOnly ifTrue: [ - allPairs := allPairs select: [ :pair | - self isCodeChangeEntry: pair second ] ]. + allPairs := allPairs select: [ :pair | + self isCodeChangeEntry: pair second ] ]. allPairs ifEmpty: [ ^ pairs ]. start := allPairs size - request latestCount + 1 max: 1. selected := allPairs copyFrom: start to: allPairs size. @@ -40,9 +40,9 @@ MCPChangeHistorySelectionCommand >> addRangeSelectionTo: pairs fromLog: aLog [ request hasRangeSelection ifFalse: [ ^ pairs ]. request startIndex to: request endIndex do: [ :index | - pairs add: { - index. - (self entryAtIndex: index inLog: aLog) } ]. + pairs add: { + index. + (self entryAtIndex: index inLog: aLog) } ]. ^ pairs ] @@ -75,14 +75,14 @@ MCPChangeHistorySelectionCommand >> applyOrRevertEntries [ MCPChangeHistorySelectionCommand >> entryAtIndex: anIndex inLog: aLog [ (anIndex between: 1 and: aLog entries size) ifFalse: [ - MCPCommandError - signalErrorCode: #ChangeHistoryEntryNotFound - message: - 'Change history entry index ' , anIndex asString - , ' does not exist.' - details: { - (#index -> anIndex). - (#entryCount -> aLog entries size) } asDictionary ]. + MCPCommandError + signalErrorCode: #ChangeHistoryEntryNotFound + message: + 'Change history entry index ' , anIndex asString + , ' does not exist.' + details: { + (#index -> anIndex). + (#entryCount -> aLog entries size) } asDictionary ]. ^ aLog entries at: anIndex ] @@ -97,10 +97,10 @@ MCPChangeHistorySelectionCommand >> entryInfosFromLog: aLog [ MCPChangeHistorySelectionCommand >> entryInfosFromPairs: pairs log: aLog [ ^ pairs collect: [ :pair | - MCPChangeHistoryEntryInfo - fromEntry: pair second - index: pair first - log: aLog ] + MCPChangeHistoryEntryInfo + fromEntry: pair second + index: pair first + log: aLog ] ] { #category : 'private - entries' } @@ -109,9 +109,9 @@ MCPChangeHistorySelectionCommand >> entryPairsFromLog: aLog [ | pairs | pairs := OrderedCollection new. aLog entries doWithIndex: [ :entry :index | - pairs add: { - index. - entry } ]. + pairs add: { + index. + entry } ]. ^ pairs ] diff --git a/src/MCP/MCPChangeHistorySelectionRequest.class.st b/src/MCP/MCPChangeHistorySelectionRequest.class.st index e304a4d..db990b5 100644 --- a/src/MCP/MCPChangeHistorySelectionRequest.class.st +++ b/src/MCP/MCPChangeHistorySelectionRequest.class.st @@ -154,12 +154,12 @@ MCPChangeHistorySelectionRequest >> optionalPositiveIntegerArgumentNamed: argume (aRequest hasArgumentNamed: argumentName) ifFalse: [ ^ nil ]. value := aRequest argumentNamed: argumentName ifAbsent: [ ^ nil ]. (value isInteger and: [ value > 0 ]) ifFalse: [ - self - signalInvalidSelection: - argumentName , ' must be a positive integer.' - details: { - (#argumentName -> argumentName). - (#actualValue -> value) } asDictionary ]. + self + signalInvalidSelection: + argumentName , ' must be a positive integer.' + details: { + (#argumentName -> argumentName). + (#actualValue -> value) } asDictionary ]. ^ value ] @@ -169,14 +169,14 @@ MCPChangeHistorySelectionRequest >> positiveIntegerCollectionArgumentNamed: argu | values | values := aRequest arrayArgumentNamed: argumentName. ^ (values collect: [ :each | - (each isInteger and: [ each > 0 ]) ifFalse: [ - self - signalInvalidSelection: - argumentName , ' must contain only positive integers.' - details: { - (#argumentName -> argumentName). - (#actualValue -> each) } asDictionary ]. - each ]) asArray + (each isInteger and: [ each > 0 ]) ifFalse: [ + self + signalInvalidSelection: + argumentName , ' must contain only positive integers.' + details: { + (#argumentName -> argumentName). + (#actualValue -> each) } asDictionary ]. + each ]) asArray ] { #category : 'converting' } diff --git a/src/MCP/MCPChangeHistorySelectionResult.class.st b/src/MCP/MCPChangeHistorySelectionResult.class.st index 75b0ab1..e780582 100644 --- a/src/MCP/MCPChangeHistorySelectionResult.class.st +++ b/src/MCP/MCPChangeHistorySelectionResult.class.st @@ -3,7 +3,7 @@ Structured result for previewing or applying selected image change history entri " Class { #name : 'MCPChangeHistorySelectionResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'historyFileName', 'selectionCriteria', diff --git a/src/MCP/MCPCheckoutRepositoryBranchCommand.class.st b/src/MCP/MCPCheckoutRepositoryBranchCommand.class.st index dd60fa6..e47e88c 100644 --- a/src/MCP/MCPCheckoutRepositoryBranchCommand.class.st +++ b/src/MCP/MCPCheckoutRepositoryBranchCommand.class.st @@ -3,30 +3,18 @@ Command wrapper for repository_branch_checkout. It asks Iceberg to check out the " Class { #name : 'MCPCheckoutRepositoryBranchCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPCheckoutRepositoryBranchCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPCheckoutRepositoryBranchCommand >> execute [ | beforeInfo branch repository result | - ^ self tool - executeMutationAction: 'checkoutBranch' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'checkoutBranch' work: [ repository := self request repository. beforeInfo := MCPRepositoryInfo fromRepository: repository. @@ -39,29 +27,10 @@ MCPCheckoutRepositoryBranchCommand >> execute [ self tool successResultText: 'Checked out repository ' , result repositoryInfo name - , ' to branch ' , self request branchName , '.' - data: (self tool dataForRepositoryCheckoutBranchResult: result) + , ' branch ' , self request branchName , '.' + data: (self tool dataForRepositoryResult: result) warnings: warningMessages ] failureSummary: [ :error | 'Failed to check out repository branch: ' , (error messageText ifNil: [ error asString ]) ] ] - -{ #category : 'initialization' } -MCPCheckoutRepositoryBranchCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest -] - -{ #category : 'accessing' } -MCPCheckoutRepositoryBranchCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPCheckoutRepositoryBranchCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPClassAppliedChangeResult.class.st b/src/MCP/MCPClassAppliedChangeResult.class.st index 56ba548..f65fa7a 100644 --- a/src/MCP/MCPClassAppliedChangeResult.class.st +++ b/src/MCP/MCPClassAppliedChangeResult.class.st @@ -3,57 +3,14 @@ Compact public result for a class update selected and executed by a class mutati " Class { #name : 'MCPClassAppliedChangeResult', - #superclass : 'Object', - #instVars : [ - 'updatePlan', - 'changeResult' - ], + #superclass : 'MCPAppliedChangeResult', #category : 'MCP-Results', #package : 'MCP', #tag : 'Results' } -{ #category : 'instance creation' } -MCPClassAppliedChangeResult class >> updatePlan: anUpdatePlan changeResult: aChangeResult [ - - ^ self new - updatePlan: anUpdatePlan; - changeResult: aChangeResult; - yourself -] - { #category : 'converting' } MCPClassAppliedChangeResult >> asDictionary [ ^ Dictionary new ] - -{ #category : 'accessing' } -MCPClassAppliedChangeResult >> changeResult [ - - ^ changeResult -] - -{ #category : 'accessing' } -MCPClassAppliedChangeResult >> changeResult: aResult [ - - changeResult := aResult -] - -{ #category : 'accessing' } -MCPClassAppliedChangeResult >> updateAction [ - - ^ self updatePlan updateAction -] - -{ #category : 'accessing' } -MCPClassAppliedChangeResult >> updatePlan [ - - ^ updatePlan -] - -{ #category : 'accessing' } -MCPClassAppliedChangeResult >> updatePlan: anUpdatePlan [ - - updatePlan := anUpdatePlan -] diff --git a/src/MCP/MCPClassCommand.class.st b/src/MCP/MCPClassCommand.class.st new file mode 100644 index 0000000..475d7cd --- /dev/null +++ b/src/MCP/MCPClassCommand.class.st @@ -0,0 +1,87 @@ +" +Abstract command for operations targeting one existing or newly defined class. + +Subclasses provide #className and implement their command-specific execution. +" +Class { + #name : 'MCPClassCommand', + #superclass : 'MCPCommand', + #instVars : [ + 'className' + ], + #category : 'MCP-Commands', + #package : 'MCP', + #tag : 'Commands' +} + +{ #category : 'testing' } +MCPClassCommand class >> isAbstract [ + + ^ self == MCPClassCommand +] + +{ #category : 'accessing' } +MCPClassCommand >> className [ + + ^ className +] + +{ #category : 'accessing' } +MCPClassCommand >> className: aClassName [ + + className := aClassName +] + +{ #category : 'private' } +MCPClassCommand >> currentClass [ + + ^ MCPImageLookup classNamed: self className +] + +{ #category : 'private - resolving' } +MCPClassCommand >> resolvedLayoutClassNamed: layoutName [ + + | behavior | + layoutName ifNil: [ ^ nil ]. + behavior := Smalltalk globals at: layoutName asSymbol ifAbsent: [ + MCPCommandError + signalErrorCode: #LayoutClassNotFound + message: + 'Layout class ' , layoutName , ' does not exist.' + details: { + (#className -> self className). + (#layout -> layoutName) } asDictionary ]. + (AbstractLayout withAllSubclasses includes: behavior) ifFalse: [ + MCPCommandError + signalErrorCode: #InvalidLayoutClass + message: layoutName , ' not layout class.' + details: { + (#className -> self className). + (#layout -> layoutName) } asDictionary ]. + ^ behavior +] + +{ #category : 'private - resolving' } +MCPClassCommand >> resolvedSharedPoolNamed: aSharedPoolName [ + + | behavior sharedPoolName | + sharedPoolName := aSharedPoolName. + behavior := Smalltalk globals + at: sharedPoolName asSymbol + ifAbsent: [ + MCPCommandError + signalErrorCode: #SharedPoolNotFound + message: + 'Shared pool ' , sharedPoolName , ' does not exist.' + details: { + (#className -> self className). + (#sharedPoolName -> sharedPoolName) } asDictionary ]. + (SharedPool withAllSubclasses includes: behavior) ifFalse: [ + MCPCommandError + signalErrorCode: #InvalidSharedPool + message: sharedPoolName , ' not shared pool.' + details: { + (#className -> self className). + (#sharedPoolName -> sharedPoolName) } asDictionary ]. + ^ behavior +] diff --git a/src/MCP/MCPClassDescriptionInfo.class.st b/src/MCP/MCPClassDescriptionInfo.class.st index 1c3c301..b3d82b8 100644 --- a/src/MCP/MCPClassDescriptionInfo.class.st +++ b/src/MCP/MCPClassDescriptionInfo.class.st @@ -5,7 +5,7 @@ It includes package, tag, layout, slots, traits, pools, shared variables, method " Class { #name : 'MCPClassDescriptionInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'className', 'superclassName', diff --git a/src/MCP/MCPClassInfo.class.st b/src/MCP/MCPClassInfo.class.st index 8fc1434..13c8ad1 100644 --- a/src/MCP/MCPClassInfo.class.st +++ b/src/MCP/MCPClassInfo.class.st @@ -5,7 +5,7 @@ It describes class identity, package placement, slots, traits, shared variables, " Class { #name : 'MCPClassInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'className', 'superclassName', diff --git a/src/MCP/MCPClassResult.class.st b/src/MCP/MCPClassResult.class.st new file mode 100644 index 0000000..dba79f5 --- /dev/null +++ b/src/MCP/MCPClassResult.class.st @@ -0,0 +1,36 @@ +" +Abstract result for operations that return a class snapshot. + +Subclasses provide #classInfo and add operation-specific fields when needed. +" +Class { + #name : 'MCPClassResult', + #superclass : 'MCPResult', + #category : 'MCP-Results', + #package : 'MCP', + #tag : 'Results' +} + +{ #category : 'testing' } +MCPClassResult class >> isAbstract [ + + ^ self == MCPClassResult +] + +{ #category : 'converting' } +MCPClassResult >> asDictionary [ + + ^ self newClassInfoDictionary +] + +{ #category : 'accessing' } +MCPClassResult >> classInfo [ + + self subclassResponsibility +] + +{ #category : 'private' } +MCPClassResult >> newClassInfoDictionary [ + + ^ self classInfo asDictionary copy +] diff --git a/src/MCP/MCPClassScopeQuery.class.st b/src/MCP/MCPClassScopeQuery.class.st index 6333668..5e88ed2 100644 --- a/src/MCP/MCPClassScopeQuery.class.st +++ b/src/MCP/MCPClassScopeQuery.class.st @@ -5,16 +5,7 @@ It handles packageNames, classNames, hierarchyClassNames, subclassClassNames, an " Class { #name : 'MCPClassScopeQuery', - #superclass : 'Object', - #instVars : [ - 'packageNames', - 'classNames', - 'hierarchyClassNames', - 'subclassClassNames', - 'parentClassNames', - 'warnings', - 'requiresCompleteScope' - ], + #superclass : 'MCPScopeQuery', #category : 'MCP-Queries', #package : 'MCP', #tag : 'Queries' @@ -30,20 +21,6 @@ MCPClassScopeQuery >> allClasses [ ^ self sortedClassesByName: classes ] -{ #category : 'accessing' } -MCPClassScopeQuery >> classNames [ - - ^ classNames -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> classNames: someClassNames [ - - classNames := someClassNames - ifNil: [ #( ) ] - ifNotNil: [ someClassNames asArray ] -] - { #category : 'private - scope' } MCPClassScopeQuery >> classScopeSets [ @@ -52,8 +29,8 @@ MCPClassScopeQuery >> classScopeSets [ self packageNames ifNotEmpty: [ sets add: self classesForPackageNames ]. self classNames ifNotEmpty: [ - sets add: - (self resolvedClassesNamed: self classNames inScope: 'classNames') ]. + sets add: + (self resolvedClassesNamed: self classNames inScope: 'classNames') ]. self hierarchyClassNames ifNotEmpty: [ sets add: (self hierarchyClassesNamed: self hierarchyClassNames) ]. self subclassClassNames ifNotEmpty: [ @@ -77,27 +54,13 @@ MCPClassScopeQuery >> classesForPackageNames [ | classes | classes := IdentitySet new. packageNames do: [ :eachName | - (self resolvedPackageNamed: eachName inScope: 'packageNames') - ifNotNil: [ :package | - package classes do: [ :eachClass | - classes add: eachClass instanceSide ] ] ]. + (self resolvedPackageNamed: eachName inScope: 'packageNames') + ifNotNil: [ :package | + package classes do: [ :eachClass | + classes add: eachClass instanceSide ] ] ]. ^ self sortedClassesByName: classes ] -{ #category : 'accessing' } -MCPClassScopeQuery >> hierarchyClassNames [ - - ^ hierarchyClassNames ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> hierarchyClassNames: someClassNames [ - - hierarchyClassNames := someClassNames - ifNil: [ #( ) ] - ifNotNil: [ someClassNames asArray ] -] - { #category : 'private - scope' } MCPClassScopeQuery >> hierarchyClassesNamed: someClassNames [ @@ -106,8 +69,8 @@ MCPClassScopeQuery >> hierarchyClassesNamed: someClassNames [ (self resolvedClassesNamed: someClassNames inScope: 'hierarchyClassNames') do: [ :eachClass | - eachClass withAllSuperAndSubclasses do: [ :relatedClass | - classes add: relatedClass instanceSide ] ]. + eachClass withAllSuperAndSubclasses do: [ :relatedClass | + classes add: relatedClass instanceSide ] ]. ^ self sortedClassesByName: classes ] @@ -124,34 +87,6 @@ MCPClassScopeQuery >> initialize [ requiresCompleteScope := false ] -{ #category : 'accessing' } -MCPClassScopeQuery >> packageNames [ - - ^ packageNames -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> packageNames: somePackageNames [ - - packageNames := somePackageNames - ifNil: [ #( ) ] - ifNotNil: [ somePackageNames asArray ] -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> parentClassNames [ - - ^ parentClassNames ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> parentClassNames: someClassNames [ - - parentClassNames := someClassNames - ifNil: [ #( ) ] - ifNotNil: [ someClassNames asArray ] -] - { #category : 'private - scope' } MCPClassScopeQuery >> parentClassesNamed: someClassNames [ @@ -160,72 +95,11 @@ MCPClassScopeQuery >> parentClassesNamed: someClassNames [ (self resolvedClassesNamed: someClassNames inScope: 'parentClassNames') do: [ :eachClass | - eachClass allSuperclasses do: [ :relatedClass | - classes add: relatedClass instanceSide ] ]. + eachClass allSuperclasses do: [ :relatedClass | + classes add: relatedClass instanceSide ] ]. ^ self sortedClassesByName: classes ] -{ #category : 'private - resolution' } -MCPClassScopeQuery >> recordMissingClassNamed: className inScope: scopeName [ - - | suggestions | - suggestions := MCPScopeNameSuggester classSuggestionsFor: className. - self requiresCompleteScope ifTrue: [ - ^ MCPCommandError - signalMissingClassNamed: className - scopeName: scopeName ]. - warnings ifNil: [ self resetWarnings ]. - warnings add: (MCPScopeNameSuggester - missingNameWarningForKind: 'Class' - name: className - scope: scopeName - suggestions: suggestions). - ^ nil -] - -{ #category : 'private - resolution' } -MCPClassScopeQuery >> recordMissingPackageNamed: packageName inScope: scopeName [ - - | suggestions | - suggestions := MCPScopeNameSuggester packageSuggestionsFor: - packageName. - self requiresCompleteScope ifTrue: [ - ^ MCPCommandError - signalMissingPackageNamed: packageName - scopeName: scopeName ]. - warnings ifNil: [ self resetWarnings ]. - warnings add: (MCPScopeNameSuggester - missingNameWarningForKind: 'Package' - name: packageName - scope: scopeName - suggestions: suggestions). - ^ nil -] - -{ #category : 'configuring' } -MCPClassScopeQuery >> requireCompleteScope [ - - self requiresCompleteScope: true -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> requiresCompleteScope [ - - ^ requiresCompleteScope ifNil: [ false ] -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> requiresCompleteScope: aBoolean [ - - requiresCompleteScope := aBoolean = true -] - -{ #category : 'private - resolution' } -MCPClassScopeQuery >> resetWarnings [ - - warnings := OrderedCollection new -] - { #category : 'private - resolution' } MCPClassScopeQuery >> resolvedClassNamed: className [ @@ -253,8 +127,8 @@ MCPClassScopeQuery >> resolvedClassesNamed: someClassNames inScope: scopeName [ | classes | classes := IdentitySet new. someClassNames do: [ :eachName | - (self resolvedClassNamed: eachName inScope: scopeName) ifNotNil: [ - :resolvedClass | classes add: resolvedClass instanceSide ] ]. + (self resolvedClassNamed: eachName inScope: scopeName) ifNotNil: [ + :resolvedClass | classes add: resolvedClass instanceSide ] ]. ^ self sortedClassesByName: classes ] @@ -279,20 +153,6 @@ MCPClassScopeQuery >> sortedClassesByName: someClasses [ ^ someClasses asArray sort: [ :left :right | left name <= right name ] ] -{ #category : 'accessing' } -MCPClassScopeQuery >> subclassClassNames [ - - ^ subclassClassNames ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> subclassClassNames: someClassNames [ - - subclassClassNames := someClassNames - ifNil: [ #( ) ] - ifNotNil: [ someClassNames asArray ] -] - { #category : 'private - scope' } MCPClassScopeQuery >> subclassClassesNamed: someClassNames [ @@ -301,8 +161,8 @@ MCPClassScopeQuery >> subclassClassesNamed: someClassNames [ (self resolvedClassesNamed: someClassNames inScope: 'subclassClassNames') do: [ :eachClass | - eachClass allSubclasses do: [ :relatedClass | - classes add: relatedClass instanceSide ] ]. + eachClass allSubclasses do: [ :relatedClass | + classes add: relatedClass instanceSide ] ]. ^ self sortedClassesByName: classes ] @@ -314,19 +174,3 @@ MCPClassScopeQuery >> unionClasses [ self classScopeSets do: [ :eachSet | classes addAll: eachSet ]. ^ self sortedClassesByName: classes ] - -{ #category : 'private - source' } -MCPClassScopeQuery >> usesImplicitImageScope [ - - ^ self packageNames isEmpty and: [ - self classNames isEmpty and: [ - self hierarchyClassNames isEmpty and: [ - self subclassClassNames isEmpty and: [ - self parentClassNames isEmpty ] ] ] ] -] - -{ #category : 'accessing' } -MCPClassScopeQuery >> warnings [ - - ^ warnings ifNil: [ #( ) ] ifNotNil: [ warnings asArray ] -] diff --git a/src/MCP/MCPClassSlotCommand.class.st b/src/MCP/MCPClassSlotCommand.class.st new file mode 100644 index 0000000..3d98e27 --- /dev/null +++ b/src/MCP/MCPClassSlotCommand.class.st @@ -0,0 +1,60 @@ +" +Abstract command for class-slot operations. + +Subclasses provide #slotName, #classSide, and the operation-specific refactoring. +" +Class { + #name : 'MCPClassSlotCommand', + #superclass : 'MCPClassCommand', + #instVars : [ + 'slotName', + 'classSide' + ], + #category : 'MCP-Commands', + #package : 'MCP', + #tag : 'Commands' +} + +{ #category : 'testing' } +MCPClassSlotCommand class >> isAbstract [ + + ^ self == MCPClassSlotCommand +] + +{ #category : 'accessing' } +MCPClassSlotCommand >> classSide [ + + ^ classSide ifNil: [ false ] +] + +{ #category : 'accessing' } +MCPClassSlotCommand >> classSide: aBoolean [ + + classSide := aBoolean +] + +{ #category : 'private' } +MCPClassSlotCommand >> refactoringBehaviorForClass: aClass [ + + ^ self classSide + ifTrue: [ aClass classSide ] + ifFalse: [ aClass ] +] + +{ #category : 'private' } +MCPClassSlotCommand >> refactoringForBehavior: aBehavior [ + + self subclassResponsibility +] + +{ #category : 'accessing' } +MCPClassSlotCommand >> slotName [ + + ^ slotName +] + +{ #category : 'accessing' } +MCPClassSlotCommand >> slotName: aSlotName [ + + slotName := aSlotName +] diff --git a/src/MCP/MCPClassUpdatePlanInfo.class.st b/src/MCP/MCPClassUpdatePlanInfo.class.st index 0017d6c..c028250 100644 --- a/src/MCP/MCPClassUpdatePlanInfo.class.st +++ b/src/MCP/MCPClassUpdatePlanInfo.class.st @@ -5,14 +5,14 @@ It records the selected update action and the request context used for validatio " Class { #name : 'MCPClassUpdatePlanInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'requestedContext', 'updateAction' ], - #category : 'MCP-Results', + #category : 'MCP-DTOs', #package : 'MCP', - #tag : 'Results' + #tag : 'DTOs' } { #category : 'instance creation' } diff --git a/src/MCP/MCPClassUpdateRequest.class.st b/src/MCP/MCPClassUpdateRequest.class.st index 4a8cf22..67b9bd3 100644 --- a/src/MCP/MCPClassUpdateRequest.class.st +++ b/src/MCP/MCPClassUpdateRequest.class.st @@ -281,9 +281,9 @@ MCPClassUpdateRequest >> requestedContext [ context := Dictionary new. context at: #className put: self className. self suppliedProperties do: [ :propertyName | - context - at: propertyName asSymbol - put: (self contextValueForPropertyNamed: propertyName) ]. + context + at: propertyName asSymbol + put: (self contextValueForPropertyNamed: propertyName) ]. ^ context ] @@ -341,11 +341,11 @@ MCPClassUpdateRequest >> slotOperation [ ('pullUp' -> 'pullUpSlot'). ('pushDown' -> 'pushDownSlot') } asDictionary. ^ operations at: self slotAction ifAbsent: [ - MCPCommandError - signalErrorCode: #InvalidSlotAction - message: - 'slotAction must be one of add, remove, rename, pullUp, pushDown.' - details: self slotRequestedContext ] + MCPCommandError + signalErrorCode: #InvalidSlotAction + message: + 'slotAction must be one of add, remove, rename, pullUp, pushDown.' + details: self slotRequestedContext ] ] { #category : 'converting' } @@ -418,28 +418,28 @@ MCPClassUpdateRequest >> validateSlotUpdate [ | operation | operation := self slotOperation. operation ifNil: [ - (self hasSlotName or: [ self hasNewSlotName ]) ifTrue: [ + (self hasSlotName or: [ self hasNewSlotName ]) ifTrue: [ + MCPCommandError + signalErrorCode: #SlotActionRequired + message: + 'slotAction is required when slotName or newSlotName is provided for update.' + details: self slotRequestedContext ]. + ^ self ]. + self hasSlotName ifFalse: [ MCPCommandError - signalErrorCode: #SlotActionRequired - message: - 'slotAction is required when slotName or newSlotName is provided for update.' + signalErrorCode: #SlotNameRequired + message: 'slotName is required for slot updates.' details: self slotRequestedContext ]. - ^ self ]. - self hasSlotName ifFalse: [ - MCPCommandError - signalErrorCode: #SlotNameRequired - message: 'slotName is required for slot updates.' - details: self slotRequestedContext ]. (operation = 'renameSlot' and: [ self hasNewSlotName not ]) ifTrue: [ - MCPCommandError - signalErrorCode: #NewSlotNameRequired - message: 'newSlotName is required when slotAction=rename.' - details: self slotRequestedContext ]. + MCPCommandError + signalErrorCode: #NewSlotNameRequired + message: 'newSlotName is required when slotAction=rename.' + details: self slotRequestedContext ]. (operation ~= 'renameSlot' and: [ self hasNewSlotName ]) ifTrue: [ - MCPCommandError - signalErrorCode: #UnexpectedNewSlotName - message: 'newSlotName is only accepted when slotAction=rename.' - details: self slotRequestedContext ]. + MCPCommandError + signalErrorCode: #UnexpectedNewSlotName + message: 'newSlotName is only accepted when slotAction=rename.' + details: self slotRequestedContext ]. ^ self ] diff --git a/src/MCP/MCPCommand.class.st b/src/MCP/MCPCommand.class.st new file mode 100644 index 0000000..654899c --- /dev/null +++ b/src/MCP/MCPCommand.class.st @@ -0,0 +1,24 @@ +" +Abstract base for command objects that perform one image-side action through #execute. + +Subclasses keep the command-specific state and implement #execute. +" +Class { + #name : 'MCPCommand', + #superclass : 'Object', + #category : 'MCP-Commands', + #package : 'MCP', + #tag : 'Commands' +} + +{ #category : 'testing' } +MCPCommand class >> isAbstract [ + + ^ self == MCPCommand +] + +{ #category : 'executing' } +MCPCommand >> execute [ + + self subclassResponsibility +] diff --git a/src/MCP/MCPCommandError.class.st b/src/MCP/MCPCommandError.class.st index 0929a12..ae069cc 100644 --- a/src/MCP/MCPCommandError.class.st +++ b/src/MCP/MCPCommandError.class.st @@ -46,23 +46,23 @@ MCPCommandError class >> detailsWith: associations suggestionsForPackageNamed: p MCPCommandError class >> messageForMissingKind: kind name: missingName scopeName: scopeName suggestions: suggestions [ ^ String streamContents: [ :stream | - stream - nextPutAll: kind; - space; - nextPutAll: missingName asString; - nextPutAll: ' does not exist'. - scopeName ifNotNil: [ stream - nextPutAll: ' in '; - nextPutAll: scopeName asString; - nextPutAll: ' scope' ]. - stream nextPut: $.. - suggestions ifNotEmpty: [ - stream nextPutAll: ' Did you mean: '. - suggestions - do: [ :each | stream nextPutAll: each ] - separatedBy: [ stream nextPutAll: ', ' ]. - stream nextPut: $. ] ] + nextPutAll: kind; + space; + nextPutAll: missingName asString; + nextPutAll: ' does not exist'. + scopeName ifNotNil: [ + stream + nextPutAll: ' in '; + nextPutAll: scopeName asString; + nextPutAll: ' scope' ]. + stream nextPut: $.. + suggestions ifNotEmpty: [ + stream nextPutAll: ' Did you mean: '. + suggestions + do: [ :each | stream nextPutAll: each ] + separatedBy: [ stream nextPutAll: ', ' ]. + stream nextPut: $. ] ] ] { #category : 'signaling' } diff --git a/src/MCP/MCPCommitRepositoryCommand.class.st b/src/MCP/MCPCommitRepositoryCommand.class.st index e394d84..787d507 100644 --- a/src/MCP/MCPCommitRepositoryCommand.class.st +++ b/src/MCP/MCPCommitRepositoryCommand.class.st @@ -13,10 +13,8 @@ Class { MCPCommitRepositoryCommand >> execute [ | changedPackageNames diff repository result | - ^ self tool - executeMutationAction: 'commit' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'commit' work: [ repository := self request repository. (self repositoryHasChangesToCommit: repository) ifFalse: [ @@ -39,7 +37,7 @@ MCPCommitRepositoryCommand >> execute [ self tool successResultText: 'Committed repository ' , result repositoryInfo name , '.' - data: (self tool dataForRepositoryCommitResult: result) + data: (self tool dataForRepositoryResult: result) warnings: warningMessages ] failureSummary: [ :error | 'Failed to commit repository: ' @@ -74,10 +72,10 @@ MCPCommitRepositoryCommand >> gitSignatureMissingFor: anError [ message := anError messageText ifNil: [ '' ]. message := message asLowercase. ^ message = 'config value ''user.name'' was not found' or: [ - message = 'config value ''user.email'' was not found' or: [ - message - = - 'failed to parse signature - signature cannot have an empty name or email' ] ] + message = 'config value ''user.email'' was not found' or: [ + message + = + 'failed to parse signature - signature cannot have an empty name or email' ] ] ] { #category : 'private - git identity' } @@ -91,8 +89,8 @@ MCPCommitRepositoryCommand >> removeGitConfigKey: key from: config [ { #category : 'private - git identity' } MCPCommitRepositoryCommand >> removeTemporaryGitConfigKey: key from: config [ - "Pharo 13 libgit2 can crash while deleting freshly-created repository config entries." + PharoCompatibility isPharo13OrLater ifTrue: [ ^ self ]. self removeGitConfigKey: key from: config ] @@ -108,13 +106,13 @@ MCPCommitRepositoryCommand >> repositoryHasChangesToCommit: aRepository [ MCPCommitRepositoryCommand >> repositoryHasDefaultGitSignature: aRepository [ ^ [ - aRepository repositoryHandle defaultSignature. - true ] + aRepository repositoryHandle defaultSignature. + true ] on: LGit_GIT_ENOTFOUND , LGit_GIT_ERROR do: [ :error | - (self gitSignatureMissingFor: error) - ifTrue: [ false ] - ifFalse: [ error pass ] ] + (self gitSignatureMissingFor: error) + ifTrue: [ false ] + ifFalse: [ error pass ] ] ] { #category : 'private - diff' } @@ -144,8 +142,8 @@ MCPCommitRepositoryCommand >> withNonInteractiveGitIdentityFor: aRepository duri shouldSetName ifTrue: [ config username: self fallbackGitUserName ]. shouldSetEmail ifTrue: [ config email: self fallbackGitUserEmail ]. ^ [ aBlock value ] ensure: [ - shouldSetName ifTrue: [ - self removeTemporaryGitConfigKey: 'user.name' from: config ]. - shouldSetEmail ifTrue: [ - self removeTemporaryGitConfigKey: 'user.email' from: config ] ] + shouldSetName ifTrue: [ + self removeTemporaryGitConfigKey: 'user.name' from: config ]. + shouldSetEmail ifTrue: [ + self removeTemporaryGitConfigKey: 'user.email' from: config ] ] ] diff --git a/src/MCP/MCPCompileMethodCommand.class.st b/src/MCP/MCPCompileMethodCommand.class.st index 2775d5b..cdc52c9 100644 --- a/src/MCP/MCPCompileMethodCommand.class.st +++ b/src/MCP/MCPCompileMethodCommand.class.st @@ -5,22 +5,12 @@ It reports whether compilation created a new method or replaced an existing meth " Class { #name : 'MCPCompileMethodCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPCompileMethodCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private' } MCPCompileMethodCommand >> changeSummaryVerbFor: changeKindString [ @@ -75,28 +65,8 @@ MCPCompileMethodCommand >> execute [ error: error ] ] -{ #category : 'initialization' } -MCPCompileMethodCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPCompileMethodCommand >> request [ - - ^ request -] - { #category : 'private' } MCPCompileMethodCommand >> selectorForMethodSource: methodSourceString [ ^ (RBParser parseMethod: methodSourceString) selector ] - -{ #category : 'accessing' } -MCPCompileMethodCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPCompiledMethodInfo.class.st b/src/MCP/MCPCompiledMethodInfo.class.st index bc726c4..2f25567 100644 --- a/src/MCP/MCPCompiledMethodInfo.class.st +++ b/src/MCP/MCPCompiledMethodInfo.class.st @@ -5,7 +5,7 @@ It records selector, declaring class, class-side flag, protocol, package, extens " Class { #name : 'MCPCompiledMethodInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'className', 'selector', @@ -26,6 +26,12 @@ MCPCompiledMethodInfo class >> fromMethod: aCompiledMethod [ ^ self new initializeFromMethod: aCompiledMethod ] +{ #category : 'converting' } +MCPCompiledMethodInfo >> asDictionary [ + + ^ self asDictionaryIncludingSource: false +] + { #category : 'converting' } MCPCompiledMethodInfo >> asDictionaryIncludingSource: includeSource [ diff --git a/src/MCP/MCPCompiledMethodScopeQuery.class.st b/src/MCP/MCPCompiledMethodScopeQuery.class.st index 8a3885b..72502af 100644 --- a/src/MCP/MCPCompiledMethodScopeQuery.class.st +++ b/src/MCP/MCPCompiledMethodScopeQuery.class.st @@ -5,16 +5,9 @@ It handles packageNames, classNames, hierarchyClassNames, subclassClassNames, pa " Class { #name : 'MCPCompiledMethodScopeQuery', - #superclass : 'Object', + #superclass : 'MCPScopeQuery', #instVars : [ - 'packageNames', - 'classNames', - 'side', - 'hierarchyClassNames', - 'subclassClassNames', - 'parentClassNames', - 'warnings', - 'requiresCompleteScope' + 'side' ], #category : 'MCP-Queries', #package : 'MCP', @@ -36,8 +29,8 @@ MCPCompiledMethodScopeQuery >> allBehaviors [ | behaviors | behaviors := IdentitySet new. Smalltalk globals allBehaviorsDo: [ :eachBehavior | - (self matchesSideForBehavior: eachBehavior) ifTrue: [ - behaviors add: eachBehavior ] ]. + (self matchesSideForBehavior: eachBehavior) ifTrue: [ + behaviors add: eachBehavior ] ]. ^ behaviors asArray ] @@ -53,11 +46,11 @@ MCPCompiledMethodScopeQuery >> allMethodsDo: aBlock [ | seenMethods | seenMethods := IdentitySet new. Smalltalk globals allBehaviorsDo: [ :eachBehavior | - (self matchesSideForBehavior: eachBehavior) ifTrue: [ - eachBehavior methods do: [ :eachMethod | - (seenMethods includes: eachMethod) ifFalse: [ - seenMethods add: eachMethod. - aBlock value: eachMethod ] ] ] ] + (self matchesSideForBehavior: eachBehavior) ifTrue: [ + eachBehavior methods do: [ :eachMethod | + (seenMethods includes: eachMethod) ifFalse: [ + seenMethods add: eachMethod. + aBlock value: eachMethod ] ] ] ] ] { #category : 'converting' } @@ -104,8 +97,9 @@ MCPCompiledMethodScopeQuery >> behaviorsForClassNames [ | behaviors | behaviors := IdentitySet new. self classNames do: [ :eachName | - (self classNamed: eachName inScope: 'classNames') ifNotNil: [ :class | - self addBehaviorsForBaseClass: class instanceSide to: behaviors ] ]. + (self classNamed: eachName inScope: 'classNames') ifNotNil: [ + :class | + self addBehaviorsForBaseClass: class instanceSide to: behaviors ] ]. ^ behaviors asArray ] @@ -115,13 +109,13 @@ MCPCompiledMethodScopeQuery >> behaviorsForPackageNames [ | behaviors | behaviors := IdentitySet new. self packageNames do: [ :eachName | - (self packageNamed: eachName inScope: 'packageNames') ifNotNil: [ - :package | - package definedClasses do: [ :aClass | - self addBehaviorsForBaseClass: aClass to: behaviors ]. - package extensionMethods do: [ :eachMethod | - (self matchesSideForMethod: eachMethod) ifTrue: [ - behaviors add: eachMethod methodClass ] ] ] ]. + (self packageNamed: eachName inScope: 'packageNames') ifNotNil: [ + :package | + package definedClasses do: [ :aClass | + self addBehaviorsForBaseClass: aClass to: behaviors ]. + package extensionMethods do: [ :eachMethod | + (self matchesSideForMethod: eachMethod) ifTrue: [ + behaviors add: eachMethod methodClass ] ] ] ]. ^ behaviors asArray ] @@ -140,50 +134,22 @@ MCPCompiledMethodScopeQuery >> classNamed: aClassName inScope: scopeName [ self recordMissingClassNamed: aClassName inScope: scopeName ] ] -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> classNames [ - - ^ classNames ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> classNames: someNames [ - - classNames := someNames - ifNil: [ #( ) ] - ifNotNil: [ someNames asArray ] -] - { #category : 'private - source' } MCPCompiledMethodScopeQuery >> hierarchyBehaviorsForClassNames [ | behaviors hierarchyClasses | hierarchyClasses := IdentitySet new. self hierarchyClassNames do: [ :eachName | - (self classNamed: eachName inScope: 'hierarchyClassNames') - ifNotNil: [ :class | - class instanceSide withAllSuperAndSubclasses do: [ :relatedClass | - hierarchyClasses add: relatedClass instanceSide ] ] ]. + (self classNamed: eachName inScope: 'hierarchyClassNames') + ifNotNil: [ :class | + class instanceSide withAllSuperAndSubclasses do: [ :relatedClass | + hierarchyClasses add: relatedClass instanceSide ] ] ]. behaviors := IdentitySet new. hierarchyClasses do: [ :eachClass | self addBehaviorsForBaseClass: eachClass to: behaviors ]. ^ behaviors asArray ] -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> hierarchyClassNames [ - - ^ hierarchyClassNames ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> hierarchyClassNames: someNames [ - - hierarchyClassNames := someNames - ifNil: [ #( ) ] - ifNotNil: [ someNames asArray ] -] - { #category : 'private - scope' } MCPCompiledMethodScopeQuery >> includesClassSide [ @@ -235,14 +201,14 @@ MCPCompiledMethodScopeQuery >> methodScopeSets [ self classNames ifNotEmpty: [ sets add: (self methodsForBehaviors: self behaviorsForClassNames) ]. self hierarchyClassNames ifNotEmpty: [ - sets add: - (self methodsForBehaviors: self hierarchyBehaviorsForClassNames) ]. + sets add: + (self methodsForBehaviors: self hierarchyBehaviorsForClassNames) ]. self subclassClassNames ifNotEmpty: [ - sets add: - (self methodsForBehaviors: self subclassBehaviorsForClassNames) ]. + sets add: + (self methodsForBehaviors: self subclassBehaviorsForClassNames) ]. self parentClassNames ifNotEmpty: [ - sets add: - (self methodsForBehaviors: self parentBehaviorsForClassNames) ]. + sets add: + (self methodsForBehaviors: self parentBehaviorsForClassNames) ]. ^ sets asArray ] @@ -263,9 +229,9 @@ MCPCompiledMethodScopeQuery >> methodsDo: aBlock [ self usesImplicitImageScope ifTrue: [ ^ self allMethodsDo: aBlock ]. seenMethods := IdentitySet new. self methods do: [ :eachMethod | - (seenMethods includes: eachMethod) ifFalse: [ - seenMethods add: eachMethod. - aBlock value: eachMethod ] ] + (seenMethods includes: eachMethod) ifFalse: [ + seenMethods add: eachMethod. + aBlock value: eachMethod ] ] ] { #category : 'private - scope' } @@ -284,10 +250,10 @@ MCPCompiledMethodScopeQuery >> methodsForBehaviors: behaviors do: aBlock [ | seenMethods | seenMethods := IdentitySet new. behaviors do: [ :eachBehavior | - eachBehavior methods do: [ :eachMethod | - (seenMethods includes: eachMethod) ifFalse: [ - seenMethods add: eachMethod. - aBlock value: eachMethod ] ] ] + eachBehavior methods do: [ :eachMethod | + (seenMethods includes: eachMethod) ifFalse: [ + seenMethods add: eachMethod. + aBlock value: eachMethod ] ] ] ] { #category : 'private - scope' } @@ -351,111 +317,22 @@ MCPCompiledMethodScopeQuery >> packageNamed: aPackageName inScope: scopeName [ ^ PackageOrganizer default packageNamed: aPackageName ] -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> packageNames [ - - ^ packageNames ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> packageNames: someNames [ - - packageNames := someNames - ifNil: [ #( ) ] - ifNotNil: [ someNames asArray ] -] - { #category : 'private - scope' } MCPCompiledMethodScopeQuery >> parentBehaviorsForClassNames [ | behaviors relatedClasses | relatedClasses := IdentitySet new. self parentClassNames do: [ :eachName | - (self classNamed: eachName inScope: 'parentClassNames') ifNotNil: [ - :class | - class instanceSide allSuperclasses do: [ :relatedClass | - relatedClasses add: relatedClass instanceSide ] ] ]. + (self classNamed: eachName inScope: 'parentClassNames') ifNotNil: [ + :class | + class instanceSide allSuperclasses do: [ :relatedClass | + relatedClasses add: relatedClass instanceSide ] ] ]. behaviors := IdentitySet new. relatedClasses do: [ :eachClass | self addBehaviorsForBaseClass: eachClass to: behaviors ]. ^ behaviors asArray ] -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> parentClassNames [ - - ^ parentClassNames ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> parentClassNames: someNames [ - - parentClassNames := someNames - ifNil: [ #( ) ] - ifNotNil: [ someNames asArray ] -] - -{ #category : 'private - resolution' } -MCPCompiledMethodScopeQuery >> recordMissingClassNamed: className inScope: scopeName [ - - | suggestions | - suggestions := MCPScopeNameSuggester classSuggestionsFor: className. - self requiresCompleteScope ifTrue: [ - ^ MCPCommandError - signalMissingClassNamed: className - scopeName: scopeName ]. - warnings ifNil: [ self resetWarnings ]. - warnings add: (MCPScopeNameSuggester - missingNameWarningForKind: 'Class' - name: className - scope: scopeName - suggestions: suggestions). - ^ nil -] - -{ #category : 'private - resolution' } -MCPCompiledMethodScopeQuery >> recordMissingPackageNamed: packageName inScope: scopeName [ - - | suggestions | - suggestions := MCPScopeNameSuggester packageSuggestionsFor: - packageName. - self requiresCompleteScope ifTrue: [ - ^ MCPCommandError - signalMissingPackageNamed: packageName - scopeName: scopeName ]. - warnings ifNil: [ self resetWarnings ]. - warnings add: (MCPScopeNameSuggester - missingNameWarningForKind: 'Package' - name: packageName - scope: scopeName - suggestions: suggestions). - ^ nil -] - -{ #category : 'configuring' } -MCPCompiledMethodScopeQuery >> requireCompleteScope [ - - self requiresCompleteScope: true -] - -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> requiresCompleteScope [ - - ^ requiresCompleteScope ifNil: [ false ] -] - -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> requiresCompleteScope: aBoolean [ - - requiresCompleteScope := aBoolean = true -] - -{ #category : 'private - resolution' } -MCPCompiledMethodScopeQuery >> resetWarnings [ - - warnings := OrderedCollection new -] - { #category : 'accessing' } MCPCompiledMethodScopeQuery >> side [ @@ -474,30 +351,16 @@ MCPCompiledMethodScopeQuery >> subclassBehaviorsForClassNames [ | behaviors relatedClasses | relatedClasses := IdentitySet new. self subclassClassNames do: [ :eachName | - (self classNamed: eachName inScope: 'subclassClassNames') ifNotNil: [ - :class | - class instanceSide allSubclasses do: [ :relatedClass | - relatedClasses add: relatedClass instanceSide ] ] ]. + (self classNamed: eachName inScope: 'subclassClassNames') + ifNotNil: [ :class | + class instanceSide allSubclasses do: [ :relatedClass | + relatedClasses add: relatedClass instanceSide ] ] ]. behaviors := IdentitySet new. relatedClasses do: [ :eachClass | self addBehaviorsForBaseClass: eachClass to: behaviors ]. ^ behaviors asArray ] -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> subclassClassNames [ - - ^ subclassClassNames ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> subclassClassNames: someNames [ - - subclassClassNames := someNames - ifNil: [ #( ) ] - ifNotNil: [ someNames asArray ] -] - { #category : 'private - scope' } MCPCompiledMethodScopeQuery >> unionBehaviors [ @@ -516,25 +379,9 @@ MCPCompiledMethodScopeQuery >> unionMethods [ ^ methods asArray ] -{ #category : 'private - source' } -MCPCompiledMethodScopeQuery >> usesImplicitImageScope [ - - ^ self packageNames isEmpty and: [ - self classNames isEmpty and: [ - self hierarchyClassNames isEmpty and: [ - self subclassClassNames isEmpty and: [ - self parentClassNames isEmpty ] ] ] ] -] - { #category : 'validating' } MCPCompiledMethodScopeQuery >> validate [ (#( 'instance' 'class' 'both' ) includes: side) ifFalse: [ Error signal: 'side must be one of instance, class, or both.' ] ] - -{ #category : 'accessing' } -MCPCompiledMethodScopeQuery >> warnings [ - - ^ warnings ifNil: [ #( ) ] ifNotNil: [ warnings asArray ] -] diff --git a/src/MCP/MCPCreateClassCommand.class.st b/src/MCP/MCPCreateClassCommand.class.st index bb4fa74..406be48 100644 --- a/src/MCP/MCPCreateClassCommand.class.st +++ b/src/MCP/MCPCreateClassCommand.class.st @@ -5,9 +5,8 @@ It owns the class-builder interaction for superclass, package, tag, slots, trait " Class { #name : 'MCPCreateClassCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'superclassName', 'packageName', 'tag', @@ -71,23 +70,12 @@ MCPCreateClassCommand >> buildClass [ builder sharedVariables: self sharedVariables ]. self sharedPools ifNotEmpty: [ builder sharedPools: self resolvedSharedPools ]. - self layout ifNotNil: [ builder layout: self resolvedLayoutClass ]. + self layout ifNotNil: [ :layoutName | + builder layout: (self resolvedLayoutClassNamed: layoutName) ]. createdClass := builder install. ^ createdClass ] -{ #category : 'accessing' } -MCPCreateClassCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPCreateClassCommand >> className: aString [ - - className := aString -] - { #category : 'accessing' } MCPCreateClassCommand >> classSlots [ @@ -172,20 +160,20 @@ MCPCreateClassCommand >> resolvedClassTraitNamed: aClassTraitName [ behavior := Smalltalk globals at: classTraitName asSymbol ifAbsent: [ - MCPCommandError - signalErrorCode: #ClassTraitNotFound - message: - 'Class trait ' , originalName , ' does not exist.' - details: { - (#className -> self className). - (#classTraitName -> originalName) } asDictionary ]. + MCPCommandError + signalErrorCode: #ClassTraitNotFound + message: + 'Class trait ' , originalName , ' does not exist.' + details: { + (#className -> self className). + (#classTraitName -> originalName) } asDictionary ]. behavior isTrait ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidClassTrait - message: originalName , ' is not a class trait.' - details: { - (#className -> self className). - (#classTraitName -> originalName) } asDictionary ]. + MCPCommandError + signalErrorCode: #InvalidClassTrait + message: originalName , ' is not a class trait.' + details: { + (#className -> self className). + (#classTraitName -> originalName) } asDictionary ]. ^ behavior classTrait ] @@ -197,54 +185,6 @@ MCPCreateClassCommand >> resolvedClassTraits [ as: Array ] -{ #category : 'private' } -MCPCreateClassCommand >> resolvedLayoutClass [ - - | behavior | - self layout ifNil: [ ^ nil ]. - behavior := Smalltalk globals at: self layout asSymbol ifAbsent: [ - MCPCommandError - signalErrorCode: #LayoutClassNotFound - message: - 'Layout class ' , self layout , ' does not exist.' - details: { - (#className -> self className). - (#layout -> self layout) } asDictionary ]. - (AbstractLayout withAllSubclasses includes: behavior) ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidLayoutClass - message: self layout , ' is not a layout class.' - details: { - (#className -> self className). - (#layout -> self layout) } asDictionary ]. - ^ behavior -] - -{ #category : 'private' } -MCPCreateClassCommand >> resolvedSharedPoolNamed: aSharedPoolName [ - - | behavior sharedPoolName | - sharedPoolName := aSharedPoolName. - behavior := Smalltalk globals - at: sharedPoolName asSymbol - ifAbsent: [ - MCPCommandError - signalErrorCode: #SharedPoolNotFound - message: - 'Shared pool ' , sharedPoolName , ' does not exist.' - details: { - (#className -> self className). - (#sharedPoolName -> sharedPoolName) } asDictionary ]. - (SharedPool withAllSubclasses includes: behavior) ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidSharedPool - message: sharedPoolName , ' is not a shared pool.' - details: { - (#className -> self className). - (#sharedPoolName -> sharedPoolName) } asDictionary ]. - ^ behavior -] - { #category : 'private' } MCPCreateClassCommand >> resolvedSharedPools [ @@ -259,23 +199,23 @@ MCPCreateClassCommand >> resolvedTraitNamed: aTraitName [ | behavior traitName | traitName := aTraitName. (traitName endsWith: ' classTrait') ifTrue: [ - traitName := traitName - copyFrom: 1 - to: traitName size - ' classTrait' size ]. + traitName := traitName + copyFrom: 1 + to: traitName size - ' classTrait' size ]. behavior := Smalltalk globals at: traitName asSymbol ifAbsent: [ - MCPCommandError - signalErrorCode: #TraitNotFound - message: 'Trait ' , traitName , ' does not exist.' - details: { - (#className -> self className). - (#traitName -> traitName) } asDictionary ]. + MCPCommandError + signalErrorCode: #TraitNotFound + message: 'Trait ' , traitName , ' does not exist.' + details: { + (#className -> self className). + (#traitName -> traitName) } asDictionary ]. behavior isTrait ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidTrait - message: traitName , ' is not a trait.' - details: { - (#className -> self className). - (#traitName -> traitName) } asDictionary ]. + MCPCommandError + signalErrorCode: #InvalidTrait + message: traitName , ' is not a trait.' + details: { + (#className -> self className). + (#traitName -> traitName) } asDictionary ]. ^ behavior ] @@ -331,9 +271,9 @@ MCPCreateClassCommand >> slots: someSlots [ MCPCreateClassCommand >> superclass [ ^ Smalltalk globals at: self superclassName asSymbol ifAbsent: [ - MCPCommandError - signalMissingSuperclassNamed: self superclassName - forClassNamed: self className ] + MCPCommandError + signalMissingSuperclassNamed: self superclassName + forClassNamed: self className ] ] { #category : 'accessing' } diff --git a/src/MCP/MCPCreateClassResult.class.st b/src/MCP/MCPCreateClassResult.class.st index 6e4eb19..684c883 100644 --- a/src/MCP/MCPCreateClassResult.class.st +++ b/src/MCP/MCPCreateClassResult.class.st @@ -5,7 +5,7 @@ It wraps the MCPClassInfo for the newly created class. " Class { #name : 'MCPCreateClassResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo' ], @@ -22,12 +22,6 @@ MCPCreateClassResult class >> classInfo: aClassInfo [ yourself ] -{ #category : 'converting' } -MCPCreateClassResult >> asDictionary [ - - ^ self classInfo asDictionary copy -] - { #category : 'accessing' } MCPCreateClassResult >> classInfo [ diff --git a/src/MCP/MCPCreateClassToolCommand.class.st b/src/MCP/MCPCreateClassToolCommand.class.st index 6814773..e585e73 100644 --- a/src/MCP/MCPCreateClassToolCommand.class.st +++ b/src/MCP/MCPCreateClassToolCommand.class.st @@ -5,22 +5,12 @@ It owns tool-level execution concerns such as warning handling, class comments, " Class { #name : 'MCPCreateClassToolCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPCreateClassToolCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPCreateClassToolCommand >> execute [ @@ -30,53 +20,32 @@ MCPCreateClassToolCommand >> execute [ force: self request force requestedContext: self request requestedContext work: [ - result := (MCPCreateClassCommand - className: self request className - superclassName: self request superclassName - packageName: self request packageName - tag: self request tag - slots: self request slots - classSlots: self request classSlots - traits: self request traits - classTraits: self request classTraits - sharedVariables: self request sharedVariables - sharedPools: self request sharedPools - layout: self request layout) execute. - self request classComment ifNotNil: [ - (MCPChangeClassCommentCommand - className: self request className - classComment: self request classComment) execute ] ] + result := (MCPCreateClassCommand + className: self request className + superclassName: self request superclassName + packageName: self request packageName + tag: self request tag + slots: self request slots + classSlots: self request classSlots + traits: self request traits + classTraits: self request classTraits + sharedVariables: self request sharedVariables + sharedPools: self request sharedPools + layout: self request layout) execute. + self request classComment ifNotNil: [ + (MCPChangeClassCommentCommand + className: self request className + classComment: self request classComment) execute ] ] successResult: [ :warningMessages | - self tool - successResultText: - 'Created class ' , self request className , '.' - data: (self tool dataForResult: result action: 'create') - warnings: warningMessages ] + self tool + successResultText: + 'Created class ' , self request className , '.' + data: (self tool dataForResult: result action: 'create') + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForCreateClassNamed: self request className - superclassName: self request superclassName - packageName: self request packageName - error: error ] - -] - -{ #category : 'initialization' } -MCPCreateClassToolCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPCreateClassToolCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPCreateClassToolCommand >> tool [ - - ^ tool + self tool + failureMessageForCreateClassNamed: self request className + superclassName: self request superclassName + packageName: self request packageName + error: error ] ] diff --git a/src/MCP/MCPCreateRepositoryBranchCommand.class.st b/src/MCP/MCPCreateRepositoryBranchCommand.class.st index e05265f..45df83d 100644 --- a/src/MCP/MCPCreateRepositoryBranchCommand.class.st +++ b/src/MCP/MCPCreateRepositoryBranchCommand.class.st @@ -3,65 +3,33 @@ Command wrapper for repository_branch_create. It calls IceRepository>>createBran " Class { #name : 'MCPCreateRepositoryBranchCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPCreateRepositoryBranchCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPCreateRepositoryBranchCommand >> execute [ | beforeInfo repository result | - ^ self tool - executeMutationAction: 'createBranch' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'createBranch' work: [ - repository := self request repository. - beforeInfo := MCPRepositoryInfo fromRepository: repository. - repository createBranch: self request branchName. - result := MCPRepositoryBranchResult - repositoryBefore: beforeInfo - after: repository ] + repository := self request repository. + beforeInfo := MCPRepositoryInfo fromRepository: repository. + repository createBranch: self request branchName. + result := MCPRepositoryBranchResult + repositoryBefore: beforeInfo + after: repository ] successResult: [ :warningMessages | - self tool - successResultText: - 'Created branch ' , self request branchName , ' in repository ' - , result repositoryInfo name , '.' - data: (self tool dataForRepositoryCreateBranchResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Created branch ' , self request branchName + , ' in repository ' , result repositoryInfo name , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to create repository branch: ' - , (error messageText ifNil: [ error asString ]) ] -] - -{ #category : 'initialization' } -MCPCreateRepositoryBranchCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPCreateRepositoryBranchCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPCreateRepositoryBranchCommand >> tool [ - - ^ tool + 'Failed to create repository branch: ' + , (error messageText ifNil: [ error asString ]) ] ] diff --git a/src/MCP/MCPCreateRepositoryCommand.class.st b/src/MCP/MCPCreateRepositoryCommand.class.st index bb46031..95b3a5a 100644 --- a/src/MCP/MCPCreateRepositoryCommand.class.st +++ b/src/MCP/MCPCreateRepositoryCommand.class.st @@ -3,22 +3,12 @@ Command wrapper for repository_create. It creates an Iceberg repository through " Class { #name : 'MCPCreateRepositoryCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPCreateRepositoryCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private' } MCPCreateRepositoryCommand >> addRequestedPackagesTo: aRepository [ @@ -43,41 +33,19 @@ MCPCreateRepositoryCommand >> createRepository [ MCPCreateRepositoryCommand >> execute [ | repository result | - ^ self tool - executeMutationAction: 'create' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'create' work: [ - repository := self createRepository. - self addRequestedPackagesTo: repository. - result := MCPRepositoryCreateResult fromRepository: repository ] + repository := self createRepository. + self addRequestedPackagesTo: repository. + result := MCPRepositoryCreateResult fromRepository: repository ] successResult: [ :warningMessages | - self tool - successResultText: - 'Created repository ' , self request name , '.' - data: (self tool dataForRepositoryCreateResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Created repository ' , self request name , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to create repository ' , self request name , ': ' - , (error messageText ifNil: [ error asString ]) ] -] - -{ #category : 'initialization' } -MCPCreateRepositoryCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPCreateRepositoryCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPCreateRepositoryCommand >> tool [ - - ^ tool + 'Failed create repository ' , self request name , ': ' + , (error messageText ifNil: [ error asString ]) ] ] diff --git a/src/MCP/MCPDataTransferObject.class.st b/src/MCP/MCPDataTransferObject.class.st new file mode 100644 index 0000000..8fb3984 --- /dev/null +++ b/src/MCP/MCPDataTransferObject.class.st @@ -0,0 +1,24 @@ +" +Abstract base for MCP value objects that can be rendered as compact dictionaries. + +Subclasses implement #asDictionary. +" +Class { + #name : 'MCPDataTransferObject', + #superclass : 'Object', + #category : 'MCP-DTOs', + #package : 'MCP', + #tag : 'DTOs' +} + +{ #category : 'testing' } +MCPDataTransferObject class >> isAbstract [ + + ^ self == MCPDataTransferObject +] + +{ #category : 'converting' } +MCPDataTransferObject >> asDictionary [ + + self subclassResponsibility +] diff --git a/src/MCP/MCPDebugAttachedDebuggerSelectionStrategy.class.st b/src/MCP/MCPDebugAttachedDebuggerSelectionStrategy.class.st index ac002c7..add3e5c 100644 --- a/src/MCP/MCPDebugAttachedDebuggerSelectionStrategy.class.st +++ b/src/MCP/MCPDebugAttachedDebuggerSelectionStrategy.class.st @@ -90,6 +90,12 @@ MCPDebugAttachedDebuggerSelectionStrategy class >> reset [ ^ self ] +{ #category : 'iterating' } +MCPDebugAttachedDebuggerSelectionStrategy >> nextDebugger [ + + ^ self shouldNotImplement +] + { #category : 'debuggers' } MCPDebugAttachedDebuggerSelectionStrategy >> openDebuggerForSession: aDebugSession [ diff --git a/src/MCP/MCPDebugBreakpointsCommand.class.st b/src/MCP/MCPDebugBreakpointsCommand.class.st index 2afe974..ec429ea 100644 --- a/src/MCP/MCPDebugBreakpointsCommand.class.st +++ b/src/MCP/MCPDebugBreakpointsCommand.class.st @@ -5,10 +5,8 @@ It creates method-entry or source-interval DebugPoint breakpoints, lists registr " Class { #name : 'MCPDebugBreakpointsCommand', - #superclass : 'Object', + #superclass : 'MCPToolRequestCommand', #instVars : [ - 'tool', - 'request', 'registry' ], #category : 'MCP-Commands', @@ -100,10 +98,8 @@ MCPDebugBreakpointsCommand >> execute [ { #category : 'initialization' } MCPDebugBreakpointsCommand >> initializeTool: aTool request: aRequest registry: aRegistry [ - tool := aTool. - request := aRequest. - registry := aRegistry. - ^ self + super initializeTool: aTool request: aRequest. + registry := aRegistry ] { #category : 'private - actions' } @@ -152,12 +148,6 @@ MCPDebugBreakpointsCommand >> removeBreakpoint [ data: data ] -{ #category : 'accessing' } -MCPDebugBreakpointsCommand >> request [ - - ^ request -] - { #category : 'private - validation' } MCPDebugBreakpointsCommand >> requireSetArguments [ @@ -365,9 +355,3 @@ MCPDebugBreakpointsCommand >> targetNodeInMethod: aCompiledMethod [ ^ self sourceIntervalNodeInMethod: aCompiledMethod ]. ^ self signalUnsupportedTargetKind ] - -{ #category : 'accessing' } -MCPDebugBreakpointsCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPDebugCommand.class.st b/src/MCP/MCPDebugCommand.class.st index 00467ef..70db5be 100644 --- a/src/MCP/MCPDebugCommand.class.st +++ b/src/MCP/MCPDebugCommand.class.st @@ -5,10 +5,8 @@ It holds the tool, parsed request, and shared session registry, and provides com " Class { #name : 'MCPDebugCommand', - #superclass : 'Object', + #superclass : 'MCPToolRequestCommand', #instVars : [ - 'tool', - 'request', 'registry' ], #category : 'MCP-Commands', @@ -16,6 +14,12 @@ Class { #tag : 'Commands' } +{ #category : 'testing' } +MCPDebugCommand class >> isAbstract [ + + ^ self == MCPDebugCommand +] + { #category : 'instance creation' } MCPDebugCommand class >> tool: aTool request: aRequest [ @@ -25,19 +29,19 @@ MCPDebugCommand class >> tool: aTool request: aRequest [ registry: MCPDebugSessionRegistry default ] -{ #category : 'executing' } -MCPDebugCommand >> execute [ +{ #category : 'private - frames' } +MCPDebugCommand >> frameRefForRecord: aRecord frameIndex: frameIndex [ - self subclassResponsibility + frameIndex ifNil: [ ^ nil ]. + ^ aRecord sessionId , '/' , aRecord stateId , '/frame-' + , frameIndex asString ] { #category : 'initialization' } MCPDebugCommand >> initializeTool: aTool request: aRequest registry: aRegistry [ - tool := aTool. - request := aRequest. - registry := aRegistry. - ^ self + super initializeTool: aTool request: aRequest. + registry := aRegistry ] { #category : 'private' } @@ -70,18 +74,24 @@ MCPDebugCommand >> registry: aRegistry [ registry := aRegistry ] -{ #category : 'accessing' } -MCPDebugCommand >> request [ - - ^ request -] - { #category : 'private' } MCPDebugCommand >> requestedStateId [ ^ request requestedStateId ] +{ #category : 'private - frames' } +MCPDebugCommand >> selectedContextForRecord: aRecord frameIndex: frameIndex [ + + | contexts stateInfo | + stateInfo := MCPDebugStateInfo fromRecord: aRecord request: request. + contexts := stateInfo rawContexts. + ^ contexts + at: frameIndex + 1 + ifAbsent: [ + self signalMissingFrameIndex: frameIndex record: aRecord ] +] + { #category : 'private - frames' } MCPDebugCommand >> selectedFrameIndex [ @@ -150,6 +160,23 @@ MCPDebugCommand >> signalInvalidFrameReference: aFrameRef details: detailAssocia details: details ] +{ #category : 'private - errors' } +MCPDebugCommand >> signalMissingFrameIndex: frameIndex record: aRecord [ + + ^ MCPCommandError + signalErrorCode: #DebugFrameNotFound + message: + 'Debug frame ' , frameIndex asString + , ' was not found for session ' , aRecord sessionId , '.' + details: { + (#sessionId -> aRecord sessionId). + (#stateId -> aRecord stateId). + (#frameIndex -> frameIndex). + (#frameRef + -> (self frameRefForRecord: aRecord frameIndex: frameIndex)) } + asDictionary +] + { #category : 'private - errors' } MCPDebugCommand >> signalMissingSession [ @@ -189,12 +216,6 @@ MCPDebugCommand >> signalUnsupportedOperation: operationName [ details: { (#operation -> operationName) } asDictionary ] -{ #category : 'accessing' } -MCPDebugCommand >> tool [ - - ^ tool -] - { #category : 'private' } MCPDebugCommand >> validateFrameReferenceForRecord: aRecord [ diff --git a/src/MCP/MCPDebugControlCommand.class.st b/src/MCP/MCPDebugControlCommand.class.st index 6596991..8ca5314 100644 --- a/src/MCP/MCPDebugControlCommand.class.st +++ b/src/MCP/MCPDebugControlCommand.class.st @@ -96,14 +96,6 @@ MCPDebugControlCommand >> execute [ warnings: (data at: #warnings) ] -{ #category : 'private - frames' } -MCPDebugControlCommand >> frameRefForRecord: aRecord frameIndex: frameIndex [ - - frameIndex ifNil: [ ^ nil ]. - ^ aRecord sessionId , '/' , aRecord stateId , '/frame-' - , frameIndex asString -] - { #category : 'private - actions' } MCPDebugControlCommand >> operationRequiresContext: operationName [ @@ -200,18 +192,6 @@ MCPDebugControlCommand >> resultDataForRecord: aRecord previousStateId: previous ^ data ] -{ #category : 'private - frames' } -MCPDebugControlCommand >> selectedContextForRecord: aRecord frameIndex: frameIndex [ - - | contexts stateInfo | - stateInfo := MCPDebugStateInfo fromRecord: aRecord request: request. - contexts := stateInfo rawContexts. - ^ contexts - at: frameIndex + 1 - ifAbsent: [ - self signalMissingFrameIndex: frameIndex record: aRecord ] -] - { #category : 'private - data' } MCPDebugControlCommand >> shouldReturnStateForRecord: aRecord operation: operationName [ @@ -231,23 +211,6 @@ MCPDebugControlCommand >> signalMissingDebugSessionForRecord: aRecord [ details: { (#sessionId -> aRecord sessionId) } asDictionary ] -{ #category : 'private - errors' } -MCPDebugControlCommand >> signalMissingFrameIndex: frameIndex record: aRecord [ - - ^ MCPCommandError - signalErrorCode: #DebugFrameNotFound - message: - 'Debug frame ' , frameIndex asString - , ' was not found for session ' , aRecord sessionId , '.' - details: { - (#sessionId -> aRecord sessionId). - (#stateId -> aRecord stateId). - (#frameIndex -> frameIndex). - (#frameRef - -> (self frameRefForRecord: aRecord frameIndex: frameIndex)) } - asDictionary -] - { #category : 'private - data' } MCPDebugControlCommand >> stateSnapshotForRecord: aRecord operation: operationName [ diff --git a/src/MCP/MCPDebugController.class.st b/src/MCP/MCPDebugController.class.st index 9e73096..3265856 100644 --- a/src/MCP/MCPDebugController.class.st +++ b/src/MCP/MCPDebugController.class.st @@ -9,6 +9,12 @@ Class { #tag : 'Debugging' } +{ #category : 'testing' } +MCPDebugController class >> isAbstract [ + + ^ self == MCPDebugController +] + { #category : 'accessing' } MCPDebugController >> debugSession [ diff --git a/src/MCP/MCPDebugEvaluateCommand.class.st b/src/MCP/MCPDebugEvaluateCommand.class.st index c449a35..8d42de8 100644 --- a/src/MCP/MCPDebugEvaluateCommand.class.st +++ b/src/MCP/MCPDebugEvaluateCommand.class.st @@ -100,13 +100,6 @@ MCPDebugEvaluateCommand >> execute [ warnings: warnings ] -{ #category : 'private - frames' } -MCPDebugEvaluateCommand >> frameRefForRecord: aRecord frameIndex: frameIndex [ - - ^ aRecord sessionId , '/' , aRecord stateId , '/frame-' - , frameIndex asString -] - { #category : 'private - printing' } MCPDebugEvaluateCommand >> limitedPrintStringOf: anObject [ @@ -149,35 +142,6 @@ MCPDebugEvaluateCommand >> runtimeFailureFor: anError record: aRecord frameIndex details: details ] -{ #category : 'private - frames' } -MCPDebugEvaluateCommand >> selectedContextForRecord: aRecord frameIndex: frameIndex [ - - | contexts stateInfo | - stateInfo := MCPDebugStateInfo fromRecord: aRecord request: request. - contexts := stateInfo rawContexts. - ^ contexts - at: frameIndex + 1 - ifAbsent: [ - self signalMissingFrameIndex: frameIndex record: aRecord ] -] - -{ #category : 'private - errors' } -MCPDebugEvaluateCommand >> signalMissingFrameIndex: frameIndex record: aRecord [ - - ^ MCPCommandError - signalErrorCode: #DebugFrameNotFound - message: - 'Debug frame ' , frameIndex asString - , ' was not found for session ' , aRecord sessionId , '.' - details: { - (#sessionId -> aRecord sessionId). - (#stateId -> aRecord stateId). - (#frameIndex -> frameIndex). - (#frameRef - -> (self frameRefForRecord: aRecord frameIndex: frameIndex)) } - asDictionary -] - { #category : 'private - errors' } MCPDebugEvaluateCommand >> syntaxFailureFor: aNotice record: aRecord frameIndex: frameIndex [ diff --git a/src/MCP/MCPDebugRepairAnalyzer.class.st b/src/MCP/MCPDebugRepairAnalyzer.class.st index a4ddc97..782e6cf 100644 --- a/src/MCP/MCPDebugRepairAnalyzer.class.st +++ b/src/MCP/MCPDebugRepairAnalyzer.class.st @@ -150,13 +150,8 @@ MCPDebugRepairAnalyzer >> methodBehaviorForContext: aContext [ { #category : 'private - contexts' } MCPDebugRepairAnalyzer >> methodImplementor [ - | implementorClass session | - session := self debugSession. - session ifNil: [ ^ nil ]. - implementorClass := Smalltalk globals - at: #StDebuggerMethodImplementor - ifAbsent: [ ^ nil ]. - ^ implementorClass forSession: session + ^ self debugSession ifNotNil: [ :session | + PharoCompatibility debuggerMethodImplementorForSession: session ] ] { #category : 'private - actions' } @@ -224,7 +219,8 @@ MCPDebugRepairAnalyzer >> repairActionForContext: aContext behavior: aBehavior s (#selector -> aSelector asString). (#targetClassName -> (self classNameForBehavior: aBehavior)). (#classSide -> (self classSideForBehavior: aBehavior)). - (#arguments -> (self debugMethodUpdateArgumentsForFrameRef: frameRef)) } + (#arguments + -> (self debugMethodUpdateArgumentsForFrameRef: frameRef)) } asDictionary ] diff --git a/src/MCP/MCPDebugSessionsCommand.class.st b/src/MCP/MCPDebugSessionsCommand.class.st index 92cb635..7237b6f 100644 --- a/src/MCP/MCPDebugSessionsCommand.class.st +++ b/src/MCP/MCPDebugSessionsCommand.class.st @@ -74,12 +74,9 @@ MCPDebugSessionsCommand >> candidateIsAttached: aCandidate [ { #category : 'private - candidates' } MCPDebugSessionsCommand >> debuggerCandidates [ - | candidates debuggerClass reversed | - debuggerClass := Smalltalk globals - at: #StDebugger - ifAbsent: [ ^ #( ) ]. + | candidates reversed | candidates := OrderedCollection new. - debuggerClass allInstancesDo: [ :debugger | + StDebugger allInstancesDo: [ :debugger | | candidate | candidate := MCPDebugSessionCandidate fromDebugger: debugger. candidate isAttachable ifTrue: [ candidates add: candidate ] ]. diff --git a/src/MCP/MCPDebugToolResult.class.st b/src/MCP/MCPDebugToolResult.class.st index d9e6173..753e047 100644 --- a/src/MCP/MCPDebugToolResult.class.st +++ b/src/MCP/MCPDebugToolResult.class.st @@ -5,7 +5,7 @@ It normalizes debugger success, warning, and error payloads before they are rend " Class { #name : 'MCPDebugToolResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'status', 'summary', @@ -46,6 +46,20 @@ MCPDebugToolResult class >> okSummary: aSummary data: aDictionary warnings: warn errorDetails: nil ] +{ #category : 'converting' } +MCPDebugToolResult >> asDictionary [ + + | result | + result := Dictionary new. + result at: #status put: self status. + self summary ifNotNil: [ :text | result at: #summary put: text ]. + self data ifNotEmpty: [ :value | result at: #data put: value ]. + self warnings ifNotEmpty: [ :value | result at: #warnings put: value ]. + self errorDetails ifNotEmpty: [ :value | + result at: #error put: value ]. + ^ result +] + { #category : 'accessing' } MCPDebugToolResult >> data [ diff --git a/src/MCP/MCPDebugVariablesCommand.class.st b/src/MCP/MCPDebugVariablesCommand.class.st index e7e9eee..60abc88 100644 --- a/src/MCP/MCPDebugVariablesCommand.class.st +++ b/src/MCP/MCPDebugVariablesCommand.class.st @@ -277,15 +277,15 @@ MCPDebugVariablesCommand >> rootValueForVariableReference: aReference context: a aReference variableName ifNil: [ ^ self signalMissingVariableForReference: aReference ]. aReference scopeName = 'receiver' ifTrue: [ - aReference variableName = 'self' ifTrue: [ ^ aContext receiver ]. - ^ self signalMissingVariableForReference: aReference ]. + aReference variableName = 'self' ifTrue: [ ^ aContext receiver ]. + ^ self signalMissingVariableForReference: aReference ]. aReference scopeName = 'temporaries' ifTrue: [ - names := aContext tempNames collect: [ :each | each asString ]. - index := names - indexOf: aReference variableName - ifAbsent: [ - ^ self signalMissingVariableForReference: aReference ]. - ^ aContext tempAt: index ]. + names := aContext tempNames collect: [ :each | each asString ]. + index := names + indexOf: aReference variableName + ifAbsent: [ + ^ self signalMissingVariableForReference: aReference ]. + ^ aContext tempAt: index ]. ^ self signalMissingScopeNamed: aReference scopeName forReference: aReference diff --git a/src/MCP/MCPEvaluateCommand.class.st b/src/MCP/MCPEvaluateCommand.class.st index c80d62e..258792e 100644 --- a/src/MCP/MCPEvaluateCommand.class.st +++ b/src/MCP/MCPEvaluateCommand.class.st @@ -3,11 +3,9 @@ Command that evaluates Smalltalk code for the evaluate tool and returns a result " Class { #name : 'MCPEvaluateCommand', - #superclass : 'Object', + #superclass : 'MCPToolRequestCommand', #instVars : [ - 'request', - 'resultPreviewCharacterLimit', - 'tool' + 'resultPreviewCharacterLimit' ], #category : 'MCP-Commands', #package : 'MCP', @@ -31,15 +29,15 @@ MCPEvaluateCommand >> execute [ compiler compilationContext isScripting: true. notice := nil. compiler failBlock: [ :aNotice | - notice := aNotice. - nil ]. + notice := aNotice. + nil ]. answer := [ compiler evaluate: request code ] on: Exception do: [ :error | - (PharoCompatibility syntaxNoticeFromException: error) - ifNotNil: [ - :syntaxNotice | ^ self syntaxFailureFor: syntaxNotice ]. - ^ self runtimeFailureFor: error ]. + (PharoCompatibility syntaxNoticeFromException: error) + ifNotNil: [ :syntaxNotice | + ^ self syntaxFailureFor: syntaxNotice ]. + ^ self runtimeFailureFor: error ]. notice ifNotNil: [ ^ self syntaxFailureFor: notice ]. ^ MCPEvaluateResult okData: { (#resultClassName -> answer class name asString). @@ -57,12 +55,6 @@ MCPEvaluateCommand >> initializeTool: aTool request: aRequest resultPreviewChara ^ self ] -{ #category : 'accessing' } -MCPEvaluateCommand >> request [ - - ^ request -] - { #category : 'accessing' } MCPEvaluateCommand >> resultPreviewCharacterLimit [ @@ -88,9 +80,3 @@ MCPEvaluateCommand >> syntaxFailureFor: aNotice [ errorSummary: (tool syntaxFailureMessageFor: aNotice) details: details ] - -{ #category : 'accessing' } -MCPEvaluateCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPEvaluateResult.class.st b/src/MCP/MCPEvaluateResult.class.st index 91ab2cb..e0a0ec1 100644 --- a/src/MCP/MCPEvaluateResult.class.st +++ b/src/MCP/MCPEvaluateResult.class.st @@ -3,7 +3,7 @@ Result DTO produced by the evaluate command. It transports either evaluated data " Class { #name : 'MCPEvaluateResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'status', 'data', @@ -35,6 +35,18 @@ MCPEvaluateResult class >> okData: aDictionary [ errorDetails: nil ] +{ #category : 'converting' } +MCPEvaluateResult >> asDictionary [ + + | result | + result := Dictionary new. + result at: #status put: self status. + self data ifNotNil: [ :value | result at: #data put: value ]. + self summary ifNotNil: [ :text | result at: #summary put: text ]. + self errorDetails ifNotNil: [ :value | result at: #error put: value ]. + ^ result +] + { #category : 'accessing' } MCPEvaluateResult >> data [ diff --git a/src/MCP/MCPExportRepositoryCommand.class.st b/src/MCP/MCPExportRepositoryCommand.class.st index e62e2f9..888d78f 100644 --- a/src/MCP/MCPExportRepositoryCommand.class.st +++ b/src/MCP/MCPExportRepositoryCommand.class.st @@ -13,10 +13,8 @@ Class { MCPExportRepositoryCommand >> execute [ | changedPackageNames diff modifiedPaths repository result restoredOrderOnlyPaths tonelSnapshot | - ^ self tool - executeMutationAction: 'export' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'export' work: [ repository := self request repository. diff := repository workingCopyDiff. @@ -41,7 +39,7 @@ MCPExportRepositoryCommand >> execute [ self tool successResultText: 'Exported repository ' , result repositoryInfo name , '.' - data: (self tool dataForRepositoryExportResult: result) + data: (self tool dataForRepositoryResult: result) warnings: warningMessages ] failureSummary: [ :error | 'Failed to export repository: ' diff --git a/src/MCP/MCPFetchRepositoryCommand.class.st b/src/MCP/MCPFetchRepositoryCommand.class.st index dd4db4d..0632aab 100644 --- a/src/MCP/MCPFetchRepositoryCommand.class.st +++ b/src/MCP/MCPFetchRepositoryCommand.class.st @@ -3,64 +3,32 @@ Command wrapper for repository_fetch. It calls IceRepository>>fetch and returns " Class { #name : 'MCPFetchRepositoryCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPFetchRepositoryCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPFetchRepositoryCommand >> execute [ | beforeInfo repository result | - ^ self tool - executeMutationAction: 'fetch' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'fetch' work: [ - repository := self request repository. - beforeInfo := MCPRepositoryInfo fromRepository: repository. - repository fetch. - result := MCPRepositoryFetchResult - repositoryBefore: beforeInfo - after: repository ] + repository := self request repository. + beforeInfo := MCPRepositoryInfo fromRepository: repository. + repository fetch. + result := MCPRepositoryFetchResult + repositoryBefore: beforeInfo + after: repository ] successResult: [ :warningMessages | - self tool - successResultText: - 'Fetched repository ' , result repositoryInfo name , '.' - data: (self tool dataForRepositoryFetchResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Fetched repository ' , result repositoryInfo name , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to fetch repository: ' - , (error messageText ifNil: [ error asString ]) ] -] - -{ #category : 'initialization' } -MCPFetchRepositoryCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPFetchRepositoryCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPFetchRepositoryCommand >> tool [ - - ^ tool + 'Failed to fetch repository: ' + , (error messageText ifNil: [ error asString ]) ] ] diff --git a/src/MCP/MCPGetClassCommand.class.st b/src/MCP/MCPGetClassCommand.class.st index cb4ae59..493781f 100644 --- a/src/MCP/MCPGetClassCommand.class.st +++ b/src/MCP/MCPGetClassCommand.class.st @@ -3,22 +3,12 @@ Command that returns class metadata DTO dictionaries for class_get. " Class { #name : 'MCPGetClassCommand', - #superclass : 'Object', - #instVars : [ - 'request', - 'tool' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPGetClassCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPGetClassCommand >> execute [ @@ -44,20 +34,6 @@ MCPGetClassCommand >> execute [ subclasses: subclasses ] -{ #category : 'initialization' } -MCPGetClassCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPGetClassCommand >> request [ - - ^ request -] - { #category : 'private' } MCPGetClassCommand >> subclassesForClass: aClass [ @@ -66,8 +42,8 @@ MCPGetClassCommand >> subclassesForClass: aClass [ subclasses := OrderedCollection new. aClass allSubclassesWithLevelDo: [ :eachClass :level | - (level between: 1 and: request subclassDepth) ifTrue: [ - subclasses add: eachClass ] ] + (level between: 1 and: request subclassDepth) ifTrue: [ + subclasses add: eachClass ] ] startingLevel: 0. ^ subclasses asArray ] @@ -81,15 +57,9 @@ MCPGetClassCommand >> superclassesForClass: aClass [ targetSuperclass := Smalltalk globals at: targetSuperclassName asSymbol ifAbsent: [ - MCPCommandError - signalMissingSuperclassNamed: - targetSuperclassName - forClassNamed: aClass name asString ]. + MCPCommandError + signalMissingSuperclassNamed: + targetSuperclassName + forClassNamed: aClass name asString ]. ^ aClass allSuperclasses asArray copyUpTo: targetSuperclass ] - -{ #category : 'accessing' } -MCPGetClassCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPGetClassResult.class.st b/src/MCP/MCPGetClassResult.class.st index 8d1525c..4d64af5 100644 --- a/src/MCP/MCPGetClassResult.class.st +++ b/src/MCP/MCPGetClassResult.class.st @@ -3,7 +3,7 @@ Result DTO produced by the class_get command. " Class { #name : 'MCPGetClassResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'className', 'data', @@ -25,6 +25,18 @@ MCPGetClassResult class >> className: aClassName data: aDictionary superclasses: subclasses: subclassCollection ] +{ #category : 'converting' } +MCPGetClassResult >> asDictionary [ + + | result | + result := self data copy. + self superclasses ifNotEmpty: [ :value | + result at: #superclasses put: value ]. + self subclasses ifNotEmpty: [ :value | + result at: #subclasses put: value ]. + ^ result +] + { #category : 'accessing' } MCPGetClassResult >> className [ diff --git a/src/MCP/MCPGetMethodCommand.class.st b/src/MCP/MCPGetMethodCommand.class.st index d81be65..5609ea3 100644 --- a/src/MCP/MCPGetMethodCommand.class.st +++ b/src/MCP/MCPGetMethodCommand.class.st @@ -3,22 +3,12 @@ Command that returns method source and optional variable-reference DTOs for meth " Class { #name : 'MCPGetMethodCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPGetMethodCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPGetMethodCommand >> execute [ @@ -35,32 +25,12 @@ MCPGetMethodCommand >> execute [ (#source -> (compiledMethod sourceCode ifNil: [ '' ])) } asDictionary. request includeVariableDetails ifTrue: [ - methodBehavior := tool - behaviorNamed: request className - classSide: request classSide. - variableReferences := tool - variableSummariesForMethod: compiledMethod - methodBehavior: methodBehavior. - data at: #variableReferences put: variableReferences ]. + methodBehavior := tool + behaviorNamed: request className + classSide: request classSide. + variableReferences := tool + variableSummariesForMethod: compiledMethod + methodBehavior: methodBehavior. + data at: #variableReferences put: variableReferences ]. ^ MCPGetMethodResult data: data externalVariableCount: nil ] - -{ #category : 'initialization' } -MCPGetMethodCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPGetMethodCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPGetMethodCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPGetMethodResult.class.st b/src/MCP/MCPGetMethodResult.class.st index 73ad4e3..319a6b8 100644 --- a/src/MCP/MCPGetMethodResult.class.st +++ b/src/MCP/MCPGetMethodResult.class.st @@ -3,7 +3,7 @@ Result DTO produced by the method_get command. " Class { #name : 'MCPGetMethodResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'data', 'externalVariableCount' @@ -21,6 +21,16 @@ MCPGetMethodResult class >> data: aDictionary externalVariableCount: anIntegerOr externalVariableCount: anIntegerOrNil ] +{ #category : 'converting' } +MCPGetMethodResult >> asDictionary [ + + | result | + result := self data copy. + self externalVariableCount ifNotNil: [ :count | + result at: #externalVariableCount put: count ]. + ^ result +] + { #category : 'accessing' } MCPGetMethodResult >> data [ diff --git a/src/MCP/MCPGetToolCommand.class.st b/src/MCP/MCPGetToolCommand.class.st index 5c5600f..d71951c 100644 --- a/src/MCP/MCPGetToolCommand.class.st +++ b/src/MCP/MCPGetToolCommand.class.st @@ -5,12 +5,7 @@ This command is the second step of the discoverable-tool flow: after discovery g " Class { #name : 'MCPGetToolCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request', - 'toolExposurePolicy' - ], + #superclass : 'MCPToolCatalogCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' @@ -25,16 +20,6 @@ MCPGetToolCommand class >> tool: aTool request: aRequest [ toolExposurePolicy: MCPToolExposurePolicy default ] -{ #category : 'instance creation' } -MCPGetToolCommand class >> tool: aTool request: aRequest toolExposurePolicy: aToolExposurePolicy [ - - ^ self new - tool: aTool; - request: aRequest; - toolExposurePolicy: aToolExposurePolicy; - yourself -] - { #category : 'executing' } MCPGetToolCommand >> execute [ @@ -50,40 +35,3 @@ MCPGetToolCommand >> execute [ includeOutputSchema: request includeOutputSchema)) } asDictionary ] - -{ #category : 'accessing' } -MCPGetToolCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPGetToolCommand >> request: anObject [ - - request := anObject -] - -{ #category : 'accessing' } -MCPGetToolCommand >> tool [ - - ^ tool -] - -{ #category : 'accessing' } -MCPGetToolCommand >> tool: anObject [ - - tool := anObject -] - -{ #category : 'accessing' } -MCPGetToolCommand >> toolExposurePolicy [ - - ^ toolExposurePolicy ifNil: [ MCPToolExposurePolicy default ] -] - -{ #category : 'accessing' } -MCPGetToolCommand >> toolExposurePolicy: aToolExposurePolicy [ - - toolExposurePolicy := aToolExposurePolicy ifNil: [ - MCPToolExposurePolicy default ] -] diff --git a/src/MCP/MCPGitRepositoryMetadata.class.st b/src/MCP/MCPGitRepositoryMetadata.class.st index 9ecfe4a..caf4ff5 100644 --- a/src/MCP/MCPGitRepositoryMetadata.class.st +++ b/src/MCP/MCPGitRepositoryMetadata.class.st @@ -11,9 +11,9 @@ Class { 'gitDirectory', 'configEntries' ], - #category : 'MCP-Support', + #category : 'MCP-Utilities', #package : 'MCP', - #tag : 'Support' + #tag : 'Utilities' } { #category : 'instance creation' } diff --git a/src/MCP/MCPHTTPServer.class.st b/src/MCP/MCPHTTPServer.class.st index a244526..4ca7a8f 100644 --- a/src/MCP/MCPHTTPServer.class.st +++ b/src/MCP/MCPHTTPServer.class.st @@ -46,9 +46,9 @@ MCPHTTPServer >> answerPost: request with: response [ | payload | payload := self handleJSON: request contents. (payload isString and: [ payload isEmpty ]) ifTrue: [ - response statusLine: ZnStatusLine accepted. - response headers at: #'Content-Length' put: '0'. - ^ response ]. + response statusLine: ZnStatusLine accepted. + response headers at: #'Content-Length' put: '0'. + ^ response ]. response entity: (ZnEntity json: payload). ^ response ] diff --git a/src/MCP/MCPIcebergCommitInfo.class.st b/src/MCP/MCPIcebergCommitInfo.class.st index afac8ca..c2dc7cf 100644 --- a/src/MCP/MCPIcebergCommitInfo.class.st +++ b/src/MCP/MCPIcebergCommitInfo.class.st @@ -6,9 +6,9 @@ Iceberg has exposed commit metadata through slightly different protocols across Class { #name : 'MCPIcebergCommitInfo', #superclass : 'Object', - #category : 'MCP-DTOs', + #category : 'MCP-Utilities', #package : 'MCP', - #tag : 'DTOs' + #tag : 'Utilities' } { #category : 'accessing' } diff --git a/src/MCP/MCPImageCodeChangeTracker.class.st b/src/MCP/MCPImageCodeChangeTracker.class.st index 2d1e27f..bae2f06 100644 --- a/src/MCP/MCPImageCodeChangeTracker.class.st +++ b/src/MCP/MCPImageCodeChangeTracker.class.st @@ -11,9 +11,9 @@ Class { 'hasChanges', 'affectedPackageNames' ], - #category : 'MCP-Commands', + #category : 'MCP-Utilities', #package : 'MCP', - #tag : 'Commands' + #tag : 'Utilities' } { #category : 'accessing' } diff --git a/src/MCP/MCPImageLookup.class.st b/src/MCP/MCPImageLookup.class.st index 34c9707..1f7c508 100644 --- a/src/MCP/MCPImageLookup.class.st +++ b/src/MCP/MCPImageLookup.class.st @@ -21,9 +21,9 @@ MCPImageLookup class >> classNamed: aClassName [ MCPImageLookup class >> classNamed: aClassName scopeName: scopeName [ ^ Smalltalk globals at: aClassName asSymbol ifAbsent: [ - MCPCommandError - signalMissingClassNamed: aClassName - scopeName: scopeName ] + MCPCommandError + signalMissingClassNamed: aClassName + scopeName: scopeName ] ] { #category : 'resolving' } @@ -38,7 +38,7 @@ MCPImageLookup class >> packageNamed: aPackageName scopeName: scopeName [ ^ PackageOrganizer default packageNamed: aPackageName asSymbol ifAbsent: [ - MCPCommandError - signalMissingPackageNamed: aPackageName - scopeName: scopeName ] + MCPCommandError + signalMissingPackageNamed: aPackageName + scopeName: scopeName ] ] diff --git a/src/MCP/MCPJSONSchemaValidator.class.st b/src/MCP/MCPJSONSchemaValidator.class.st index 8ed0cfa..24aee1e 100644 --- a/src/MCP/MCPJSONSchemaValidator.class.st +++ b/src/MCP/MCPJSONSchemaValidator.class.st @@ -53,8 +53,8 @@ MCPJSONSchemaValidator >> hasObjectKeywordsIn: schema [ MCPJSONSchemaValidator >> includesPropertyNamed: propertyName in: aDictionary [ ^ (aDictionary includesKey: propertyName) or: [ - (aDictionary includesKey: propertyName asString) or: [ - aDictionary includesKey: propertyName asSymbol ] ] + (aDictionary includesKey: propertyName asString) or: [ + aDictionary includesKey: propertyName asSymbol ] ] ] { #category : 'initialization' } @@ -192,12 +192,12 @@ MCPJSONSchemaValidator >> validateAnyOfIn: schema for: aValue atPath: path [ matches := schemas count: [ :eachSchema | self schema: eachSchema matchesValue: aValue ]. matches = 0 ifTrue: [ - self - addViolationAt: path - keyword: #anyOf - message: 'Value must match at least one schema branch.' - expected: 'at least one matching branch' - actual: matches ] + self + addViolationAt: path + keyword: #anyOf + message: 'Value must match at least one schema branch.' + expected: 'at least one matching branch' + actual: matches ] ] { #category : 'private - array validation' } @@ -236,12 +236,12 @@ MCPJSONSchemaValidator >> validateConstIn: schema for: aValue atPath: path [ in: schema ifAbsent: [ ^ self ]. aValue = expectedValue ifFalse: [ - self - addViolationAt: path - keyword: #const - message: 'Value must equal the schema constant.' - expected: expectedValue - actual: aValue ] + self + addViolationAt: path + keyword: #const + message: 'Value must equal the schema constant.' + expected: expectedValue + actual: aValue ] ] { #category : 'private - object validation' } @@ -253,15 +253,15 @@ MCPJSONSchemaValidator >> validateDefinedPropertiesIn: aDictionary againstSchema in: schema ifAbsent: [ ^ self ]. properties keysAndValuesDo: [ :propertyName :propertySchema | - self - propertyValueNamed: propertyName - in: aDictionary - ifPresent: [ :value | - self - validateValue: value - againstSchema: propertySchema - atPath: (path copyWith: propertyName asString) ] - ifAbsent: [ ] ] + self + propertyValueNamed: propertyName + in: aDictionary + ifPresent: [ :value | + self + validateValue: value + againstSchema: propertySchema + atPath: (path copyWith: propertyName asString) ] + ifAbsent: [ ] ] ] { #category : 'private - validating' } @@ -273,12 +273,12 @@ MCPJSONSchemaValidator >> validateEnumIn: schema for: aValue atPath: path [ in: schema ifAbsent: [ ^ self ]. (expectedValues includes: aValue) ifFalse: [ - self - addViolationAt: path - keyword: #enum - message: 'Value must be one of the schema enum values.' - expected: expectedValues - actual: aValue ] + self + addViolationAt: path + keyword: #enum + message: 'Value must be one of the schema enum values.' + expected: expectedValues + actual: aValue ] ] { #category : 'private - combinators' } @@ -306,12 +306,12 @@ MCPJSONSchemaValidator >> validateNotIn: schema for: aValue atPath: path [ in: schema ifAbsent: [ ^ self ]. (self schema: prohibitedSchema matchesValue: aValue) ifTrue: [ - self - addViolationAt: path - keyword: #not - message: 'Value must not match the prohibited schema.' - expected: 'a value that does not match the prohibited schema' - actual: 'matched prohibited schema' ] + self + addViolationAt: path + keyword: #not + message: 'Value must not match the prohibited schema.' + expected: 'a value that does not match the prohibited schema' + actual: 'matched prohibited schema' ] ] { #category : 'private - number validation' } @@ -363,12 +363,12 @@ MCPJSONSchemaValidator >> validateOneOfIn: schema for: aValue atPath: path [ matches := schemas count: [ :eachSchema | self schema: eachSchema matchesValue: aValue ]. matches = 1 ifFalse: [ - self - addViolationAt: path - keyword: #oneOf - message: 'Value must match exactly one schema branch.' - expected: 'exactly one matching branch' - actual: matches ] + self + addViolationAt: path + keyword: #oneOf + message: 'Value must match exactly one schema branch.' + expected: 'exactly one matching branch' + actual: matches ] ] { #category : 'private - object validation' } @@ -380,13 +380,14 @@ MCPJSONSchemaValidator >> validateRequiredPropertiesIn: aDictionary againstSchem in: schema ifAbsent: [ #( ) ]. requiredProperties do: [ :propertyName | - (self includesPropertyNamed: propertyName in: aDictionary) ifFalse: [ - self - addViolationAt: path - keyword: #required - message: 'Object is missing a required property.' - expected: propertyName - actual: nil ] ] + (self includesPropertyNamed: propertyName in: aDictionary) + ifFalse: [ + self + addViolationAt: path + keyword: #required + message: 'Object is missing a required property.' + expected: propertyName + actual: nil ] ] ] { #category : 'private - string validation' } diff --git a/src/MCP/MCPListChangeHistoryEntriesCommand.class.st b/src/MCP/MCPListChangeHistoryEntriesCommand.class.st index 1afa023..083ef1f 100644 --- a/src/MCP/MCPListChangeHistoryEntriesCommand.class.st +++ b/src/MCP/MCPListChangeHistoryEntriesCommand.class.st @@ -42,11 +42,11 @@ MCPListChangeHistoryEntriesCommand >> matchingEntryPairsFrom: aLog [ | pairs | pairs := OrderedCollection new. aLog entries doWithIndex: [ :entry :index | - (request codeChangesOnly not or: [ self isCodeChangeEntry: entry ]) - ifTrue: [ - pairs add: { - index. - entry } ] ]. + (request codeChangesOnly not or: [ self isCodeChangeEntry: entry ]) + ifTrue: [ + pairs add: { + index. + entry } ] ]. request newestFirst ifTrue: [ ^ pairs reversed asOrderedCollection ]. ^ pairs ] diff --git a/src/MCP/MCPListChangeHistoryLogsCommand.class.st b/src/MCP/MCPListChangeHistoryLogsCommand.class.st index 2f26a86..ea05c46 100644 --- a/src/MCP/MCPListChangeHistoryLogsCommand.class.st +++ b/src/MCP/MCPListChangeHistoryLogsCommand.class.st @@ -78,15 +78,6 @@ MCPListChangeHistoryLogsCommand >> execute [ page: resultPage ] -{ #category : 'private' } -MCPListChangeHistoryLogsCommand >> historyDirectoryForCurrentFile: aFileReference [ - - aFileReference ifNotNil: [ ^ aFileReference parent ]. - ^ [ EpMonitor logsDirectory ] - on: Error - do: [ :error | FileLocator localDirectory asFileReference ] -] - { #category : 'private' } MCPListChangeHistoryLogsCommand >> historyFileReferencesFrom: aDirectory including: currentFile [ diff --git a/src/MCP/MCPLoadBaselineCommand.class.st b/src/MCP/MCPLoadBaselineCommand.class.st index 9443feb..bd92fce 100644 --- a/src/MCP/MCPLoadBaselineCommand.class.st +++ b/src/MCP/MCPLoadBaselineCommand.class.st @@ -3,10 +3,8 @@ Command that performs a Metacello baseline load and reports packages and reposit " Class { #name : 'MCPLoadBaselineCommand', - #superclass : 'Object', + #superclass : 'MCPToolRequestCommand', #instVars : [ - 'tool', - 'request', 'configureMetacelloBlock' ], #category : 'MCP-Commands', @@ -83,19 +81,17 @@ MCPLoadBaselineCommand >> execute [ { #category : 'initialization' } MCPLoadBaselineCommand >> initializeTool: aTool request: aRequest configureMetacello: aBlock [ - tool := aTool. - request := aRequest. - configureMetacelloBlock := aBlock. - ^ self + super initializeTool: aTool request: aRequest. + configureMetacelloBlock := aBlock ] { #category : 'private - loading' } MCPLoadBaselineCommand >> loadMetacello: metacello [ [ - self request groups isEmpty - ifTrue: [ metacello load ] - ifFalse: [ metacello load: self request groups ] ] + self request groups isEmpty + ifTrue: [ metacello load ] + ifFalse: [ metacello load: self request groups ] ] on: MetacelloNotification do: [ :notification | notification resume ] ] @@ -126,15 +122,3 @@ MCPLoadBaselineCommand >> newRepositoryInfosAfter: beforeRepositories [ thenCollect: [ :each | MCPRepositoryInfo fromRepository: each ]) asArray ] - -{ #category : 'accessing' } -MCPLoadBaselineCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPLoadBaselineCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPLoadBaselineResult.class.st b/src/MCP/MCPLoadBaselineResult.class.st index f21611b..da891d4 100644 --- a/src/MCP/MCPLoadBaselineResult.class.st +++ b/src/MCP/MCPLoadBaselineResult.class.st @@ -3,7 +3,7 @@ Result DTO for the reusable Metacello baseline load core. It reports baseline gr " Class { #name : 'MCPLoadBaselineResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'baseline', 'groups', diff --git a/src/MCP/MCPLoadRepositoryCommand.class.st b/src/MCP/MCPLoadRepositoryCommand.class.st index 816993b..54f54c4 100644 --- a/src/MCP/MCPLoadRepositoryCommand.class.st +++ b/src/MCP/MCPLoadRepositoryCommand.class.st @@ -3,22 +3,12 @@ Command for repository_load. It dispatches baseline-only loads to MCPLoadBaselin " Class { #name : 'MCPLoadRepositoryCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPLoadRepositoryCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private - executing' } MCPLoadRepositoryCommand >> baselineCommandClass [ @@ -47,23 +37,3 @@ MCPLoadRepositoryCommand >> execute [ repositoryUrl: repositoryUrl loadResult: loadResult ] - -{ #category : 'initialization' } -MCPLoadRepositoryCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPLoadRepositoryCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPLoadRepositoryCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPLoadRepositoryRequest.class.st b/src/MCP/MCPLoadRepositoryRequest.class.st index 64a7ccf..60ee540 100644 --- a/src/MCP/MCPLoadRepositoryRequest.class.st +++ b/src/MCP/MCPLoadRepositoryRequest.class.st @@ -347,10 +347,10 @@ MCPLoadRepositoryRequest >> repositoryScheme [ scheme = 'gitlabs' ifTrue: [ ^ 'gitlab' ]. scheme = 'bitbucket.org' ifTrue: [ ^ 'bitbucket' ]. (#( 'github' 'gitlab' 'bitbucket' ) includes: scheme) ifFalse: [ - MCPCommandError - signalErrorCode: #UnsupportedLoadRepositoryHost - message: 'hostUrl must identify github, gitlab, or bitbucket.' - details: { (#hostUrl -> self hostUrl) } asDictionary ]. + MCPCommandError + signalErrorCode: #UnsupportedLoadRepositoryHost + message: 'hostUrl must identify github, gitlab, or bitbucket.' + details: { (#hostUrl -> self hostUrl) } asDictionary ]. ^ scheme ] diff --git a/src/MCP/MCPLoadRepositoryResult.class.st b/src/MCP/MCPLoadRepositoryResult.class.st index 9e14258..48b54f1 100644 --- a/src/MCP/MCPLoadRepositoryResult.class.st +++ b/src/MCP/MCPLoadRepositoryResult.class.st @@ -3,7 +3,7 @@ Result DTO for repository_load. It wraps the reusable baseline load result and r " Class { #name : 'MCPLoadRepositoryResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'mode', 'repositoryUrl', diff --git a/src/MCP/MCPMessageNotUnderstoodHandlerRule.class.st b/src/MCP/MCPMessageNotUnderstoodHandlerRule.class.st index a53bc33..556508d 100644 --- a/src/MCP/MCPMessageNotUnderstoodHandlerRule.class.st +++ b/src/MCP/MCPMessageNotUnderstoodHandlerRule.class.st @@ -26,7 +26,7 @@ MCPMessageNotUnderstoodHandlerRule class >> forbiddenExceptionName [ { #category : 'accessing' } MCPMessageNotUnderstoodHandlerRule class >> group [ - ^ self designFlawGroup + ^ #'Design Flaws' ] { #category : 'accessing' } diff --git a/src/MCP/MCPMessageProcessor.class.st b/src/MCP/MCPMessageProcessor.class.st index b3bf0ec..e1c5805 100644 --- a/src/MCP/MCPMessageProcessor.class.st +++ b/src/MCP/MCPMessageProcessor.class.st @@ -24,31 +24,31 @@ MCPMessageProcessor >> addHandler: aJRPCHandler [ MCPMessageProcessor >> addHandlersFromPragmasIn: anObject [ (Pragma allNamed: #jrpc: in: anObject class) do: [ :pragma | - self addHandler: (MCPMessageSendHandler new - receiver: anObject; - methodName: pragma arguments first; - messageSelector: pragma methodSelector; - yourself) ] + self addHandler: (MCPMessageSendHandler new + receiver: anObject; + methodName: pragma arguments first; + messageSelector: pragma methodSelector; + yourself) ] ] { #category : 'handling - jrpc' } MCPMessageProcessor >> handleJRPCRequestObject: aJRPCRequestObject [ ^ [ - | handler result | - handler := self handlerFor: aJRPCRequestObject. - handler checkParametersForRequest: aJRPCRequestObject. - result := handler executeWithArguments: aJRPCRequestObject params. - JRPCSuccessResponseObject id: aJRPCRequestObject id result: result ] + | handler result | + handler := self handlerFor: aJRPCRequestObject. + handler checkParametersForRequest: aJRPCRequestObject. + result := handler executeWithArguments: aJRPCRequestObject params. + JRPCSuccessResponseObject id: aJRPCRequestObject id result: result ] on: Exception do: [ :exception | - self debugMode - ifTrue: [ exception pass ] - ifFalse: [ - exception return: - (self - responseForException: exception - request: aJRPCRequestObject) ] ] + self debugMode + ifTrue: [ exception pass ] + ifFalse: [ + exception return: + (self + responseForException: exception + request: aJRPCRequestObject) ] ] ] { #category : 'handling - json' } @@ -56,14 +56,14 @@ MCPMessageProcessor >> handleJSON: aJSONString [ | jrpcResponse | jrpcResponse := [ - (self parseSupposedJRPCMessageObjectFromString: - aJSONString) beHandledBy: self ] + (self parseSupposedJRPCMessageObjectFromString: + aJSONString) beHandledBy: self ] on: Exception do: [ :exception | - self debugMode - ifTrue: [ exception pass ] - ifFalse: [ - exception return: exception asJRPCResponse ] ]. + self debugMode + ifTrue: [ exception pass ] + ifFalse: [ + exception return: exception asJRPCResponse ] ]. ^ jrpcResponse beConvertedBy: self ] diff --git a/src/MCP/MCPMessageSendHandler.class.st b/src/MCP/MCPMessageSendHandler.class.st index 3857c19..957a5cf 100644 --- a/src/MCP/MCPMessageSendHandler.class.st +++ b/src/MCP/MCPMessageSendHandler.class.st @@ -11,6 +11,12 @@ Class { #tag : 'Server' } +{ #category : 'accessing' } +MCPMessageSendHandler class >> defaultMethodName [ + + ^ self shouldNotImplement +] + { #category : 'private' } MCPMessageSendHandler >> argumentsFromParameters: parameters [ diff --git a/src/MCP/MCPMethodAppliedChangeResult.class.st b/src/MCP/MCPMethodAppliedChangeResult.class.st index 8d0702b..167e97d 100644 --- a/src/MCP/MCPMethodAppliedChangeResult.class.st +++ b/src/MCP/MCPMethodAppliedChangeResult.class.st @@ -3,57 +3,14 @@ Compact public result for a method update selected and executed by a method muta " Class { #name : 'MCPMethodAppliedChangeResult', - #superclass : 'Object', - #instVars : [ - 'updatePlan', - 'changeResult' - ], + #superclass : 'MCPAppliedChangeResult', #category : 'MCP-Results', #package : 'MCP', #tag : 'Results' } -{ #category : 'instance creation' } -MCPMethodAppliedChangeResult class >> updatePlan: anUpdatePlan changeResult: aChangeResult [ - - ^ self new - updatePlan: anUpdatePlan; - changeResult: aChangeResult; - yourself -] - { #category : 'converting' } MCPMethodAppliedChangeResult >> asDictionary [ ^ self changeResult asDictionary copy ] - -{ #category : 'accessing' } -MCPMethodAppliedChangeResult >> changeResult [ - - ^ changeResult -] - -{ #category : 'accessing' } -MCPMethodAppliedChangeResult >> changeResult: aResult [ - - changeResult := aResult -] - -{ #category : 'accessing' } -MCPMethodAppliedChangeResult >> updateAction [ - - ^ self updatePlan updateAction -] - -{ #category : 'accessing' } -MCPMethodAppliedChangeResult >> updatePlan [ - - ^ updatePlan -] - -{ #category : 'accessing' } -MCPMethodAppliedChangeResult >> updatePlan: anUpdatePlan [ - - updatePlan := anUpdatePlan -] diff --git a/src/MCP/MCPMethodCompileRequest.class.st b/src/MCP/MCPMethodCompileRequest.class.st index 410999f..66f72e4 100644 --- a/src/MCP/MCPMethodCompileRequest.class.st +++ b/src/MCP/MCPMethodCompileRequest.class.st @@ -55,8 +55,7 @@ MCPMethodCompileRequest >> initializeFromRequest: request tool: aTool [ classSide := request booleanArgumentNamed: 'classSide' default: false. methodSource := (request argumentNamed: 'source' ifAbsent: [ MCPInvalidToolInput - signalMissingRequiredArgumentNamed: - 'source' + signalMissingRequiredArgumentNamed: 'source' forTool: aTool ]) withInternalLineEndings. protocol := request stringArgumentNamed: 'protocol'. force := request booleanArgumentNamed: 'force' default: false. diff --git a/src/MCP/MCPMethodCompileResult.class.st b/src/MCP/MCPMethodCompileResult.class.st index 0bcb5ad..c546b29 100644 --- a/src/MCP/MCPMethodCompileResult.class.st +++ b/src/MCP/MCPMethodCompileResult.class.st @@ -5,7 +5,7 @@ It reports whether compiling the source created a new method or replaced an exis " Class { #name : 'MCPMethodCompileResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'methodInfo', 'critiques', diff --git a/src/MCP/MCPMethodReferenceSpec.class.st b/src/MCP/MCPMethodReferenceSpec.class.st index 7bcd1a5..df5e890 100644 --- a/src/MCP/MCPMethodReferenceSpec.class.st +++ b/src/MCP/MCPMethodReferenceSpec.class.st @@ -52,10 +52,10 @@ MCPMethodReferenceSpec >> compiledMethod [ behavior := self behavior. selectorSymbol := self selector asSymbol. (behavior includesSelector: selectorSymbol) ifFalse: [ - MCPCommandError - signalMissingMethodInClassName: self className - classSide: self classSide - selector: self selector ]. + MCPCommandError + signalMissingMethodInClassName: self className + classSide: self classSide + selector: self selector ]. ^ behavior compiledMethodAt: selectorSymbol ] diff --git a/src/MCP/MCPMethodRewriteChangeInfo.class.st b/src/MCP/MCPMethodRewriteChangeInfo.class.st index aca25d9..e253527 100644 --- a/src/MCP/MCPMethodRewriteChangeInfo.class.st +++ b/src/MCP/MCPMethodRewriteChangeInfo.class.st @@ -5,7 +5,7 @@ It records the affected method identity and, when requested, the before and afte " Class { #name : 'MCPMethodRewriteChangeInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'className', 'classSide', @@ -38,8 +38,8 @@ MCPMethodRewriteChangeInfo >> asDictionary [ (#packageName -> self packageName). (#protocol -> self protocol) } asDictionary. self includeSources ifTrue: [ - data at: #oldSource put: self oldSource. - data at: #newSource put: self newSource ]. + data at: #oldSource put: self oldSource. + data at: #newSource put: self newSource ]. ^ data ] @@ -76,14 +76,14 @@ MCPMethodRewriteChangeInfo >> initializeFromChange: aChange includeSources: aBoo ifAbsent: [ nil ]. compiledMethod ifNil: [ - packageName := ''. - protocol := ''. - oldSource := '' ] + packageName := ''. + protocol := ''. + oldSource := '' ] ifNotNil: [ - methodInfo := MCPCompiledMethodInfo fromMethod: compiledMethod. - packageName := methodInfo packageName. - protocol := methodInfo protocol. - oldSource := compiledMethod sourceCode ifNil: [ '' ] ]. + methodInfo := MCPCompiledMethodInfo fromMethod: compiledMethod. + packageName := methodInfo packageName. + protocol := methodInfo protocol. + oldSource := compiledMethod sourceCode ifNil: [ '' ] ]. newSource := aChange source ifNil: [ '' ]. includeSources := aBoolean. ^ self diff --git a/src/MCP/MCPMethodRewriteReport.class.st b/src/MCP/MCPMethodRewriteReport.class.st index 880de65..d868b00 100644 --- a/src/MCP/MCPMethodRewriteReport.class.st +++ b/src/MCP/MCPMethodRewriteReport.class.st @@ -5,7 +5,7 @@ It summarizes preview or apply mode, calculated and applied change counts, norma " Class { #name : 'MCPMethodRewriteReport', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'apply', 'changeInfos', diff --git a/src/MCP/MCPMethodRewriteRuleSpec.class.st b/src/MCP/MCPMethodRewriteRuleSpec.class.st index 92ab169..6361bb5 100644 --- a/src/MCP/MCPMethodRewriteRuleSpec.class.st +++ b/src/MCP/MCPMethodRewriteRuleSpec.class.st @@ -129,15 +129,15 @@ MCPMethodRewriteRuleSpec >> signalInvalidPatternError: anError [ MCPMethodRewriteRuleSpec >> validateAtIndex: index [ lhs ifNil: [ - MCPCommandError - signalErrorCode: #RewriteRuleMissingLhs - message: 'Rewrite rule ' , index asString , ' is missing lhs.' - details: self diagnosticDetails ]. + MCPCommandError + signalErrorCode: #RewriteRuleMissingLhs + message: 'Rewrite rule ' , index asString , ' is missing lhs.' + details: self diagnosticDetails ]. rhs ifNil: [ - MCPCommandError - signalErrorCode: #RewriteRuleMissingRhs - message: 'Rewrite rule ' , index asString , ' is missing rhs.' - details: self diagnosticDetails ] + MCPCommandError + signalErrorCode: #RewriteRuleMissingRhs + message: 'Rewrite rule ' , index asString , ' is missing rhs.' + details: self diagnosticDetails ] ] { #category : 'validating' } diff --git a/src/MCP/MCPMethodStyleRule.class.st b/src/MCP/MCPMethodStyleRule.class.st index fb51ff8..ab65c66 100644 --- a/src/MCP/MCPMethodStyleRule.class.st +++ b/src/MCP/MCPMethodStyleRule.class.st @@ -14,7 +14,7 @@ Class { { #category : 'accessing' } MCPMethodStyleRule class >> group [ - ^ self designFlawGroup + ^ #'Design Flaws' ] { #category : 'testing' } diff --git a/src/MCP/MCPMethodUpdateChangeResult.class.st b/src/MCP/MCPMethodUpdateChangeResult.class.st index c1b8597..dc6cfb0 100644 --- a/src/MCP/MCPMethodUpdateChangeResult.class.st +++ b/src/MCP/MCPMethodUpdateChangeResult.class.st @@ -3,7 +3,7 @@ DTO for the narrow method update performed by a method update request, such as a " Class { #name : 'MCPMethodUpdateChangeResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'methodInfo', 'oldSelector', diff --git a/src/MCP/MCPMethodUpdatePlanInfo.class.st b/src/MCP/MCPMethodUpdatePlanInfo.class.st index 6d6c1f4..5a1a55c 100644 --- a/src/MCP/MCPMethodUpdatePlanInfo.class.st +++ b/src/MCP/MCPMethodUpdatePlanInfo.class.st @@ -3,14 +3,14 @@ DTO for the method update action selected from an update request before the acti " Class { #name : 'MCPMethodUpdatePlanInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'requestedContext', 'updateAction' ], - #category : 'MCP-Results', + #category : 'MCP-DTOs', #package : 'MCP', - #tag : 'Results' + #tag : 'DTOs' } { #category : 'instance creation' } diff --git a/src/MCP/MCPMethodUpdateRequest.class.st b/src/MCP/MCPMethodUpdateRequest.class.st index 163af32..499fdec 100644 --- a/src/MCP/MCPMethodUpdateRequest.class.st +++ b/src/MCP/MCPMethodUpdateRequest.class.st @@ -29,13 +29,13 @@ MCPMethodUpdateRequest class >> fromRequest: request tool: aTool [ parsedRequest := self new initializeFromRequest: request. parsedRequest hasRenameUpdate ifTrue: [ - parsedRequest refactoringScopeSpec: - (aTool refactoringScopeSpecFromRequest: request) ] + parsedRequest refactoringScopeSpec: + (aTool refactoringScopeSpecFromRequest: request) ] ifFalse: [ - parsedRequest refactoringScopeSpec: (MCPRefactoringScopeSpec - packageNames: #( ) - classNames: #( ) - hierarchyClassNames: #( )) ]. + parsedRequest refactoringScopeSpec: (MCPRefactoringScopeSpec + packageNames: #( ) + classNames: #( ) + hierarchyClassNames: #( )) ]. ^ parsedRequest ] @@ -61,15 +61,15 @@ MCPMethodUpdateRequest >> argumentRenameMapForBehavior: aBehavior [ oldArgumentNames := parseTree argumentNames. renameMap := OrderedCollection new. 1 to: self permutation size do: [ :targetIndex | - | oldIndex newArgumentName oldArgumentName renameArgument | - oldIndex := self permutation at: targetIndex. - oldIndex > 0 ifTrue: [ - oldArgumentName := oldArgumentNames at: oldIndex. - newArgumentName := self argumentNames at: targetIndex. - oldArgumentName = newArgumentName ifFalse: [ - renameArgument := RBArgumentName name: oldArgumentName. - renameArgument newName: newArgumentName. - renameMap add: renameArgument ] ] ]. + | oldIndex newArgumentName oldArgumentName renameArgument | + oldIndex := self permutation at: targetIndex. + oldIndex > 0 ifTrue: [ + oldArgumentName := oldArgumentNames at: oldIndex. + newArgumentName := self argumentNames at: targetIndex. + oldArgumentName = newArgumentName ifFalse: [ + renameArgument := RBArgumentName name: oldArgumentName. + renameArgument newName: newArgumentName. + renameMap add: renameArgument ] ] ]. ^ renameMap asArray ] @@ -126,8 +126,8 @@ MCPMethodUpdateRequest >> defaultPermutationFromSelector: oldSelector toSelector ^ self identityPermutationForSelector: oldSelector ]. newArgumentCount = 0 ifTrue: [ ^ #( ) ]. oldArgumentCount = 0 ifTrue: [ - ^ ((1 to: newArgumentCount) collect: [ :index | index negated ]) - asArray ]. + ^ ((1 to: newArgumentCount) collect: [ :index | index negated ]) + asArray ]. ^ self keywordPermutationFromSelector: oldSelector toSelector: newSelector @@ -212,18 +212,18 @@ MCPMethodUpdateRequest >> keywordPermutationFromSelector: oldSelector toSelector usedOldIndexes := Set new. nextNewArgument := 0. ^ (newSelector keywords collect: [ :keyword | - | oldIndex | - oldIndex := self - unusedIndexOf: keyword - in: oldKeywords - excluding: usedOldIndexes. - oldIndex = 0 - ifTrue: [ - nextNewArgument := nextNewArgument + 1. - nextNewArgument negated ] - ifFalse: [ - usedOldIndexes add: oldIndex. - oldIndex ] ]) asArray + | oldIndex | + oldIndex := self + unusedIndexOf: keyword + in: oldKeywords + excluding: usedOldIndexes. + oldIndex = 0 + ifTrue: [ + nextNewArgument := nextNewArgument + 1. + nextNewArgument negated ] + ifFalse: [ + usedOldIndexes add: oldIndex. + oldIndex ] ]) asArray ] { #category : 'converting' } @@ -274,10 +274,10 @@ MCPMethodUpdateRequest >> permutationFromRequest: request selector: oldSelector requestedPermutation := request arrayArgumentNamed: 'permutation' ifAbsent: [ - ^ self - defaultPermutationFromSelector: - oldSelector - toSelector: selectorToUse ]. + ^ self + defaultPermutationFromSelector: + oldSelector + toSelector: selectorToUse ]. self validatePermutation: requestedPermutation fromSelector: oldSelector @@ -335,9 +335,9 @@ MCPMethodUpdateRequest >> requestedContext [ context at: #classSide put: self classSide. context at: #selector put: self selector. self suppliedProperties do: [ :propertyName | - context - at: propertyName asSymbol - put: (self contextValueForPropertyNamed: propertyName) ]. + context + at: propertyName asSymbol + put: (self contextValueForPropertyNamed: propertyName) ]. ^ context ] @@ -368,8 +368,8 @@ MCPMethodUpdateRequest >> suppliedProperties [ MCPMethodUpdateRequest >> unusedIndexOf: keyword in: oldKeywords excluding: usedOldIndexes [ 1 to: oldKeywords size do: [ :index | - ((oldKeywords at: index) = keyword and: [ - (usedOldIndexes includes: index) not ]) ifTrue: [ ^ index ] ]. + ((oldKeywords at: index) = keyword and: [ + (usedOldIndexes includes: index) not ]) ifTrue: [ ^ index ] ]. ^ 0 ] @@ -384,31 +384,31 @@ MCPMethodUpdateRequest >> updatePropertyNames [ MCPMethodUpdateRequest >> validateAddArgumentsUpdate [ self argumentNames isEmpty ifTrue: [ - MCPCommandError - signalErrorCode: #ArgumentNamesRequiredForAddedArguments - message: - 'argumentNames is required when newSelector adds method arguments.' - details: self requestedContext ]. + MCPCommandError + signalErrorCode: #ArgumentNamesRequiredForAddedArguments + message: + 'argumentNames is required when newSelector adds method arguments.' + details: self requestedContext ]. self argumentNames size = self newSelector asSymbol numArgs ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidMethodArgumentNames - message: - 'argumentNames must contain one name for each target selector argument.' - details: self requestedContext ]. - (self argumentNames allSatisfy: [ :each | each isNotEmpty ]) - ifFalse: [ MCPCommandError signalErrorCode: #InvalidMethodArgumentNames - message: 'argumentNames must not contain empty names.' + message: + 'argumentNames must contain one name for each target selector argument.' details: self requestedContext ]. + (self argumentNames allSatisfy: [ :each | each isNotEmpty ]) + ifFalse: [ + MCPCommandError + signalErrorCode: #InvalidMethodArgumentNames + message: 'argumentNames must not contain empty names.' + details: self requestedContext ]. (self argumentValueExpressions isNotEmpty and: [ self argumentValueExpressions size ~= self addedArgumentCount ]) ifTrue: [ - MCPCommandError - signalErrorCode: #InvalidMethodArgumentValueExpressions - message: - 'argumentValueExpressions must contain one expression for each newly added argument.' - details: self requestedContext ]. + MCPCommandError + signalErrorCode: #InvalidMethodArgumentValueExpressions + message: + 'argumentValueExpressions must contain one expression for each newly added argument.' + details: self requestedContext ]. ^ self ] @@ -417,20 +417,20 @@ MCPMethodUpdateRequest >> validateForUpdate [ | action | self hasPermutation ifTrue: [ - self hasRenameUpdate ifFalse: [ - MCPCommandError - signalErrorCode: #PermutationRequiresMethodSelectorUpdate - message: - 'permutation is only valid when update changes a method selector with newSelector.' - details: self requestedContext ] ]. + self hasRenameUpdate ifFalse: [ + MCPCommandError + signalErrorCode: #PermutationRequiresMethodSelectorUpdate + message: + 'permutation is only valid when update changes a method selector with newSelector.' + details: self requestedContext ] ]. (self hasArgumentNames or: [ self hasArgumentValueExpressions ]) ifTrue: [ - self hasRenameUpdate ifFalse: [ - MCPCommandError - signalErrorCode: #ArgumentMetadataRequiresMethodSelectorUpdate - message: - 'argumentNames and argumentValueExpressions are only valid with newSelector.' - details: self requestedContext ] ]. + self hasRenameUpdate ifFalse: [ + MCPCommandError + signalErrorCode: #ArgumentMetadataRequiresMethodSelectorUpdate + message: + 'argumentNames and argumentValueExpressions are only valid with newSelector.' + details: self requestedContext ] ]. action := self newSelectorUpdateAction. action = 'addArguments' ifTrue: [ self validateAddArgumentsUpdate ]. ^ self @@ -443,51 +443,51 @@ MCPMethodUpdateRequest >> validatePermutation: requestedPermutation fromSelector oldArgumentCount := oldSelector numArgs. newArgumentCount := newSelector numArgs. requestedPermutation size = newArgumentCount ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidMethodArgumentPermutation - message: - 'permutation must contain one entry for each target selector argument.' - details: self requestedContext ]. - (requestedPermutation allSatisfy: [ :each | each isInteger ]) - ifFalse: [ MCPCommandError signalErrorCode: #InvalidMethodArgumentPermutation - message: 'permutation entries must be integers.' + message: + 'permutation must contain one entry for each target selector argument.' details: self requestedContext ]. + (requestedPermutation allSatisfy: [ :each | each isInteger ]) + ifFalse: [ + MCPCommandError + signalErrorCode: #InvalidMethodArgumentPermutation + message: 'permutation entries must be integers.' + details: self requestedContext ]. positiveIndexes := requestedPermutation select: [ :each | each > 0 ]. (positiveIndexes allSatisfy: [ :each | each between: 1 and: oldArgumentCount ]) ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidMethodArgumentPermutation - message: - 'positive permutation entries must reference existing arguments by 1-based index.' - details: self requestedContext ]. + MCPCommandError + signalErrorCode: #InvalidMethodArgumentPermutation + message: + 'positive permutation entries must reference existing arguments by 1-based index.' + details: self requestedContext ]. positiveIndexes asSet size = positiveIndexes size ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidMethodArgumentPermutation - message: - 'permutation must not reference the same old argument twice.' - details: self requestedContext ]. + MCPCommandError + signalErrorCode: #InvalidMethodArgumentPermutation + message: + 'permutation must not reference the same old argument twice.' + details: self requestedContext ]. newArgumentCount >= oldArgumentCount ifTrue: [ - positiveIndexes size = oldArgumentCount ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidMethodArgumentPermutation - message: - 'adding arguments requires every old argument to appear exactly once in permutation.' - details: self requestedContext ] ] + positiveIndexes size = oldArgumentCount ifFalse: [ + MCPCommandError + signalErrorCode: #InvalidMethodArgumentPermutation + message: + 'adding arguments requires every old argument to appear exactly once in permutation.' + details: self requestedContext ] ] ifFalse: [ - positiveIndexes size = newArgumentCount ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidMethodArgumentPermutation - message: - 'removing arguments requires permutation to contain only kept old argument indexes.' - details: self requestedContext ]. - (requestedPermutation allSatisfy: [ :each | each > 0 ]) ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidMethodArgumentPermutation - message: - 'removing arguments does not accept negative permutation entries.' - details: self requestedContext ] ]. + positiveIndexes size = newArgumentCount ifFalse: [ + MCPCommandError + signalErrorCode: #InvalidMethodArgumentPermutation + message: + 'removing arguments requires permutation to contain only kept old argument indexes.' + details: self requestedContext ]. + (requestedPermutation allSatisfy: [ :each | each > 0 ]) ifFalse: [ + MCPCommandError + signalErrorCode: #InvalidMethodArgumentPermutation + message: + 'removing arguments does not accept negative permutation entries.' + details: self requestedContext ] ]. ^ self ] diff --git a/src/MCP/MCPMonitoringState.class.st b/src/MCP/MCPMonitoringState.class.st index 142efd3..bcc37d7 100644 --- a/src/MCP/MCPMonitoringState.class.st +++ b/src/MCP/MCPMonitoringState.class.st @@ -73,24 +73,25 @@ MCPMonitoringState >> approximateOutputTokensForBytes: byteCount [ MCPMonitoringState >> captureTraceSnapshotsFor: aRecord result: aToolResult error: anError [ [ - [ - aRecord isTraceWorthy - ifTrue: [ - aRecord inputSnapshot: (self traceSnapshotFor: aRecord inputObject). - aRecord outputSnapshot: - (self traceSnapshotForResult: aToolResult error: anError) ] - ifFalse: [ - aRecord inputSnapshot: nil. - aRecord outputSnapshot: nil ] ] - on: Error - do: [ :snapshotError | - aRecord inputSnapshot: nil. - aRecord outputSnapshot: (self traceSnapshotFor: { - (#errorClass -> snapshotError class name asString). - (#message - -> - (snapshotError messageText ifNil: [ snapshotError asString ])). - (#during -> 'trace snapshot creation') } asDictionary) ] ] + [ + aRecord isTraceWorthy + ifTrue: [ + aRecord inputSnapshot: + (self traceSnapshotFor: aRecord inputObject). + aRecord outputSnapshot: + (self traceSnapshotForResult: aToolResult error: anError) ] + ifFalse: [ + aRecord inputSnapshot: nil. + aRecord outputSnapshot: nil ] ] + on: Error + do: [ :snapshotError | + aRecord inputSnapshot: nil. + aRecord outputSnapshot: (self traceSnapshotFor: { + (#errorClass -> snapshotError class name asString). + (#message + -> + (snapshotError messageText ifNil: [ snapshotError asString ])). + (#during -> 'trace snapshot creation') } asDictionary) ] ] ensure: [ aRecord inputObject: nil ] ] @@ -165,8 +166,8 @@ MCPMonitoringState >> ensureLogger [ logger ifNil: [ logger := TinyLogger new ]. memoryLogger ifNil: [ - memoryLogger := MCPMemoryTinyLogger new. - logger addLogger: memoryLogger ]. + memoryLogger := MCPMemoryTinyLogger new. + logger addLogger: memoryLogger ]. ^ logger ] @@ -475,13 +476,13 @@ MCPMonitoringState >> outlierExplanationForDurationMilliseconds: duration stats: ratio := duration / average. ratio < self outlierFactor ifTrue: [ ^ '' ]. ^ String streamContents: [ :stream | - stream - print: duration; - nextPutAll: ' ms is '; - nextPutAll: (ratio asFloat printShowingDecimalPlaces: 1); - nextPutAll: 'x the prior average of '; - nextPutAll: (average asFloat printShowingDecimalPlaces: 1); - nextPutAll: ' ms' ] + stream + print: duration; + nextPutAll: ' ms is '; + nextPutAll: (ratio asFloat printShowingDecimalPlaces: 1); + nextPutAll: 'x the prior average of '; + nextPutAll: (average asFloat printShowingDecimalPlaces: 1); + nextPutAll: ' ms' ] ] { #category : 'accessing' } diff --git a/src/MCP/MCPMoveClassCommand.class.st b/src/MCP/MCPMoveClassCommand.class.st index 1a7a57b..4ffc060 100644 --- a/src/MCP/MCPMoveClassCommand.class.st +++ b/src/MCP/MCPMoveClassCommand.class.st @@ -5,9 +5,8 @@ When only a tag is supplied, it recategorizes the class inside its current packa " Class { #name : 'MCPMoveClassCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'packageName', 'tag' ], @@ -26,18 +25,6 @@ MCPMoveClassCommand class >> className: aClassName packageName: aPackageName tag yourself ] -{ #category : 'accessing' } -MCPMoveClassCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPMoveClassCommand >> className: aString [ - - className := aString -] - { #category : 'private' } MCPMoveClassCommand >> destinationValidation [ @@ -85,14 +72,14 @@ MCPMoveClassCommand >> performMove [ self tag ifNil: [ - (RBMoveClassTransformation - move: self className - toPackage: self packageName) execute ] + (RBMoveClassTransformation + move: self className + toPackage: self packageName) execute ] ifNotNil: [ - (RBMoveClassTransformation - move: self className - toPackage: self packageName - inTag: self tag) execute ] + (RBMoveClassTransformation + move: self className + toPackage: self packageName + inTag: self tag) execute ] ] { #category : 'accessing' } diff --git a/src/MCP/MCPMoveClassResult.class.st b/src/MCP/MCPMoveClassResult.class.st index 0ca991f..6cb8f7b 100644 --- a/src/MCP/MCPMoveClassResult.class.st +++ b/src/MCP/MCPMoveClassResult.class.st @@ -5,7 +5,7 @@ It carries the updated class info plus the previous package and tag. " Class { #name : 'MCPMoveClassResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldPackageName', @@ -30,7 +30,7 @@ MCPMoveClassResult class >> classInfo: aClassInfo oldPackageName: anOldPackageNa MCPMoveClassResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldPackageName put: self oldPackageName. data at: #oldTag put: self oldTag. ^ data diff --git a/src/MCP/MCPMoveSlotCommand.class.st b/src/MCP/MCPMoveSlotCommand.class.st index f6009fb..525d133 100644 --- a/src/MCP/MCPMoveSlotCommand.class.st +++ b/src/MCP/MCPMoveSlotCommand.class.st @@ -5,12 +5,9 @@ It performs pull-up or push-down refactorings for instance-side or class-side sl " Class { #name : 'MCPMoveSlotCommand', - #superclass : 'Object', + #superclass : 'MCPClassSlotCommand', #instVars : [ - 'className', - 'slotName', - 'direction', - 'classSide' + 'direction' ], #category : 'MCP-Commands', #package : 'MCP', @@ -49,36 +46,6 @@ MCPMoveSlotCommand >> affectedClassNamesFor: aBehavior [ as: Array) sort: [ :left :right | left <= right ] ] -{ #category : 'accessing' } -MCPMoveSlotCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPMoveSlotCommand >> className: aClassName [ - - className := aClassName -] - -{ #category : 'accessing' } -MCPMoveSlotCommand >> classSide [ - - ^ classSide -] - -{ #category : 'accessing' } -MCPMoveSlotCommand >> classSide: aBoolean [ - - classSide := aBoolean -] - -{ #category : 'private' } -MCPMoveSlotCommand >> currentClass [ - - ^ MCPImageLookup classNamed: self className -] - { #category : 'accessing' } MCPMoveSlotCommand >> direction [ @@ -123,36 +90,16 @@ MCPMoveSlotCommand >> normalizedAffectedClassNameFor: aBehavior [ ifFalse: [ aBehavior name ]) asString ] -{ #category : 'private' } -MCPMoveSlotCommand >> refactoringBehaviorForClass: aClass [ - - ^ self classSide - ifTrue: [ aClass classSide ] - ifFalse: [ aClass ] -] - { #category : 'private' } MCPMoveSlotCommand >> refactoringForBehavior: aBehavior [ ^ (self direction = 'pullUpSlot' ifTrue: [ RePullUpInstanceVariableRefactoring ] ifFalse: [ - self direction = 'pushDownSlot' - ifTrue: [ RBPushDownInstanceVariableRefactoring ] - ifFalse: [ - Error signal: 'direction must be pullUpSlot or pushDownSlot.' ] ]) + self direction = 'pushDownSlot' + ifTrue: [ RBPushDownInstanceVariableRefactoring ] + ifFalse: [ + Error signal: 'direction must be pullUpSlot or pushDownSlot.' ] ]) variable: self slotName class: aBehavior ] - -{ #category : 'accessing' } -MCPMoveSlotCommand >> slotName [ - - ^ slotName -] - -{ #category : 'accessing' } -MCPMoveSlotCommand >> slotName: aSlotName [ - - slotName := aSlotName -] diff --git a/src/MCP/MCPMoveSlotResult.class.st b/src/MCP/MCPMoveSlotResult.class.st index 3987dde..9967c9b 100644 --- a/src/MCP/MCPMoveSlotResult.class.st +++ b/src/MCP/MCPMoveSlotResult.class.st @@ -5,7 +5,7 @@ It includes updated class info, the moved slot identity, side, and affected clas " Class { #name : 'MCPMoveSlotResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'slotName', @@ -44,7 +44,7 @@ MCPMoveSlotResult >> affectedClassNames: someClassNames [ MCPMoveSlotResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #slotName put: self slotName. data at: #classSide put: self classSide. data at: #affectedClassNames put: self affectedClassNames. diff --git a/src/MCP/MCPPackageInfo.class.st b/src/MCP/MCPPackageInfo.class.st index beff83c..62e404f 100644 --- a/src/MCP/MCPPackageInfo.class.st +++ b/src/MCP/MCPPackageInfo.class.st @@ -5,7 +5,7 @@ It records package name, project names, tag names, class and extension method co " Class { #name : 'MCPPackageInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'packageName', 'projectNames', diff --git a/src/MCP/MCPPackageScopeQuery.class.st b/src/MCP/MCPPackageScopeQuery.class.st index 3077c8f..3d5e075 100644 --- a/src/MCP/MCPPackageScopeQuery.class.st +++ b/src/MCP/MCPPackageScopeQuery.class.st @@ -49,13 +49,13 @@ MCPPackageScopeQuery >> packageProjectNamesMap [ | packageProjects | packageProjects := Dictionary new. self projectRegistrations do: [ :eachProject | - | projectName | - projectName := eachProject projectName asString. - (self packagesForProjectRegistration: eachProject) do: [ - :eachPackage | - (packageProjects - at: eachPackage name asString - ifAbsentPut: [ OrderedCollection new ]) add: projectName ] ]. + | projectName | + projectName := eachProject projectName asString. + (self packagesForProjectRegistration: eachProject) do: [ + :eachPackage | + (packageProjects + at: eachPackage name asString + ifAbsentPut: [ OrderedCollection new ]) add: projectName ] ]. packageProjects valuesDo: [ :eachProjectNames | eachProjectNames sort ]. ^ packageProjects @@ -125,9 +125,9 @@ MCPPackageScopeQuery >> projectNames: someProjectNames [ MCPPackageScopeQuery >> projectRegistrations [ ^ MetacelloProjectRegistration registry registrations select: [ :each | - [ each loadedInImage ] - on: Error - do: [ :error | false ] ] + [ each loadedInImage ] + on: Error + do: [ :error | false ] ] ] { #category : 'private - querying' } @@ -153,9 +153,9 @@ MCPPackageScopeQuery >> resolvedProjectsNamed: someProjectNames [ projectsByName := self projectsByName. projects := OrderedCollection new. someProjectNames do: [ :eachName | - projects add: (projectsByName - at: eachName - ifAbsent: [ MCPCommandError signalMissingProjectNamed: eachName ]) ]. + projects add: (projectsByName + at: eachName + ifAbsent: [ MCPCommandError signalMissingProjectNamed: eachName ]) ]. ^ projects asArray ] diff --git a/src/MCP/MCPPaginationResult.class.st b/src/MCP/MCPPaginationResult.class.st index 9df1739..90b7414 100644 --- a/src/MCP/MCPPaginationResult.class.st +++ b/src/MCP/MCPPaginationResult.class.st @@ -3,7 +3,7 @@ Compact pagination result shared by list and search tools. It keeps MCP payloads " Class { #name : 'MCPPaginationResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'entries', 'nextOffset' @@ -39,6 +39,12 @@ MCPPaginationResult class >> fromEntries: entryCollection limit: limit offset: o offset + pageEntries size ]) ] +{ #category : 'converting' } +MCPPaginationResult >> asDictionary [ + + ^ self asDictionaryWithEntriesKey: #entries +] + { #category : 'converting' } MCPPaginationResult >> asDictionaryWithEntriesKey: entriesKey [ diff --git a/src/MCP/MCPPullRepositoryCommand.class.st b/src/MCP/MCPPullRepositoryCommand.class.st index e0e010d..cd14c31 100644 --- a/src/MCP/MCPPullRepositoryCommand.class.st +++ b/src/MCP/MCPPullRepositoryCommand.class.st @@ -3,64 +3,32 @@ Command wrapper for repository_pull. It calls IceRepository>>pull and returns an " Class { #name : 'MCPPullRepositoryCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPPullRepositoryCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPPullRepositoryCommand >> execute [ | beforeInfo repository result | - ^ self tool - executeMutationAction: 'pull' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'pull' work: [ - repository := self request repository. - beforeInfo := MCPRepositoryInfo fromRepository: repository. - repository pull. - result := MCPRepositoryPullResult - repositoryBefore: beforeInfo - after: repository ] + repository := self request repository. + beforeInfo := MCPRepositoryInfo fromRepository: repository. + repository pull. + result := MCPRepositoryPullResult + repositoryBefore: beforeInfo + after: repository ] successResult: [ :warningMessages | - self tool - successResultText: - 'Pulled repository ' , result repositoryInfo name , '.' - data: (self tool dataForRepositoryPullResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Pulled repository ' , result repositoryInfo name , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to pull repository: ' - , (error messageText ifNil: [ error asString ]) ] -] - -{ #category : 'initialization' } -MCPPullRepositoryCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPPullRepositoryCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPPullRepositoryCommand >> tool [ - - ^ tool + 'Failed to pull repository: ' + , (error messageText ifNil: [ error asString ]) ] ] diff --git a/src/MCP/MCPPushRepositoryCommand.class.st b/src/MCP/MCPPushRepositoryCommand.class.st index f1ef918..a53cf5a 100644 --- a/src/MCP/MCPPushRepositoryCommand.class.st +++ b/src/MCP/MCPPushRepositoryCommand.class.st @@ -3,61 +3,29 @@ Command wrapper for repository_push. It calls IceRepository>>push and returns an " Class { #name : 'MCPPushRepositoryCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPPushRepositoryCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPPushRepositoryCommand >> execute [ | repository result | - ^ self tool - executeMutationAction: 'push' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'push' work: [ - repository := self request repository. - repository push. - result := MCPRepositoryPushResult repository: repository ] + repository := self request repository. + repository push. + result := MCPRepositoryPushResult repository: repository ] successResult: [ :warningMessages | - self tool - successResultText: - 'Pushed repository ' , result repositoryInfo name , '.' - data: (self tool dataForRepositoryPushResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Pushed repository ' , result repositoryInfo name , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to push repository: ' - , (error messageText ifNil: [ error asString ]) ] -] - -{ #category : 'initialization' } -MCPPushRepositoryCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPPushRepositoryCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPPushRepositoryCommand >> tool [ - - ^ tool + 'Failed to push repository: ' + , (error messageText ifNil: [ error asString ]) ] ] diff --git a/src/MCP/MCPRemoveClassResult.class.st b/src/MCP/MCPRemoveClassResult.class.st index afab311..45d685d 100644 --- a/src/MCP/MCPRemoveClassResult.class.st +++ b/src/MCP/MCPRemoveClassResult.class.st @@ -5,7 +5,7 @@ It records the removed class metadata and whether subclasses were reparented. " Class { #name : 'MCPRemoveClassResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'wasEmpty', @@ -32,7 +32,7 @@ MCPRemoveClassResult class >> classInfo: aClassInfo wasEmpty: aBoolean reparente MCPRemoveClassResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #wasEmpty put: self wasEmpty. data at: #reparentedToSuperclassName diff --git a/src/MCP/MCPRemoveClassesCommand.class.st b/src/MCP/MCPRemoveClassesCommand.class.st index 6e032ef..26f5fbd 100644 --- a/src/MCP/MCPRemoveClassesCommand.class.st +++ b/src/MCP/MCPRemoveClassesCommand.class.st @@ -5,7 +5,7 @@ It gathers removal warnings, removes now-empty packages when applicable, and ret " Class { #name : 'MCPRemoveClassesCommand', - #superclass : 'Object', + #superclass : 'MCPCommand', #instVars : [ 'classNames', 'force' @@ -56,9 +56,9 @@ MCPRemoveClassesCommand >> execute [ self performRemovalWithPreparedRefactoring: refactoring. removedPackageNames := OrderedCollection new. removedClasses do: [ :eachResult | - self - removePackageIfNowEmptyNamed: eachResult classInfo packageName - recordingInto: removedPackageNames ]. + self + removePackageIfNowEmptyNamed: eachResult classInfo packageName + recordingInto: removedPackageNames ]. ^ MCPRemoveClassesResult removedClasses: removedClasses removedPackageNames: removedPackageNames @@ -108,10 +108,10 @@ MCPRemoveClassesCommand >> removePackageIfNowEmptyNamed: aPackageName recordingI PackageOrganizer default packageNamed: aPackageName ifPresent: [ :package | - package definedClasses isEmpty ifTrue: [ - PackageOrganizer default removePackage: package. - (removedPackageNamesCollection includes: aPackageName) ifFalse: [ - removedPackageNamesCollection add: aPackageName ] ] ] + package definedClasses isEmpty ifTrue: [ + PackageOrganizer default removePackage: package. + (removedPackageNamesCollection includes: aPackageName) ifFalse: [ + removedPackageNamesCollection add: aPackageName ] ] ] ] { #category : 'private' } @@ -156,11 +156,11 @@ MCPRemoveClassesCommand >> validatePreparedRefactoring: aRefactoring [ warningMessages := OrderedCollection new. self force ifTrue: [ - [ aRefactoring checkPreconditions ] - on: RBRefactoringWarning - do: [ :warning | - warningMessages add: warning messageText. - warning resume: true ] ] + [ aRefactoring checkPreconditions ] + on: RBRefactoringWarning + do: [ :warning | + warningMessages add: warning messageText. + warning resume: true ] ] ifFalse: [ aRefactoring checkPreconditions ]. ^ warningMessages asArray ] diff --git a/src/MCP/MCPRemoveClassesResult.class.st b/src/MCP/MCPRemoveClassesResult.class.st index 850c63b..1bb6f71 100644 --- a/src/MCP/MCPRemoveClassesResult.class.st +++ b/src/MCP/MCPRemoveClassesResult.class.st @@ -5,7 +5,7 @@ It groups per-class removal results, package names removed as cleanup, and warni " Class { #name : 'MCPRemoveClassesResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'removedClasses', 'removedPackageNames', @@ -43,9 +43,10 @@ MCPRemoveClassesResult >> asDictionary [ self removedPackageNames ifNotEmpty: [ data at: #removedPackageNames put: self removedPackageNames asArray ]. reparentedSubclassNames := Array streamContents: [ :stream | - self removedClasses do: [ :each | - each reparentedSubclassNames do: [ :subclassName | - stream nextPut: subclassName ] ] ]. + self removedClasses do: [ :each | + each reparentedSubclassNames do: [ + :subclassName | + stream nextPut: subclassName ] ] ]. reparentedSubclassNames ifNotEmpty: [ data at: #reparentedSubclassNames put: reparentedSubclassNames ]. ^ data diff --git a/src/MCP/MCPRemoveMethodsCommand.class.st b/src/MCP/MCPRemoveMethodsCommand.class.st index bf4663c..cb2baab 100644 --- a/src/MCP/MCPRemoveMethodsCommand.class.st +++ b/src/MCP/MCPRemoveMethodsCommand.class.st @@ -3,22 +3,12 @@ Command that removes methods and returns removed method DTO dictionaries. " Class { #name : 'MCPRemoveMethodsCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPRemoveMethodsCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPRemoveMethodsCommand >> execute [ @@ -26,39 +16,17 @@ MCPRemoveMethodsCommand >> execute [ selectorSymbols := self request selectors collect: #asSymbol. warningMessage := 'This bypasses sender checks and may leave broken senders.'. behavior := self tool - behaviorNamed: self request className - classSide: self request classSide. + behaviorNamed: self request className + classSide: self request classSide. selectorSymbols do: [ :selector | - behavior - compiledMethodAt: selector - ifAbsent: [ - MCPCommandError - signalMissingMethodInClassName: self request className - classSide: self request classSide - selector: selector asString ] ]. + behavior compiledMethodAt: selector ifAbsent: [ + MCPCommandError + signalMissingMethodInClassName: self request className + classSide: self request classSide + selector: selector asString ] ]. self tool forceRemoveSelectors: selectorSymbols from: behavior. ^ MCPRemoveMethodsResult - fromRequest: self request - removedMethods: #( ) - warningMessages: { warningMessage } -] - -{ #category : 'initialization' } -MCPRemoveMethodsCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPRemoveMethodsCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPRemoveMethodsCommand >> tool [ - - ^ tool + fromRequest: self request + removedMethods: #( ) + warningMessages: { warningMessage } ] diff --git a/src/MCP/MCPRemoveMethodsResult.class.st b/src/MCP/MCPRemoveMethodsResult.class.st index beb26e1..792387c 100644 --- a/src/MCP/MCPRemoveMethodsResult.class.st +++ b/src/MCP/MCPRemoveMethodsResult.class.st @@ -3,7 +3,7 @@ Result DTO produced by the method_remove command. " Class { #name : 'MCPRemoveMethodsResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'className', 'classSide', diff --git a/src/MCP/MCPRemoveSlotCommand.class.st b/src/MCP/MCPRemoveSlotCommand.class.st index ec89df5..3267886 100644 --- a/src/MCP/MCPRemoveSlotCommand.class.st +++ b/src/MCP/MCPRemoveSlotCommand.class.st @@ -3,12 +3,7 @@ Removes a slot from a class or metaclass through the refactoring engine. " Class { #name : 'MCPRemoveSlotCommand', - #superclass : 'Object', - #instVars : [ - 'className', - 'slotName', - 'classSide' - ], + #superclass : 'MCPClassSlotCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' @@ -24,36 +19,6 @@ MCPRemoveSlotCommand class >> className: aClassName slotName: aSlotName classSid yourself ] -{ #category : 'accessing' } -MCPRemoveSlotCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPRemoveSlotCommand >> className: aClassName [ - - className := aClassName -] - -{ #category : 'accessing' } -MCPRemoveSlotCommand >> classSide [ - - ^ classSide -] - -{ #category : 'accessing' } -MCPRemoveSlotCommand >> classSide: aBoolean [ - - classSide := aBoolean -] - -{ #category : 'private' } -MCPRemoveSlotCommand >> currentClass [ - - ^ MCPImageLookup classNamed: self className -] - { #category : 'private' } MCPRemoveSlotCommand >> directlyDefinesSlotNamed: aSlotName inBehavior: aBehavior [ @@ -86,14 +51,6 @@ MCPRemoveSlotCommand >> normalizedBehaviorNameFor: aBehavior [ ifFalse: [ aBehavior name ]) asString ] -{ #category : 'private' } -MCPRemoveSlotCommand >> refactoringBehaviorForClass: aClass [ - - ^ self classSide - ifTrue: [ aClass classSide ] - ifFalse: [ aClass ] -] - { #category : 'private' } MCPRemoveSlotCommand >> refactoringForBehavior: aBehavior [ @@ -107,10 +64,10 @@ MCPRemoveSlotCommand >> removeClassSideSlotFromBehavior: aBehavior [ (self directlyDefinesSlotNamed: self slotName inBehavior: aBehavior) ifFalse: [ - RBApplicabilityChecksFailedError signal: - 'The variable ' , self slotName - , ' is not directly defined in the class ' - , (self normalizedBehaviorNameFor: aBehavior) ]. + RBApplicabilityChecksFailedError signal: + 'The variable ' , self slotName + , ' is not directly defined in the class ' + , (self normalizedBehaviorNameFor: aBehavior) ]. self signalReferenceWarningIfNeededForBehavior: aBehavior. aBehavior removeInstVarNamed: self slotName ] @@ -122,18 +79,6 @@ MCPRemoveSlotCommand >> signalReferenceWarningIfNeededForBehavior: aBehavior [ hasReferences := aBehavior withAllSubclasses anySatisfy: [ :each | (each whichMethodsAccess: self slotName) isNotEmpty ]. hasReferences ifTrue: [ - RBBreakingChangeChecksFailedWarning signal: - ' Variable ' , self slotName , ' is still referenced' ] -] - -{ #category : 'accessing' } -MCPRemoveSlotCommand >> slotName [ - - ^ slotName -] - -{ #category : 'accessing' } -MCPRemoveSlotCommand >> slotName: aSlotName [ - - slotName := aSlotName + RBBreakingChangeChecksFailedWarning signal: + ' Variable ' , self slotName , ' is still referenced' ] ] diff --git a/src/MCP/MCPRenameClassCommand.class.st b/src/MCP/MCPRenameClassCommand.class.st index 7582be7..207bbd0 100644 --- a/src/MCP/MCPRenameClassCommand.class.st +++ b/src/MCP/MCPRenameClassCommand.class.st @@ -5,9 +5,8 @@ It preserves the old class name for reporting and returns the renamed class meta " Class { #name : 'MCPRenameClassCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'newClassName', 'model' ], @@ -35,18 +34,6 @@ MCPRenameClassCommand class >> className: aClassName newClassName: aNewClassName yourself ] -{ #category : 'accessing' } -MCPRenameClassCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPRenameClassCommand >> className: aString [ - - className := aString -] - { #category : 'executing' } MCPRenameClassCommand >> execute [ @@ -93,8 +80,8 @@ MCPRenameClassCommand >> refactoring [ rename: self className to: self newClassName ] ifNotNil: [ - ReRenameClassRefactoring - model: self model - rename: self className - to: self newClassName ] + ReRenameClassRefactoring + model: self model + rename: self className + to: self newClassName ] ] diff --git a/src/MCP/MCPRenameClassResult.class.st b/src/MCP/MCPRenameClassResult.class.st index fdc4cc9..45383ae 100644 --- a/src/MCP/MCPRenameClassResult.class.st +++ b/src/MCP/MCPRenameClassResult.class.st @@ -5,7 +5,7 @@ It carries the updated class info and both old and new class names. " Class { #name : 'MCPRenameClassResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldClassName', @@ -30,7 +30,7 @@ MCPRenameClassResult class >> classInfo: aClassInfo oldClassName: anOldClassName MCPRenameClassResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldClassName put: self oldClassName. data at: #newClassName put: self newClassName. ^ data diff --git a/src/MCP/MCPRenameSlotCommand.class.st b/src/MCP/MCPRenameSlotCommand.class.st index 775e4b7..9be9b56 100644 --- a/src/MCP/MCPRenameSlotCommand.class.st +++ b/src/MCP/MCPRenameSlotCommand.class.st @@ -3,12 +3,9 @@ Renames a slot on a class. Instance-side renames use the refactoring engine. Cla " Class { #name : 'MCPRenameSlotCommand', - #superclass : 'Object', + #superclass : 'MCPClassSlotCommand', #instVars : [ - 'className', - 'slotName', - 'newSlotName', - 'classSide' + 'newSlotName' ], #category : 'MCP-Commands', #package : 'MCP', @@ -26,30 +23,6 @@ MCPRenameSlotCommand class >> className: aClassName slotName: aSlotName newSlotN yourself ] -{ #category : 'accessing' } -MCPRenameSlotCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPRenameSlotCommand >> className: aClassName [ - - className := aClassName -] - -{ #category : 'accessing' } -MCPRenameSlotCommand >> classSide [ - - ^ classSide -] - -{ #category : 'accessing' } -MCPRenameSlotCommand >> classSide: aBoolean [ - - classSide := aBoolean -] - { #category : 'private' } MCPRenameSlotCommand >> classSideAccessorMessageRewriter [ @@ -85,18 +58,12 @@ MCPRenameSlotCommand >> classSideSlotValuesForBehavior: aBehavior [ ^ #( ) ]. values := OrderedCollection new. aBehavior withAllSubclasses do: [ :eachBehavior | - eachBehavior allInstances do: [ :eachObject | - values add: - eachObject -> (eachObject instVarNamed: self slotName asString) ] ]. + eachBehavior allInstances do: [ :eachObject | + values add: + eachObject -> (eachObject instVarNamed: self slotName asString) ] ]. ^ values asArray ] -{ #category : 'private' } -MCPRenameSlotCommand >> currentClass [ - - ^ MCPImageLookup classNamed: self className -] - { #category : 'executing' } MCPRenameSlotCommand >> execute [ @@ -104,12 +71,13 @@ MCPRenameSlotCommand >> execute [ currentClass := self currentClass. updatedClass := self classSide ifTrue: [ - self renameClassSideSlotInBehavior: - currentClass classSide. - Smalltalk globals at: self className asSymbol ] + self renameClassSideSlotInBehavior: + currentClass classSide. + Smalltalk globals at: self className asSymbol ] ifFalse: [ - self renameInstanceSideSlotInBehavior: currentClass. - Smalltalk globals at: self className asSymbol ]. + self renameInstanceSideSlotInBehavior: + currentClass. + Smalltalk globals at: self className asSymbol ]. ^ MCPRenameSlotResult classInfo: (MCPClassInfo fromClass: updatedClass) oldSlotName: self slotName @@ -153,9 +121,9 @@ MCPRenameSlotCommand >> instanceSideSlotValuesForBehavior: aBehavior [ ^ #( ) ]. values := OrderedCollection new. aBehavior withAllSubclasses do: [ :eachBehavior | - eachBehavior allInstances do: [ :eachObject | - values add: - eachObject -> (eachObject instVarNamed: self slotName asString) ] ]. + eachBehavior allInstances do: [ :eachObject | + values add: + eachObject -> (eachObject instVarNamed: self slotName asString) ] ]. ^ values asArray ] @@ -302,11 +270,11 @@ MCPRenameSlotCommand >> rewriteClassSideReferencesForSelector: aSelector inBehav MCPRenameSlotCommand >> rewriteClassSideReferencesInBehavior: aBehavior [ aBehavior withAllSubclasses do: [ :eachBehavior | - (self classSideReferenceSelectorsInBehavior: eachBehavior) do: [ - :eachSelector | - self - rewriteClassSideReferencesForSelector: eachSelector - inBehavior: eachBehavior ] ] + (self classSideReferenceSelectorsInBehavior: eachBehavior) do: [ + :eachSelector | + self + rewriteClassSideReferencesForSelector: eachSelector + inBehavior: eachBehavior ] ] ] { #category : 'private' } @@ -335,11 +303,11 @@ MCPRenameSlotCommand >> rewriteInstanceSideReferencesForSelector: aSelector inBe MCPRenameSlotCommand >> rewriteInstanceSideReferencesInBehavior: aBehavior [ aBehavior withAllSubclasses do: [ :eachBehavior | - (self instanceSideReferenceSelectorsInBehavior: eachBehavior) do: [ - :eachSelector | - self - rewriteInstanceSideReferencesForSelector: eachSelector - inBehavior: eachBehavior ] ] + (self instanceSideReferenceSelectorsInBehavior: eachBehavior) do: [ + :eachSelector | + self + rewriteInstanceSideReferencesForSelector: eachSelector + inBehavior: eachBehavior ] ] ] { #category : 'private' } @@ -349,18 +317,6 @@ MCPRenameSlotCommand >> setterSourceForNewSlot [ , self newSlotName , ' := anObject' ] -{ #category : 'accessing' } -MCPRenameSlotCommand >> slotName [ - - ^ slotName -] - -{ #category : 'accessing' } -MCPRenameSlotCommand >> slotName: aSlotName [ - - slotName := aSlotName -] - { #category : 'private' } MCPRenameSlotCommand >> slotNamed: aSlotName isDefinedIn: aBehavior [ @@ -372,34 +328,34 @@ MCPRenameSlotCommand >> slotNamed: aSlotName isDefinedIn: aBehavior [ MCPRenameSlotCommand >> validateClassSideSlotRenameInBehavior: aBehavior [ (self slotNamed: self slotName isDefinedIn: aBehavior) ifFalse: [ - RBApplicabilityChecksFailedError signal: - 'The variable ' , self slotName - , ' is not directly defined in the class ' - , (self normalizedBehaviorNameFor: aBehavior) ]. + RBApplicabilityChecksFailedError signal: + 'The variable ' , self slotName + , ' is not directly defined in the class ' + , (self normalizedBehaviorNameFor: aBehavior) ]. (self hierarchyDefinesSlotNamed: self newSlotName inBehavior: aBehavior) ifTrue: [ - RBApplicabilityChecksFailedError signal: - self newSlotName , ' is already defined in the class ' - , (self normalizedBehaviorNameFor: aBehavior) - , ' or its hierarchy.' ] + RBApplicabilityChecksFailedError signal: + self newSlotName , ' is already defined in the class ' + , (self normalizedBehaviorNameFor: aBehavior) + , ' or its hierarchy.' ] ] { #category : 'private' } MCPRenameSlotCommand >> validateInstanceSideSlotRenameInBehavior: aBehavior [ (self slotNamed: self slotName isDefinedIn: aBehavior) ifFalse: [ - RBApplicabilityChecksFailedError signal: - 'The variable ' , self slotName - , ' is not directly defined in the class ' - , (self normalizedBehaviorNameFor: aBehavior) ]. + RBApplicabilityChecksFailedError signal: + 'The variable ' , self slotName + , ' is not directly defined in the class ' + , (self normalizedBehaviorNameFor: aBehavior) ]. (self hierarchyDefinesSlotNamed: self newSlotName inBehavior: aBehavior) ifTrue: [ - RBApplicabilityChecksFailedError signal: - self newSlotName , ' is already defined in the class ' - , (self normalizedBehaviorNameFor: aBehavior) - , ' or its hierarchy.' ] + RBApplicabilityChecksFailedError signal: + self newSlotName , ' is already defined in the class ' + , (self normalizedBehaviorNameFor: aBehavior) + , ' or its hierarchy.' ] ] { #category : 'private' } @@ -409,8 +365,8 @@ MCPRenameSlotCommand >> variableReferenceRewriterForSelector: aSelector [ rename: self slotName to: self newSlotName handler: [ - RBRefactoringError signal: self newSlotName - , - ' is already defined as a method or block temporary variable while rewriting ' - , aSelector asString ] + RBRefactoringError signal: self newSlotName + , + ' is already defined as a method or block temporary variable while rewriting ' + , aSelector asString ] ] diff --git a/src/MCP/MCPRenameSlotResult.class.st b/src/MCP/MCPRenameSlotResult.class.st index 8ef6e1a..49eb8f6 100644 --- a/src/MCP/MCPRenameSlotResult.class.st +++ b/src/MCP/MCPRenameSlotResult.class.st @@ -3,7 +3,7 @@ Captures the updated class state after renaming a slot. " Class { #name : 'MCPRenameSlotResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldSlotName', @@ -30,7 +30,7 @@ MCPRenameSlotResult class >> classInfo: aClassInfo oldSlotName: anOldSlotName ne MCPRenameSlotResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldSlotName put: self oldSlotName. data at: #newSlotName put: self newSlotName. data at: #classSide put: self classSide. diff --git a/src/MCP/MCPReparentClassCommand.class.st b/src/MCP/MCPReparentClassCommand.class.st index a6d26ff..be36008 100644 --- a/src/MCP/MCPReparentClassCommand.class.st +++ b/src/MCP/MCPReparentClassCommand.class.st @@ -5,9 +5,8 @@ It records the previous superclass and returns MCPReparentClassResult with updat " Class { #name : 'MCPReparentClassCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'superclassName' ], #category : 'MCP-Commands', @@ -36,24 +35,6 @@ MCPReparentClassCommand >> builderForReparenting: aClass toSuperclass: aSupercla ^ builder ] -{ #category : 'accessing' } -MCPReparentClassCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPReparentClassCommand >> className: aString [ - - className := aString -] - -{ #category : 'private' } -MCPReparentClassCommand >> currentClass [ - - ^ MCPImageLookup classNamed: self className -] - { #category : 'executing' } MCPReparentClassCommand >> execute [ @@ -64,9 +45,9 @@ MCPReparentClassCommand >> execute [ ifNotNil: [ :aSuperclass | aSuperclass name asString ]. currentSuperclassName = self superclassName ifTrue: [ - ^ MCPReparentClassResult - classInfo: (MCPClassInfo fromClass: currentClass) - oldSuperclassName: currentSuperclassName ]. + ^ MCPReparentClassResult + classInfo: (MCPClassInfo fromClass: currentClass) + oldSuperclassName: currentSuperclassName ]. superclass := self newSuperclass. (self builderForReparenting: currentClass toSuperclass: superclass) install. @@ -80,9 +61,9 @@ MCPReparentClassCommand >> execute [ MCPReparentClassCommand >> newSuperclass [ ^ Smalltalk globals at: self superclassName asSymbol ifAbsent: [ - MCPCommandError - signalMissingSuperclassNamed: self superclassName - forClassNamed: self className ] + MCPCommandError + signalMissingSuperclassNamed: self superclassName + forClassNamed: self className ] ] { #category : 'accessing' } diff --git a/src/MCP/MCPReparentClassResult.class.st b/src/MCP/MCPReparentClassResult.class.st index 28c1740..a3e0e90 100644 --- a/src/MCP/MCPReparentClassResult.class.st +++ b/src/MCP/MCPReparentClassResult.class.st @@ -5,7 +5,7 @@ It carries the updated class info and the old superclass name. " Class { #name : 'MCPReparentClassResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldSuperclassName' @@ -28,7 +28,7 @@ MCPReparentClassResult class >> classInfo: aClassInfo oldSuperclassName: anOldSu MCPReparentClassResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldSuperclassName put: self oldSuperclassName. ^ data ] diff --git a/src/MCP/MCPReplaceClassDefinitionCommand.class.st b/src/MCP/MCPReplaceClassDefinitionCommand.class.st index 190ee2f..b7cfb95 100644 --- a/src/MCP/MCPReplaceClassDefinitionCommand.class.st +++ b/src/MCP/MCPReplaceClassDefinitionCommand.class.st @@ -3,9 +3,8 @@ Replaces the slot shape of an existing class using the Shift class installer. Om " Class { #name : 'MCPReplaceClassDefinitionCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'slotNames', 'classSlotNames', 'replaceSlots', @@ -16,18 +15,6 @@ Class { #tag : 'Commands' } -{ #category : 'accessing' } -MCPReplaceClassDefinitionCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPReplaceClassDefinitionCommand >> className: aClassName [ - - className := aClassName -] - { #category : 'accessing' } MCPReplaceClassDefinitionCommand >> classSlotNames [ @@ -97,9 +84,9 @@ MCPReplaceClassDefinitionCommand >> replaceClassSlots: aBoolean [ MCPReplaceClassDefinitionCommand >> replaceDefinitionOn: aClass [ ^ ShiftClassInstaller update: aClass to: [ :builder | - self replaceSlots ifTrue: [ builder slots: self slots ]. - self replaceClassSlots ifTrue: [ - builder classSlots: self classSlots ] ] + self replaceSlots ifTrue: [ builder slots: self slots ]. + self replaceClassSlots ifTrue: [ + builder classSlots: self classSlots ] ] ] { #category : 'accessing' } diff --git a/src/MCP/MCPReplaceClassDefinitionResult.class.st b/src/MCP/MCPReplaceClassDefinitionResult.class.st index 9712f8b..860488b 100644 --- a/src/MCP/MCPReplaceClassDefinitionResult.class.st +++ b/src/MCP/MCPReplaceClassDefinitionResult.class.st @@ -5,7 +5,7 @@ It carries the class state after replacement and the old/new instance-side and c " Class { #name : 'MCPReplaceClassDefinitionResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldInstanceSlotNames', @@ -30,7 +30,7 @@ MCPReplaceClassDefinitionResult class >> classInfo: aClassInfo [ MCPReplaceClassDefinitionResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldInstanceSlotNames put: self oldInstanceSlotNames. data at: #newInstanceSlotNames put: self newInstanceSlotNames. data at: #oldClassSlotNames put: self oldClassSlotNames. diff --git a/src/MCP/MCPReplaceClassLayoutCommand.class.st b/src/MCP/MCPReplaceClassLayoutCommand.class.st index 712cfe8..d47f951 100644 --- a/src/MCP/MCPReplaceClassLayoutCommand.class.st +++ b/src/MCP/MCPReplaceClassLayoutCommand.class.st @@ -3,9 +3,8 @@ Replaces the layout of an existing class using the Shift class installer and ret " Class { #name : 'MCPReplaceClassLayoutCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'layout' ], #category : 'MCP-Commands', @@ -22,18 +21,6 @@ MCPReplaceClassLayoutCommand class >> className: aClassName layout: aLayoutName yourself ] -{ #category : 'accessing' } -MCPReplaceClassLayoutCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPReplaceClassLayoutCommand >> className: aString [ - - className := aString -] - { #category : 'executing' } MCPReplaceClassLayoutCommand >> execute [ @@ -68,32 +55,8 @@ MCPReplaceClassLayoutCommand >> layoutClassNameFromClass: aClass [ { #category : 'private' } MCPReplaceClassLayoutCommand >> replaceLayoutOn: aClass [ - ^ ShiftClassInstaller - update: aClass - to: [ :builder | builder layout: self resolvedLayoutClass ] -] - -{ #category : 'private' } -MCPReplaceClassLayoutCommand >> resolvedLayoutClass [ - - | behavior | - self layout ifNil: [ ^ nil ]. - behavior := Smalltalk globals at: self layout asSymbol ifAbsent: [ - MCPCommandError - signalErrorCode: #LayoutClassNotFound - message: - 'Layout class ' , self layout , ' does not exist.' - details: { - (#className -> self className). - (#layout -> self layout) } asDictionary ]. - (AbstractLayout withAllSubclasses includes: behavior) ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidLayoutClass - message: self layout , ' is not a layout class.' - details: { - (#className -> self className). - (#layout -> self layout) } asDictionary ]. - ^ behavior + ^ ShiftClassInstaller update: aClass to: [ :builder | + builder layout: (self resolvedLayoutClassNamed: self layout) ] ] { #category : 'private' } diff --git a/src/MCP/MCPReplaceClassLayoutResult.class.st b/src/MCP/MCPReplaceClassLayoutResult.class.st index 3db286a..2068f26 100644 --- a/src/MCP/MCPReplaceClassLayoutResult.class.st +++ b/src/MCP/MCPReplaceClassLayoutResult.class.st @@ -5,7 +5,7 @@ It carries the class state after replacement and the old/new layout class names " Class { #name : 'MCPReplaceClassLayoutResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldLayoutClassName', @@ -30,7 +30,7 @@ MCPReplaceClassLayoutResult class >> classInfo: aClassInfo oldLayoutClassName: o MCPReplaceClassLayoutResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldLayoutClassName put: self oldLayoutClassName. data at: #newLayoutClassName put: self newLayoutClassName. ^ data diff --git a/src/MCP/MCPReplaceClassSharedPoolsCommand.class.st b/src/MCP/MCPReplaceClassSharedPoolsCommand.class.st index ef53c92..c2bc7d2 100644 --- a/src/MCP/MCPReplaceClassSharedPoolsCommand.class.st +++ b/src/MCP/MCPReplaceClassSharedPoolsCommand.class.st @@ -3,9 +3,8 @@ Replaces the shared pools of an existing class using the Shift class installer a " Class { #name : 'MCPReplaceClassSharedPoolsCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'sharedPoolNames' ], #category : 'MCP-Commands', @@ -22,18 +21,6 @@ MCPReplaceClassSharedPoolsCommand class >> className: aClassName sharedPoolNames yourself ] -{ #category : 'accessing' } -MCPReplaceClassSharedPoolsCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPReplaceClassSharedPoolsCommand >> className: aString [ - - className := aString -] - { #category : 'executing' } MCPReplaceClassSharedPoolsCommand >> execute [ @@ -55,31 +42,6 @@ MCPReplaceClassSharedPoolsCommand >> replaceSharedPoolsOn: aClass [ to: [ :builder | builder sharedPools: self resolvedSharedPools ] ] -{ #category : 'private' } -MCPReplaceClassSharedPoolsCommand >> resolvedSharedPoolNamed: aSharedPoolName [ - - | behavior sharedPoolName | - sharedPoolName := aSharedPoolName. - behavior := Smalltalk globals - at: sharedPoolName asSymbol - ifAbsent: [ - MCPCommandError - signalErrorCode: #SharedPoolNotFound - message: - 'Shared pool ' , sharedPoolName , ' does not exist.' - details: { - (#className -> self className). - (#sharedPoolName -> sharedPoolName) } asDictionary ]. - (SharedPool withAllSubclasses includes: behavior) ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidSharedPool - message: sharedPoolName , ' is not a shared pool.' - details: { - (#className -> self className). - (#sharedPoolName -> sharedPoolName) } asDictionary ]. - ^ behavior -] - { #category : 'private' } MCPReplaceClassSharedPoolsCommand >> resolvedSharedPools [ diff --git a/src/MCP/MCPReplaceClassSharedPoolsResult.class.st b/src/MCP/MCPReplaceClassSharedPoolsResult.class.st index e868c76..0adb339 100644 --- a/src/MCP/MCPReplaceClassSharedPoolsResult.class.st +++ b/src/MCP/MCPReplaceClassSharedPoolsResult.class.st @@ -5,7 +5,7 @@ It carries the class state after replacement and the old/new shared pool name li " Class { #name : 'MCPReplaceClassSharedPoolsResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldSharedPoolNames', @@ -30,7 +30,7 @@ MCPReplaceClassSharedPoolsResult class >> classInfo: aClassInfo oldSharedPoolNam MCPReplaceClassSharedPoolsResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldSharedPoolNames put: self oldSharedPoolNames. data at: #newSharedPoolNames put: self newSharedPoolNames. ^ data diff --git a/src/MCP/MCPReplaceClassSharedVariablesCommand.class.st b/src/MCP/MCPReplaceClassSharedVariablesCommand.class.st index ed281b9..6a10141 100644 --- a/src/MCP/MCPReplaceClassSharedVariablesCommand.class.st +++ b/src/MCP/MCPReplaceClassSharedVariablesCommand.class.st @@ -3,9 +3,8 @@ Replaces the class variables of an existing class using the Shift class installe " Class { #name : 'MCPReplaceClassSharedVariablesCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'sharedVariableNames' ], #category : 'MCP-Commands', @@ -22,18 +21,6 @@ MCPReplaceClassSharedVariablesCommand class >> className: aClassName sharedVaria yourself ] -{ #category : 'accessing' } -MCPReplaceClassSharedVariablesCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPReplaceClassSharedVariablesCommand >> className: aString [ - - className := aString -] - { #category : 'executing' } MCPReplaceClassSharedVariablesCommand >> execute [ diff --git a/src/MCP/MCPReplaceClassSharedVariablesResult.class.st b/src/MCP/MCPReplaceClassSharedVariablesResult.class.st index 98bce3a..c2256c7 100644 --- a/src/MCP/MCPReplaceClassSharedVariablesResult.class.st +++ b/src/MCP/MCPReplaceClassSharedVariablesResult.class.st @@ -5,7 +5,7 @@ It carries the class state after replacement and the old/new shared variable nam " Class { #name : 'MCPReplaceClassSharedVariablesResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldSharedVariableNames', @@ -30,7 +30,7 @@ MCPReplaceClassSharedVariablesResult class >> classInfo: aClassInfo oldSharedVar MCPReplaceClassSharedVariablesResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldSharedVariableNames put: self oldSharedVariableNames. data at: #newSharedVariableNames put: self newSharedVariableNames. ^ data diff --git a/src/MCP/MCPReplaceClassSideTraitsCommand.class.st b/src/MCP/MCPReplaceClassSideTraitsCommand.class.st index dde8e4a..546dd3c 100644 --- a/src/MCP/MCPReplaceClassSideTraitsCommand.class.st +++ b/src/MCP/MCPReplaceClassSideTraitsCommand.class.st @@ -3,9 +3,8 @@ Replaces the class-side traits of an existing class and returns a DTO describing " Class { #name : 'MCPReplaceClassSideTraitsCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'classTraitNames' ], #category : 'MCP-Commands', @@ -22,18 +21,6 @@ MCPReplaceClassSideTraitsCommand class >> className: aClassName classTraitNames: yourself ] -{ #category : 'accessing' } -MCPReplaceClassSideTraitsCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPReplaceClassSideTraitsCommand >> className: aString [ - - className := aString -] - { #category : 'accessing' } MCPReplaceClassSideTraitsCommand >> classTraitNames [ @@ -89,23 +76,23 @@ MCPReplaceClassSideTraitsCommand >> resolvedClassTraitNamed: aClassTraitName [ behavior := Smalltalk globals at: classTraitName asSymbol ifAbsent: [ - MCPCommandError - signalErrorCode: #ClassTraitNotFound - message: - 'Class trait ' , originalName , ' does not exist.' - details: { - (#className -> self className). - (#classTraitName -> originalName). - (#classTraits -> self classTraitNames) } - asDictionary ]. + MCPCommandError + signalErrorCode: #ClassTraitNotFound + message: + 'Class trait ' , originalName , ' does not exist.' + details: { + (#className -> self className). + (#classTraitName -> originalName). + (#classTraits -> self classTraitNames) } + asDictionary ]. behavior isTrait ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidClassTrait - message: originalName , ' is not a class trait.' - details: { - (#className -> self className). - (#classTraitName -> originalName). - (#classTraits -> self classTraitNames) } asDictionary ]. + MCPCommandError + signalErrorCode: #InvalidClassTrait + message: originalName , ' is not a class trait.' + details: { + (#className -> self className). + (#classTraitName -> originalName). + (#classTraits -> self classTraitNames) } asDictionary ]. ^ behavior classTrait ] diff --git a/src/MCP/MCPReplaceClassSideTraitsResult.class.st b/src/MCP/MCPReplaceClassSideTraitsResult.class.st index 0c76890..2e1c3a7 100644 --- a/src/MCP/MCPReplaceClassSideTraitsResult.class.st +++ b/src/MCP/MCPReplaceClassSideTraitsResult.class.st @@ -5,7 +5,7 @@ It carries the class state after replacement and the old/new class-side trait na " Class { #name : 'MCPReplaceClassSideTraitsResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldClassTraitNames', @@ -30,7 +30,7 @@ MCPReplaceClassSideTraitsResult class >> classInfo: aClassInfo oldClassTraitName MCPReplaceClassSideTraitsResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldClassTraitNames put: self oldClassTraitNames. data at: #newClassTraitNames put: self newClassTraitNames. ^ data diff --git a/src/MCP/MCPReplaceClassTraitsCommand.class.st b/src/MCP/MCPReplaceClassTraitsCommand.class.st index 3feef81..8f18507 100644 --- a/src/MCP/MCPReplaceClassTraitsCommand.class.st +++ b/src/MCP/MCPReplaceClassTraitsCommand.class.st @@ -3,9 +3,8 @@ Replaces the instance-side trait composition of an existing class and returns a " Class { #name : 'MCPReplaceClassTraitsCommand', - #superclass : 'Object', + #superclass : 'MCPClassCommand', #instVars : [ - 'className', 'traitNames' ], #category : 'MCP-Commands', @@ -22,18 +21,6 @@ MCPReplaceClassTraitsCommand class >> className: aClassName traitNames: someTrai yourself ] -{ #category : 'accessing' } -MCPReplaceClassTraitsCommand >> className [ - - ^ className -] - -{ #category : 'accessing' } -MCPReplaceClassTraitsCommand >> className: aString [ - - className := aString -] - { #category : 'executing' } MCPReplaceClassTraitsCommand >> execute [ @@ -53,25 +40,25 @@ MCPReplaceClassTraitsCommand >> resolvedTraitNamed: aTraitName [ | behavior traitName | traitName := aTraitName. (traitName endsWith: ' classTrait') ifTrue: [ - traitName := traitName - copyFrom: 1 - to: traitName size - ' classTrait' size ]. + traitName := traitName + copyFrom: 1 + to: traitName size - ' classTrait' size ]. behavior := Smalltalk globals at: traitName asSymbol ifAbsent: [ - MCPCommandError - signalErrorCode: #TraitNotFound - message: 'Trait ' , traitName , ' does not exist.' - details: { - (#className -> self className). - (#traitName -> traitName). - (#traits -> self traitNames) } asDictionary ]. + MCPCommandError + signalErrorCode: #TraitNotFound + message: 'Trait ' , traitName , ' does not exist.' + details: { + (#className -> self className). + (#traitName -> traitName). + (#traits -> self traitNames) } asDictionary ]. behavior isTrait ifFalse: [ - MCPCommandError - signalErrorCode: #InvalidTrait - message: traitName , ' is not a trait.' - details: { - (#className -> self className). - (#traitName -> traitName). - (#traits -> self traitNames) } asDictionary ]. + MCPCommandError + signalErrorCode: #InvalidTrait + message: traitName , ' is not a trait.' + details: { + (#className -> self className). + (#traitName -> traitName). + (#traits -> self traitNames) } asDictionary ]. ^ behavior ] diff --git a/src/MCP/MCPReplaceClassTraitsResult.class.st b/src/MCP/MCPReplaceClassTraitsResult.class.st index e99ddd9..f57263f 100644 --- a/src/MCP/MCPReplaceClassTraitsResult.class.st +++ b/src/MCP/MCPReplaceClassTraitsResult.class.st @@ -5,7 +5,7 @@ It carries the class state after replacement and the old/new trait name lists fo " Class { #name : 'MCPReplaceClassTraitsResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'oldTraitNames', @@ -30,7 +30,7 @@ MCPReplaceClassTraitsResult class >> classInfo: aClassInfo oldTraitNames: oldNam MCPReplaceClassTraitsResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #oldTraitNames put: self oldTraitNames. data at: #newTraitNames put: self newTraitNames. ^ data diff --git a/src/MCP/MCPRepositoryAdoptHeadRequest.class.st b/src/MCP/MCPRepositoryAdoptHeadRequest.class.st index 350ed59..de03f88 100644 --- a/src/MCP/MCPRepositoryAdoptHeadRequest.class.st +++ b/src/MCP/MCPRepositoryAdoptHeadRequest.class.st @@ -3,11 +3,7 @@ Parsed input for repository_head_adopt. It resolves the registered Iceberg repos " Class { #name : 'MCPRepositoryAdoptHeadRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference', - 'branchName' - ], + #superclass : 'MCPRepositoryBranchRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -19,27 +15,12 @@ MCPRepositoryAdoptHeadRequest class >> fromRequest: request tool: aTool [ ^ self new initializeFromRequest: request ] -{ #category : 'accessing' } -MCPRepositoryAdoptHeadRequest >> branchName [ - - ^ branchName ifNil: [ '' ] -] - { #category : 'converting' } MCPRepositoryAdoptHeadRequest >> commandForTool: aTool [ ^ MCPAdoptRepositoryHeadCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositoryAdoptHeadRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - branchName := request stringArgumentNamed: 'branchName'. - ^ self -] - { #category : 'accessing' } MCPRepositoryAdoptHeadRequest >> operation [ @@ -52,12 +33,6 @@ MCPRepositoryAdoptHeadRequest >> repository [ ^ self repositoryReference repository ] -{ #category : 'accessing' } -MCPRepositoryAdoptHeadRequest >> repositoryReference [ - - ^ repositoryReference -] - { #category : 'converting' } MCPRepositoryAdoptHeadRequest >> requestedContext [ diff --git a/src/MCP/MCPRepositoryAdoptHeadResult.class.st b/src/MCP/MCPRepositoryAdoptHeadResult.class.st index 98bda0d..2f97950 100644 --- a/src/MCP/MCPRepositoryAdoptHeadResult.class.st +++ b/src/MCP/MCPRepositoryAdoptHeadResult.class.st @@ -3,11 +3,8 @@ Result DTO returned by repository_head_adopt. It reports repository metadata bef " Class { #name : 'MCPRepositoryAdoptHeadResult', - #superclass : 'Object', + #superclass : 'MCPRepositoryTransitionResult', #instVars : [ - 'repositoryInfoBefore', - 'repositoryInfoAfter', - 'packageInfos', 'modifiedPackageNamesBefore', 'modifiedPackageNamesAfter', 'previousReferenceCommitId', @@ -88,9 +85,7 @@ MCPRepositoryAdoptHeadResult >> headDescription [ { #category : 'initialization' } MCPRepositoryAdoptHeadResult >> initializeRepositoryBefore: beforeInfo after: aRepository previousReferenceCommit: previousCommit adoptedCommit: headCommit didAdopt: aBoolean [ - repositoryInfoBefore := beforeInfo. - repositoryInfoAfter := MCPRepositoryInfo fromRepository: aRepository. - packageInfos := self packageInfosFromRepository: aRepository. + super initializeRepositoryBefore: beforeInfo after: aRepository. modifiedPackageNamesBefore := beforeInfo modifiedPackageNames. modifiedPackageNamesAfter := repositoryInfoAfter modifiedPackageNames. previousReferenceCommitId := self commitIdFrom: previousCommit. @@ -98,8 +93,7 @@ MCPRepositoryAdoptHeadResult >> initializeRepositoryBefore: beforeInfo after: aR adoptedCommitId := self commitIdFrom: headCommit. didAdopt := aBoolean. branchName := repositoryInfoAfter branchName. - headDescription := repositoryInfoAfter headDescription. - ^ self + headDescription := repositoryInfoAfter headDescription ] { #category : 'accessing' } @@ -114,23 +108,6 @@ MCPRepositoryAdoptHeadResult >> modifiedPackageNamesBefore [ ^ modifiedPackageNamesBefore ifNil: [ #( ) ] ] -{ #category : 'accessing' } -MCPRepositoryAdoptHeadResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'private' } -MCPRepositoryAdoptHeadResult >> packageInfosFromRepository: aRepository [ - - | packages | - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - ^ packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ] -] - { #category : 'accessing' } MCPRepositoryAdoptHeadResult >> previousReferenceCommitId [ @@ -148,21 +125,3 @@ MCPRepositoryAdoptHeadResult >> referenceCommitIdForRepository: aRepository [ ^ self commitIdFrom: aRepository workingCopy referenceCommit ] - -{ #category : 'accessing' } -MCPRepositoryAdoptHeadResult >> repositoryInfo [ - - ^ self repositoryInfoAfter -] - -{ #category : 'accessing' } -MCPRepositoryAdoptHeadResult >> repositoryInfoAfter [ - - ^ repositoryInfoAfter -] - -{ #category : 'accessing' } -MCPRepositoryAdoptHeadResult >> repositoryInfoBefore [ - - ^ repositoryInfoBefore -] diff --git a/src/MCP/MCPRepositoryBranchRequest.class.st b/src/MCP/MCPRepositoryBranchRequest.class.st new file mode 100644 index 0000000..e8e9d66 --- /dev/null +++ b/src/MCP/MCPRepositoryBranchRequest.class.st @@ -0,0 +1,41 @@ +" +Abstract request DTO for repository operations that target an existing repository and branch. +" +Class { + #name : 'MCPRepositoryBranchRequest', + #superclass : 'MCPRepositoryRequest', + #instVars : [ + 'branchName' + ], + #category : 'MCP-Requests', + #package : 'MCP', + #tag : 'Requests' +} + +{ #category : 'testing' } +MCPRepositoryBranchRequest class >> isAbstract [ + + ^ self == MCPRepositoryBranchRequest +] + +{ #category : 'accessing' } +MCPRepositoryBranchRequest >> branchName [ + + ^ branchName ifNil: [ '' ] +] + +{ #category : 'initialization' } +MCPRepositoryBranchRequest >> initializeFromRequest: request [ + + super initializeFromRequest: request. + branchName := request stringArgumentNamed: 'branchName' +] + +{ #category : 'converting' } +MCPRepositoryBranchRequest >> requestedContext [ + + | context | + context := self repositoryReference requestedContext copy. + context at: #branchName put: self branchName. + ^ context +] diff --git a/src/MCP/MCPRepositoryBranchResult.class.st b/src/MCP/MCPRepositoryBranchResult.class.st index 34404c7..d46334d 100644 --- a/src/MCP/MCPRepositoryBranchResult.class.st +++ b/src/MCP/MCPRepositoryBranchResult.class.st @@ -3,11 +3,8 @@ Result DTO returned by repository branch tools. It reports repository metadata b " Class { #name : 'MCPRepositoryBranchResult', - #superclass : 'Object', + #superclass : 'MCPRepositoryTransitionResult', #instVars : [ - 'repositoryInfoBefore', - 'repositoryInfoAfter', - 'packageInfos', 'previousBranchName', 'branchName', 'previousHeadDescription', @@ -54,33 +51,11 @@ MCPRepositoryBranchResult >> headDescription [ { #category : 'initialization' } MCPRepositoryBranchResult >> initializeRepositoryBefore: beforeInfo after: aRepository [ - | afterInfo | - repositoryInfoBefore := beforeInfo. - afterInfo := MCPRepositoryInfo fromRepository: aRepository. - repositoryInfoAfter := afterInfo. - packageInfos := self packageInfosFromRepository: aRepository. + super initializeRepositoryBefore: beforeInfo after: aRepository. previousBranchName := beforeInfo branchName. - branchName := afterInfo branchName. + branchName := repositoryInfoAfter branchName. previousHeadDescription := beforeInfo headDescription. - headDescription := afterInfo headDescription. - ^ self -] - -{ #category : 'accessing' } -MCPRepositoryBranchResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'private' } -MCPRepositoryBranchResult >> packageInfosFromRepository: aRepository [ - - | packages | - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - ^ packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ] + headDescription := repositoryInfoAfter headDescription ] { #category : 'accessing' } @@ -94,21 +69,3 @@ MCPRepositoryBranchResult >> previousHeadDescription [ ^ previousHeadDescription ifNil: [ '' ] ] - -{ #category : 'accessing' } -MCPRepositoryBranchResult >> repositoryInfo [ - - ^ self repositoryInfoAfter -] - -{ #category : 'accessing' } -MCPRepositoryBranchResult >> repositoryInfoAfter [ - - ^ repositoryInfoAfter -] - -{ #category : 'accessing' } -MCPRepositoryBranchResult >> repositoryInfoBefore [ - - ^ repositoryInfoBefore -] diff --git a/src/MCP/MCPRepositoryCheckoutBranchRequest.class.st b/src/MCP/MCPRepositoryCheckoutBranchRequest.class.st index 2ca8598..a2d9f9b 100644 --- a/src/MCP/MCPRepositoryCheckoutBranchRequest.class.st +++ b/src/MCP/MCPRepositoryCheckoutBranchRequest.class.st @@ -3,11 +3,7 @@ Parsed input for repository_branch_checkout. It resolves the registered Iceberg " Class { #name : 'MCPRepositoryCheckoutBranchRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference', - 'branchName' - ], + #superclass : 'MCPRepositoryBranchRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -19,26 +15,12 @@ MCPRepositoryCheckoutBranchRequest class >> fromRequest: request tool: aTool [ ^ self new initializeFromRequest: request ] -{ #category : 'accessing' } -MCPRepositoryCheckoutBranchRequest >> branchName [ - - ^ branchName -] - { #category : 'converting' } MCPRepositoryCheckoutBranchRequest >> commandForTool: aTool [ ^ MCPCheckoutRepositoryBranchCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositoryCheckoutBranchRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - branchName := request stringArgumentNamed: 'branchName' -] - { #category : 'accessing' } MCPRepositoryCheckoutBranchRequest >> operation [ @@ -50,18 +32,3 @@ MCPRepositoryCheckoutBranchRequest >> repository [ ^ self repositoryReference repository ] - -{ #category : 'accessing' } -MCPRepositoryCheckoutBranchRequest >> repositoryReference [ - - ^ repositoryReference -] - -{ #category : 'converting' } -MCPRepositoryCheckoutBranchRequest >> requestedContext [ - - | context | - context := self repositoryReference requestedContext copy. - context at: #branchName put: self branchName. - ^ context -] diff --git a/src/MCP/MCPRepositoryCommand.class.st b/src/MCP/MCPRepositoryCommand.class.st new file mode 100644 index 0000000..792d82c --- /dev/null +++ b/src/MCP/MCPRepositoryCommand.class.st @@ -0,0 +1,34 @@ +" +Abstract base for repository command objects. It owns the shared tool/request state and construction protocol used by repository tools; subclasses implement the repository operation itself. +" +Class { + #name : 'MCPRepositoryCommand', + #superclass : 'MCPToolRequestCommand', + #category : 'MCP-Commands', + #package : 'MCP', + #tag : 'Commands' +} + +{ #category : 'testing' } +MCPRepositoryCommand class >> isAbstract [ + + ^ self = MCPRepositoryCommand +] + +{ #category : 'private - execution' } +MCPRepositoryCommand >> executeRepositoryAction: actionName work: workBlock successResult: successBlock failureSummary: failureBlock [ + + ^ self tool + executeMutationAction: actionName + force: false + requestedContext: self request requestedContext + work: workBlock + successResult: successBlock + failureSummary: failureBlock +] + +{ #category : 'private' } +MCPRepositoryCommand >> sortedStringsFrom: aCollection [ + + ^ (aCollection collect: [ :each | each asString ]) asSet asArray sort +] diff --git a/src/MCP/MCPRepositoryCommitRequest.class.st b/src/MCP/MCPRepositoryCommitRequest.class.st index 7d523e3..9c4bd3b 100644 --- a/src/MCP/MCPRepositoryCommitRequest.class.st +++ b/src/MCP/MCPRepositoryCommitRequest.class.st @@ -3,9 +3,8 @@ Parsed input for repository_commit. It resolves the registered Iceberg repositor " Class { #name : 'MCPRepositoryCommitRequest', - #superclass : 'Object', + #superclass : 'MCPRepositoryRequest', #instVars : [ - 'repositoryReference', 'message' ], #category : 'MCP-Requests', @@ -28,10 +27,8 @@ MCPRepositoryCommitRequest >> commandForTool: aTool [ { #category : 'initialization' } MCPRepositoryCommitRequest >> initializeFromRequest: request [ - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - message := request stringArgumentNamed: 'message'. - ^ self + super initializeFromRequest: request. + message := request stringArgumentNamed: 'message' ] { #category : 'accessing' } @@ -52,12 +49,6 @@ MCPRepositoryCommitRequest >> repository [ ^ self repositoryReference repository ] -{ #category : 'accessing' } -MCPRepositoryCommitRequest >> repositoryReference [ - - ^ repositoryReference -] - { #category : 'converting' } MCPRepositoryCommitRequest >> requestedContext [ diff --git a/src/MCP/MCPRepositoryCommitResult.class.st b/src/MCP/MCPRepositoryCommitResult.class.st index 44ade46..6dc4f65 100644 --- a/src/MCP/MCPRepositoryCommitResult.class.st +++ b/src/MCP/MCPRepositoryCommitResult.class.st @@ -3,10 +3,8 @@ Result DTO returned by repository_commit. It reports repository state after the " Class { #name : 'MCPRepositoryCommitResult', - #superclass : 'Object', + #superclass : 'MCPRepositorySnapshotResult', #instVars : [ - 'repositoryInfo', - 'packageInfos', 'changedPackageNames', 'modifiedPackageNames', 'commitId', @@ -107,14 +105,9 @@ MCPRepositoryCommitResult >> headDescription: aString [ { #category : 'initialization' } MCPRepositoryCommitResult >> initializeRepository: aRepository changedPackageNames: packageNames commit: aCommit [ - | packages repositoryPackageNames | - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - packageInfos := packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ]. - repositoryPackageNames := (packages collect: [ :each | - each name asString ]) asArray. + | repositoryPackageNames | + packageInfos := self packageInfosFromRepository: aRepository. + repositoryPackageNames := packageInfos collect: [ :each | each name ]. changedPackageNames := packageNames ifNil: [ #( ) ]. modifiedPackageNames := #( ). commitId := self commitIdFrom: aCommit. @@ -125,8 +118,7 @@ MCPRepositoryCommitResult >> initializeRepository: aRepository changedPackageNam packageNames: repositoryPackageNames modifiedPackageNames: modifiedPackageNames headCommitId: commitId - headDescription: headDescription. - ^ self + headDescription: headDescription ] { #category : 'accessing' } @@ -140,27 +132,3 @@ MCPRepositoryCommitResult >> modifiedPackageNames: aCollection [ modifiedPackageNames := aCollection ifNil: [ #( ) ] ] - -{ #category : 'accessing' } -MCPRepositoryCommitResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryCommitResult >> packageInfos: aCollection [ - - packageInfos := aCollection ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryCommitResult >> repositoryInfo [ - - ^ repositoryInfo -] - -{ #category : 'accessing' } -MCPRepositoryCommitResult >> repositoryInfo: aRepositoryInfo [ - - repositoryInfo := aRepositoryInfo -] diff --git a/src/MCP/MCPRepositoryCreateBranchRequest.class.st b/src/MCP/MCPRepositoryCreateBranchRequest.class.st index 29632f8..328520d 100644 --- a/src/MCP/MCPRepositoryCreateBranchRequest.class.st +++ b/src/MCP/MCPRepositoryCreateBranchRequest.class.st @@ -3,11 +3,7 @@ Parsed input for repository_branch_create. It resolves the registered Iceberg re " Class { #name : 'MCPRepositoryCreateBranchRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference', - 'branchName' - ], + #superclass : 'MCPRepositoryBranchRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -19,27 +15,12 @@ MCPRepositoryCreateBranchRequest class >> fromRequest: request tool: aTool [ ^ self new initializeFromRequest: request ] -{ #category : 'accessing' } -MCPRepositoryCreateBranchRequest >> branchName [ - - ^ branchName ifNil: [ '' ] -] - { #category : 'converting' } MCPRepositoryCreateBranchRequest >> commandForTool: aTool [ ^ MCPCreateRepositoryBranchCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositoryCreateBranchRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - branchName := request stringArgumentNamed: 'branchName'. - ^ self -] - { #category : 'accessing' } MCPRepositoryCreateBranchRequest >> operation [ @@ -51,18 +32,3 @@ MCPRepositoryCreateBranchRequest >> repository [ ^ self repositoryReference repository ] - -{ #category : 'accessing' } -MCPRepositoryCreateBranchRequest >> repositoryReference [ - - ^ repositoryReference -] - -{ #category : 'converting' } -MCPRepositoryCreateBranchRequest >> requestedContext [ - - | context | - context := self repositoryReference requestedContext copy. - context at: #branchName put: self branchName. - ^ context -] diff --git a/src/MCP/MCPRepositoryCreateResult.class.st b/src/MCP/MCPRepositoryCreateResult.class.st index 7742643..b30eed8 100644 --- a/src/MCP/MCPRepositoryCreateResult.class.st +++ b/src/MCP/MCPRepositoryCreateResult.class.st @@ -3,11 +3,7 @@ Result DTO returned by repository_create or repository_attach. It reports the re " Class { #name : 'MCPRepositoryCreateResult', - #superclass : 'Object', - #instVars : [ - 'repositoryInfo', - 'packageInfos' - ], + #superclass : 'MCPRepositorySnapshotResult', #category : 'MCP-Results', #package : 'MCP', #tag : 'Results' @@ -24,40 +20,3 @@ MCPRepositoryCreateResult >> asDictionary [ ^ Dictionary new ] - -{ #category : 'initialization' } -MCPRepositoryCreateResult >> initializeFromRepository: aRepository [ - - | packages | - repositoryInfo := MCPRepositoryInfo fromRepository: aRepository. - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - packageInfos := packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ]. - ^ self -] - -{ #category : 'accessing' } -MCPRepositoryCreateResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryCreateResult >> packageInfos: aCollection [ - - packageInfos := aCollection ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryCreateResult >> repositoryInfo [ - - ^ repositoryInfo -] - -{ #category : 'accessing' } -MCPRepositoryCreateResult >> repositoryInfo: aRepositoryInfo [ - - repositoryInfo := aRepositoryInfo -] diff --git a/src/MCP/MCPRepositoryDiffCommand.class.st b/src/MCP/MCPRepositoryDiffCommand.class.st index bd49120..0b51cc1 100644 --- a/src/MCP/MCPRepositoryDiffCommand.class.st +++ b/src/MCP/MCPRepositoryDiffCommand.class.st @@ -13,28 +13,26 @@ Class { MCPRepositoryDiffCommand >> execute [ | changedPackageNames diff modifiedPaths repository result | - ^ self tool - executeMutationAction: 'diff' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'diff' work: [ - repository := self request repository. - diff := repository workingCopyDiff. - changedPackageNames := self changedPackageNamesFromDiff: diff. - modifiedPaths := self modifiedPathsFromDiff: diff. - result := MCPRepositoryDiffResult - repository: repository - changedPackageNames: changedPackageNames - modifiedPaths: modifiedPaths - isEmpty: diff isEmpty ] + repository := self request repository. + diff := repository workingCopyDiff. + changedPackageNames := self changedPackageNamesFromDiff: diff. + modifiedPaths := self modifiedPathsFromDiff: diff. + result := MCPRepositoryDiffResult + repository: repository + changedPackageNames: changedPackageNames + modifiedPaths: modifiedPaths + isEmpty: diff isEmpty ] successResult: [ :warningMessages | - self tool - successResultText: - 'Computed repository diff for ' , result repositoryInfo name - , '.' - data: (self tool dataForRepositoryDiffResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Computed repository diff for ' , result repositoryInfo name + , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to compute repository diff: ' - , (error messageText ifNil: [ error asString ]) ] + 'Failed repository diff: ' + , (error messageText ifNil: [ error asString ]) ] ] diff --git a/src/MCP/MCPRepositoryDiffRequest.class.st b/src/MCP/MCPRepositoryDiffRequest.class.st index b456fd7..9467b36 100644 --- a/src/MCP/MCPRepositoryDiffRequest.class.st +++ b/src/MCP/MCPRepositoryDiffRequest.class.st @@ -3,10 +3,7 @@ Parsed input for repository_change_list. It resolves the registered Iceberg repo " Class { #name : 'MCPRepositoryDiffRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference' - ], + #superclass : 'MCPRepositoryRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -24,14 +21,6 @@ MCPRepositoryDiffRequest >> commandForTool: aTool [ ^ MCPRepositoryDiffCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositoryDiffRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - ^ self -] - { #category : 'accessing' } MCPRepositoryDiffRequest >> operation [ @@ -43,15 +32,3 @@ MCPRepositoryDiffRequest >> repository [ ^ self repositoryReference repository ] - -{ #category : 'accessing' } -MCPRepositoryDiffRequest >> repositoryReference [ - - ^ repositoryReference -] - -{ #category : 'converting' } -MCPRepositoryDiffRequest >> requestedContext [ - - ^ self repositoryReference requestedContext -] diff --git a/src/MCP/MCPRepositoryDiffResult.class.st b/src/MCP/MCPRepositoryDiffResult.class.st index 7cc95e2..f62bc69 100644 --- a/src/MCP/MCPRepositoryDiffResult.class.st +++ b/src/MCP/MCPRepositoryDiffResult.class.st @@ -3,10 +3,8 @@ Result DTO returned by repository_change_list. It reports the repository working " Class { #name : 'MCPRepositoryDiffResult', - #superclass : 'Object', + #superclass : 'MCPRepositorySnapshotResult', #instVars : [ - 'repositoryInfo', - 'packageInfos', 'changedPackageNames', 'modifiedPaths', 'changeCount', @@ -76,18 +74,11 @@ MCPRepositoryDiffResult >> derivedChangeCount [ { #category : 'initialization' } MCPRepositoryDiffResult >> initializeRepository: aRepository changedPackageNames: packageNames modifiedPaths: paths isEmpty: aBoolean [ - | packages | - repositoryInfo := MCPRepositoryInfo fromRepository: aRepository. - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - packageInfos := packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ]. + self initializeSnapshotFromRepository: aRepository. changedPackageNames := packageNames ifNil: [ #( ) ]. modifiedPaths := paths ifNil: [ #( ) ]. isEmpty := aBoolean. - changeCount := self derivedChangeCount. - ^ self + changeCount := self derivedChangeCount ] { #category : 'accessing' } @@ -113,27 +104,3 @@ MCPRepositoryDiffResult >> modifiedPaths: aCollection [ modifiedPaths := aCollection ifNil: [ #( ) ] ] - -{ #category : 'accessing' } -MCPRepositoryDiffResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryDiffResult >> packageInfos: aCollection [ - - packageInfos := aCollection ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryDiffResult >> repositoryInfo [ - - ^ repositoryInfo -] - -{ #category : 'accessing' } -MCPRepositoryDiffResult >> repositoryInfo: aRepositoryInfo [ - - repositoryInfo := aRepositoryInfo -] diff --git a/src/MCP/MCPRepositoryExportRequest.class.st b/src/MCP/MCPRepositoryExportRequest.class.st index 7bf0470..e9fe0de 100644 --- a/src/MCP/MCPRepositoryExportRequest.class.st +++ b/src/MCP/MCPRepositoryExportRequest.class.st @@ -3,10 +3,7 @@ Parsed input for repository_export. It resolves the registered Iceberg repositor " Class { #name : 'MCPRepositoryExportRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference' - ], + #superclass : 'MCPRepositoryRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -24,14 +21,6 @@ MCPRepositoryExportRequest >> commandForTool: aTool [ ^ MCPExportRepositoryCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositoryExportRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - ^ self -] - { #category : 'accessing' } MCPRepositoryExportRequest >> operation [ @@ -43,15 +32,3 @@ MCPRepositoryExportRequest >> repository [ ^ self repositoryReference repository ] - -{ #category : 'accessing' } -MCPRepositoryExportRequest >> repositoryReference [ - - ^ repositoryReference -] - -{ #category : 'converting' } -MCPRepositoryExportRequest >> requestedContext [ - - ^ self repositoryReference requestedContext -] diff --git a/src/MCP/MCPRepositoryExportResult.class.st b/src/MCP/MCPRepositoryExportResult.class.st index 55cbd6c..c2c6bac 100644 --- a/src/MCP/MCPRepositoryExportResult.class.st +++ b/src/MCP/MCPRepositoryExportResult.class.st @@ -3,10 +3,8 @@ Result DTO returned by repository_export. It reports the repository synchronized " Class { #name : 'MCPRepositoryExportResult', - #superclass : 'Object', + #superclass : 'MCPRepositorySnapshotResult', #instVars : [ - 'repositoryInfo', - 'packageInfos', 'changedPackageNames', 'modifiedPaths', 'didChange', @@ -68,18 +66,11 @@ MCPRepositoryExportResult >> didChange: aBoolean [ { #category : 'initialization' } MCPRepositoryExportResult >> initializeRepository: aRepository changedPackageNames: packageNames modifiedPaths: paths [ - | packages | - repositoryInfo := MCPRepositoryInfo fromRepository: aRepository. - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - packageInfos := packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ]. + self initializeSnapshotFromRepository: aRepository. changedPackageNames := packageNames ifNil: [ #( ) ]. modifiedPaths := paths ifNil: [ #( ) ]. didChange := changedPackageNames notEmpty or: [ - modifiedPaths notEmpty ]. - ^ self + modifiedPaths notEmpty ] ] { #category : 'accessing' } @@ -94,30 +85,6 @@ MCPRepositoryExportResult >> modifiedPaths: aCollection [ modifiedPaths := aCollection ifNil: [ #( ) ] ] -{ #category : 'accessing' } -MCPRepositoryExportResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryExportResult >> packageInfos: aCollection [ - - packageInfos := aCollection ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryExportResult >> repositoryInfo [ - - ^ repositoryInfo -] - -{ #category : 'accessing' } -MCPRepositoryExportResult >> repositoryInfo: aRepositoryInfo [ - - repositoryInfo := aRepositoryInfo -] - { #category : 'accessing' } MCPRepositoryExportResult >> restoredOrderOnlyPaths [ diff --git a/src/MCP/MCPRepositoryFetchRequest.class.st b/src/MCP/MCPRepositoryFetchRequest.class.st index 1401d43..c1548fc 100644 --- a/src/MCP/MCPRepositoryFetchRequest.class.st +++ b/src/MCP/MCPRepositoryFetchRequest.class.st @@ -3,10 +3,7 @@ Parsed input for repository_fetch. It resolves the registered Iceberg repository " Class { #name : 'MCPRepositoryFetchRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference' - ], + #superclass : 'MCPRepositoryRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -24,14 +21,6 @@ MCPRepositoryFetchRequest >> commandForTool: aTool [ ^ MCPFetchRepositoryCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositoryFetchRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - ^ self -] - { #category : 'accessing' } MCPRepositoryFetchRequest >> operation [ @@ -43,15 +32,3 @@ MCPRepositoryFetchRequest >> repository [ ^ self repositoryReference repository ] - -{ #category : 'accessing' } -MCPRepositoryFetchRequest >> repositoryReference [ - - ^ repositoryReference -] - -{ #category : 'converting' } -MCPRepositoryFetchRequest >> requestedContext [ - - ^ self repositoryReference requestedContext -] diff --git a/src/MCP/MCPRepositoryFetchResult.class.st b/src/MCP/MCPRepositoryFetchResult.class.st index fd16a80..0ba360e 100644 --- a/src/MCP/MCPRepositoryFetchResult.class.st +++ b/src/MCP/MCPRepositoryFetchResult.class.st @@ -3,11 +3,8 @@ Result DTO returned by repository_fetch. It reports repository metadata before a " Class { #name : 'MCPRepositoryFetchResult', - #superclass : 'Object', + #superclass : 'MCPRepositoryTransitionResult', #instVars : [ - 'repositoryInfoBefore', - 'repositoryInfoAfter', - 'packageInfos', 'remoteNames', 'branchName', 'headDescription' @@ -26,12 +23,7 @@ MCPRepositoryFetchResult class >> repositoryBefore: beforeInfo after: aRepositor { #category : 'converting' } MCPRepositoryFetchResult >> asDictionary [ - | data | - data := Dictionary new. - self branchName ifNotEmpty: [ :name | data at: #branchName put: name ]. - self headDescription ifNotEmpty: [ :description | - data at: #headDescription put: description ]. - ^ data + ^ self branchHeadDictionary ] { #category : 'accessing' } @@ -49,30 +41,10 @@ MCPRepositoryFetchResult >> headDescription [ { #category : 'initialization' } MCPRepositoryFetchResult >> initializeRepositoryBefore: beforeInfo after: aRepository [ - repositoryInfoBefore := beforeInfo. - repositoryInfoAfter := MCPRepositoryInfo fromRepository: aRepository. - packageInfos := self packageInfosFromRepository: aRepository. + super initializeRepositoryBefore: beforeInfo after: aRepository. remoteNames := repositoryInfoAfter remoteNames. branchName := repositoryInfoAfter branchName. - headDescription := repositoryInfoAfter headDescription. - ^ self -] - -{ #category : 'accessing' } -MCPRepositoryFetchResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'private' } -MCPRepositoryFetchResult >> packageInfosFromRepository: aRepository [ - - | packages | - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - ^ packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ] + headDescription := repositoryInfoAfter headDescription ] { #category : 'accessing' } @@ -80,21 +52,3 @@ MCPRepositoryFetchResult >> remoteNames [ ^ remoteNames ifNil: [ #( ) ] ] - -{ #category : 'accessing' } -MCPRepositoryFetchResult >> repositoryInfo [ - - ^ self repositoryInfoAfter -] - -{ #category : 'accessing' } -MCPRepositoryFetchResult >> repositoryInfoAfter [ - - ^ repositoryInfoAfter -] - -{ #category : 'accessing' } -MCPRepositoryFetchResult >> repositoryInfoBefore [ - - ^ repositoryInfoBefore -] diff --git a/src/MCP/MCPRepositoryInfo.class.st b/src/MCP/MCPRepositoryInfo.class.st index 81e17a3..bceaab1 100644 --- a/src/MCP/MCPRepositoryInfo.class.st +++ b/src/MCP/MCPRepositoryInfo.class.st @@ -5,7 +5,7 @@ It is read-only and intended for repository_search responses and repository oper " Class { #name : 'MCPRepositoryInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'name', 'className', diff --git a/src/MCP/MCPRepositoryPackageInfo.class.st b/src/MCP/MCPRepositoryPackageInfo.class.st index 923f8cf..efea014 100644 --- a/src/MCP/MCPRepositoryPackageInfo.class.st +++ b/src/MCP/MCPRepositoryPackageInfo.class.st @@ -5,7 +5,7 @@ It reports package metadata needed by repository management tools without exposi " Class { #name : 'MCPRepositoryPackageInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'name', 'directoryName', diff --git a/src/MCP/MCPRepositoryPullRequest.class.st b/src/MCP/MCPRepositoryPullRequest.class.st index 87afd70..9204f58 100644 --- a/src/MCP/MCPRepositoryPullRequest.class.st +++ b/src/MCP/MCPRepositoryPullRequest.class.st @@ -3,10 +3,7 @@ Parsed input for repository_pull. It resolves the registered Iceberg repository " Class { #name : 'MCPRepositoryPullRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference' - ], + #superclass : 'MCPRepositoryRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -24,14 +21,6 @@ MCPRepositoryPullRequest >> commandForTool: aTool [ ^ MCPPullRepositoryCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositoryPullRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - ^ self -] - { #category : 'accessing' } MCPRepositoryPullRequest >> operation [ @@ -43,15 +32,3 @@ MCPRepositoryPullRequest >> repository [ ^ self repositoryReference repository ] - -{ #category : 'accessing' } -MCPRepositoryPullRequest >> repositoryReference [ - - ^ repositoryReference -] - -{ #category : 'converting' } -MCPRepositoryPullRequest >> requestedContext [ - - ^ self repositoryReference requestedContext -] diff --git a/src/MCP/MCPRepositoryPullResult.class.st b/src/MCP/MCPRepositoryPullResult.class.st index 75aa60c..60e3303 100644 --- a/src/MCP/MCPRepositoryPullResult.class.st +++ b/src/MCP/MCPRepositoryPullResult.class.st @@ -3,11 +3,8 @@ Result DTO returned by repository_pull. It reports repository metadata before an " Class { #name : 'MCPRepositoryPullResult', - #superclass : 'Object', + #superclass : 'MCPRepositoryTransitionResult', #instVars : [ - 'repositoryInfoBefore', - 'repositoryInfoAfter', - 'packageInfos', 'branchName', 'headDescription', 'modifiedPackageNames' @@ -51,13 +48,10 @@ MCPRepositoryPullResult >> headDescription [ { #category : 'initialization' } MCPRepositoryPullResult >> initializeRepositoryBefore: beforeInfo after: aRepository [ - repositoryInfoBefore := beforeInfo. - repositoryInfoAfter := MCPRepositoryInfo fromRepository: aRepository. - packageInfos := self packageInfosFromRepository: aRepository. + super initializeRepositoryBefore: beforeInfo after: aRepository. branchName := repositoryInfoAfter branchName. headDescription := repositoryInfoAfter headDescription. - modifiedPackageNames := repositoryInfoAfter modifiedPackageNames. - ^ self + modifiedPackageNames := repositoryInfoAfter modifiedPackageNames ] { #category : 'accessing' } @@ -65,38 +59,3 @@ MCPRepositoryPullResult >> modifiedPackageNames [ ^ modifiedPackageNames ifNil: [ #( ) ] ] - -{ #category : 'accessing' } -MCPRepositoryPullResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'private' } -MCPRepositoryPullResult >> packageInfosFromRepository: aRepository [ - - | packages | - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - ^ packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ] -] - -{ #category : 'accessing' } -MCPRepositoryPullResult >> repositoryInfo [ - - ^ self repositoryInfoAfter -] - -{ #category : 'accessing' } -MCPRepositoryPullResult >> repositoryInfoAfter [ - - ^ repositoryInfoAfter -] - -{ #category : 'accessing' } -MCPRepositoryPullResult >> repositoryInfoBefore [ - - ^ repositoryInfoBefore -] diff --git a/src/MCP/MCPRepositoryPushRequest.class.st b/src/MCP/MCPRepositoryPushRequest.class.st index de4a82e..6aa8628 100644 --- a/src/MCP/MCPRepositoryPushRequest.class.st +++ b/src/MCP/MCPRepositoryPushRequest.class.st @@ -3,10 +3,7 @@ Parsed input for repository_push. It resolves the registered Iceberg repository " Class { #name : 'MCPRepositoryPushRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference' - ], + #superclass : 'MCPRepositoryRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -24,14 +21,6 @@ MCPRepositoryPushRequest >> commandForTool: aTool [ ^ MCPPushRepositoryCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositoryPushRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - ^ self -] - { #category : 'accessing' } MCPRepositoryPushRequest >> operation [ @@ -43,15 +32,3 @@ MCPRepositoryPushRequest >> repository [ ^ self repositoryReference repository ] - -{ #category : 'accessing' } -MCPRepositoryPushRequest >> repositoryReference [ - - ^ repositoryReference -] - -{ #category : 'converting' } -MCPRepositoryPushRequest >> requestedContext [ - - ^ self repositoryReference requestedContext -] diff --git a/src/MCP/MCPRepositoryPushResult.class.st b/src/MCP/MCPRepositoryPushResult.class.st index 2591400..7e4c934 100644 --- a/src/MCP/MCPRepositoryPushResult.class.st +++ b/src/MCP/MCPRepositoryPushResult.class.st @@ -3,10 +3,8 @@ Result DTO returned by repository_push. It reports repository metadata, remote n " Class { #name : 'MCPRepositoryPushResult', - #superclass : 'Object', + #superclass : 'MCPRepositorySnapshotResult', #instVars : [ - 'repositoryInfo', - 'packageInfos', 'remoteNames', 'branchName', 'headDescription' @@ -25,12 +23,7 @@ MCPRepositoryPushResult class >> repository: aRepository [ { #category : 'converting' } MCPRepositoryPushResult >> asDictionary [ - | data | - data := Dictionary new. - self branchName ifNotEmpty: [ :name | data at: #branchName put: name ]. - self headDescription ifNotEmpty: [ :description | - data at: #headDescription put: description ]. - ^ data + ^ self branchHeadDictionary ] { #category : 'accessing' } @@ -48,29 +41,10 @@ MCPRepositoryPushResult >> headDescription [ { #category : 'initialization' } MCPRepositoryPushResult >> initializeRepository: aRepository [ - repositoryInfo := MCPRepositoryInfo fromRepository: aRepository. - packageInfos := self packageInfosFromRepository: aRepository. + self initializeSnapshotFromRepository: aRepository. remoteNames := repositoryInfo remoteNames. branchName := repositoryInfo branchName. - headDescription := repositoryInfo headDescription. - ^ self -] - -{ #category : 'accessing' } -MCPRepositoryPushResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'private' } -MCPRepositoryPushResult >> packageInfosFromRepository: aRepository [ - - | packages | - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - ^ packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ] + headDescription := repositoryInfo headDescription ] { #category : 'accessing' } @@ -78,9 +52,3 @@ MCPRepositoryPushResult >> remoteNames [ ^ remoteNames ifNil: [ #( ) ] ] - -{ #category : 'accessing' } -MCPRepositoryPushResult >> repositoryInfo [ - - ^ repositoryInfo -] diff --git a/src/MCP/MCPRepositoryReferenceSpec.class.st b/src/MCP/MCPRepositoryReferenceSpec.class.st index e34e3e8..5798b68 100644 --- a/src/MCP/MCPRepositoryReferenceSpec.class.st +++ b/src/MCP/MCPRepositoryReferenceSpec.class.st @@ -78,8 +78,8 @@ MCPRepositoryReferenceSpec >> matchesRepository: aRepository [ (self repositoryNameFor: aRepository) = self name ifFalse: [ ^ false ] ]. self hasLocation ifTrue: [ - (self repositoryLocationFor: aRepository) = self location ifFalse: [ - ^ false ] ]. + (self repositoryLocationFor: aRepository) = self location ifFalse: [ + ^ false ] ]. ^ true ] diff --git a/src/MCP/MCPRepositoryRequest.class.st b/src/MCP/MCPRepositoryRequest.class.st new file mode 100644 index 0000000..0e12404 --- /dev/null +++ b/src/MCP/MCPRepositoryRequest.class.st @@ -0,0 +1,38 @@ +" +Abstract request DTO for repository operations that target an existing repository reference. +" +Class { + #name : 'MCPRepositoryRequest', + #superclass : 'Object', + #instVars : [ + 'repositoryReference' + ], + #category : 'MCP-Requests', + #package : 'MCP', + #tag : 'Requests' +} + +{ #category : 'testing' } +MCPRepositoryRequest class >> isAbstract [ + + ^ self == MCPRepositoryRequest +] + +{ #category : 'initialization' } +MCPRepositoryRequest >> initializeFromRequest: request [ + + repositoryReference := MCPRepositoryReferenceSpec fromRequest: + request +] + +{ #category : 'accessing' } +MCPRepositoryRequest >> repositoryReference [ + + ^ repositoryReference +] + +{ #category : 'converting' } +MCPRepositoryRequest >> requestedContext [ + + ^ self repositoryReference requestedContext +] diff --git a/src/MCP/MCPRepositoryResult.class.st b/src/MCP/MCPRepositoryResult.class.st new file mode 100644 index 0000000..d6454ee --- /dev/null +++ b/src/MCP/MCPRepositoryResult.class.st @@ -0,0 +1,53 @@ +" +Abstract base for repository result DTOs. It owns shared repository snapshot helpers used by concrete repository tool results while leaving each result class responsible for its own public payload shape. +" +Class { + #name : 'MCPRepositoryResult', + #superclass : 'MCPResult', + #category : 'MCP-Results', + #package : 'MCP', + #tag : 'Results' +} + +{ #category : 'testing' } +MCPRepositoryResult class >> isAbstract [ + + ^ self = MCPRepositoryResult +] + +{ #category : 'converting' } +MCPRepositoryResult >> branchHeadDictionary [ + + | data | + data := Dictionary new. + self branchName ifNotEmpty: [ :name | data at: #branchName put: name ]. + self headDescription ifNotEmpty: [ :description | + data at: #headDescription put: description ]. + ^ data +] + +{ #category : 'accessing' } +MCPRepositoryResult >> branchName [ + + ^ '' +] + +{ #category : 'accessing' } +MCPRepositoryResult >> headDescription [ + + ^ '' +] + +{ #category : 'private' } +MCPRepositoryResult >> packageInfosFromRepository: aRepository [ + + ^ (aRepository workingCopy packages asArray sort: [ :left :right | + left name asString <= right name asString ]) collect: [ :each | + MCPRepositoryPackageInfo fromPackage: each ] +] + +{ #category : 'private' } +MCPRepositoryResult >> repositoryInfoFromRepository: aRepository [ + + ^ MCPRepositoryInfo fromRepository: aRepository +] diff --git a/src/MCP/MCPRepositorySnapshotResult.class.st b/src/MCP/MCPRepositorySnapshotResult.class.st new file mode 100644 index 0000000..8578d2a --- /dev/null +++ b/src/MCP/MCPRepositorySnapshotResult.class.st @@ -0,0 +1,57 @@ +" +Abstract base for repository result DTOs that represent one repository snapshot. Subclasses add operation-specific fields while this class owns the common repository and package summary state. +" +Class { + #name : 'MCPRepositorySnapshotResult', + #superclass : 'MCPRepositoryResult', + #instVars : [ + 'repositoryInfo', + 'packageInfos' + ], + #category : 'MCP-Results', + #package : 'MCP', + #tag : 'Results' +} + +{ #category : 'testing' } +MCPRepositorySnapshotResult class >> isAbstract [ + + ^ self = MCPRepositorySnapshotResult +] + +{ #category : 'initialization' } +MCPRepositorySnapshotResult >> initializeFromRepository: aRepository [ + + self initializeSnapshotFromRepository: aRepository +] + +{ #category : 'initialization' } +MCPRepositorySnapshotResult >> initializeSnapshotFromRepository: aRepository [ + + repositoryInfo := self repositoryInfoFromRepository: aRepository. + packageInfos := self packageInfosFromRepository: aRepository +] + +{ #category : 'accessing' } +MCPRepositorySnapshotResult >> packageInfos [ + + ^ packageInfos ifNil: [ #( ) ] +] + +{ #category : 'accessing' } +MCPRepositorySnapshotResult >> packageInfos: aCollection [ + + packageInfos := aCollection ifNil: [ #( ) ] +] + +{ #category : 'accessing' } +MCPRepositorySnapshotResult >> repositoryInfo [ + + ^ repositoryInfo +] + +{ #category : 'accessing' } +MCPRepositorySnapshotResult >> repositoryInfo: aRepositoryInfo [ + + repositoryInfo := aRepositoryInfo +] diff --git a/src/MCP/MCPRepositorySwitchBranchRequest.class.st b/src/MCP/MCPRepositorySwitchBranchRequest.class.st index 6623f02..378d906 100644 --- a/src/MCP/MCPRepositorySwitchBranchRequest.class.st +++ b/src/MCP/MCPRepositorySwitchBranchRequest.class.st @@ -3,11 +3,7 @@ Parsed input for repository_branch_switch. It resolves the registered Iceberg re " Class { #name : 'MCPRepositorySwitchBranchRequest', - #superclass : 'Object', - #instVars : [ - 'repositoryReference', - 'branchName' - ], + #superclass : 'MCPRepositoryBranchRequest', #category : 'MCP-Requests', #package : 'MCP', #tag : 'Requests' @@ -19,27 +15,12 @@ MCPRepositorySwitchBranchRequest class >> fromRequest: request tool: aTool [ ^ self new initializeFromRequest: request ] -{ #category : 'accessing' } -MCPRepositorySwitchBranchRequest >> branchName [ - - ^ branchName ifNil: [ '' ] -] - { #category : 'converting' } MCPRepositorySwitchBranchRequest >> commandForTool: aTool [ ^ MCPSwitchRepositoryBranchCommand tool: aTool request: self ] -{ #category : 'initialization' } -MCPRepositorySwitchBranchRequest >> initializeFromRequest: request [ - - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - branchName := request stringArgumentNamed: 'branchName'. - ^ self -] - { #category : 'accessing' } MCPRepositorySwitchBranchRequest >> operation [ @@ -51,18 +32,3 @@ MCPRepositorySwitchBranchRequest >> repository [ ^ self repositoryReference repository ] - -{ #category : 'accessing' } -MCPRepositorySwitchBranchRequest >> repositoryReference [ - - ^ repositoryReference -] - -{ #category : 'converting' } -MCPRepositorySwitchBranchRequest >> requestedContext [ - - | context | - context := self repositoryReference requestedContext copy. - context at: #branchName put: self branchName. - ^ context -] diff --git a/src/MCP/MCPRepositoryTransitionResult.class.st b/src/MCP/MCPRepositoryTransitionResult.class.st new file mode 100644 index 0000000..e90d964 --- /dev/null +++ b/src/MCP/MCPRepositoryTransitionResult.class.st @@ -0,0 +1,53 @@ +" +Abstract base for repository result DTOs that report a repository transition. It owns the before snapshot, after snapshot, and package summary shared by branch, fetch, pull, and adopt-head operations. +" +Class { + #name : 'MCPRepositoryTransitionResult', + #superclass : 'MCPRepositoryResult', + #instVars : [ + 'repositoryInfoBefore', + 'repositoryInfoAfter', + 'packageInfos' + ], + #category : 'MCP-Results', + #package : 'MCP', + #tag : 'Results' +} + +{ #category : 'testing' } +MCPRepositoryTransitionResult class >> isAbstract [ + + ^ self = MCPRepositoryTransitionResult +] + +{ #category : 'initialization' } +MCPRepositoryTransitionResult >> initializeRepositoryBefore: beforeInfo after: aRepository [ + + repositoryInfoBefore := beforeInfo. + repositoryInfoAfter := self repositoryInfoFromRepository: aRepository. + packageInfos := self packageInfosFromRepository: aRepository +] + +{ #category : 'accessing' } +MCPRepositoryTransitionResult >> packageInfos [ + + ^ packageInfos ifNil: [ #( ) ] +] + +{ #category : 'accessing' } +MCPRepositoryTransitionResult >> repositoryInfo [ + + ^ self repositoryInfoAfter +] + +{ #category : 'accessing' } +MCPRepositoryTransitionResult >> repositoryInfoAfter [ + + ^ repositoryInfoAfter +] + +{ #category : 'accessing' } +MCPRepositoryTransitionResult >> repositoryInfoBefore [ + + ^ repositoryInfoBefore +] diff --git a/src/MCP/MCPRepositoryUpdateRequest.class.st b/src/MCP/MCPRepositoryUpdateRequest.class.st index 1f3ee75..b35ec83 100644 --- a/src/MCP/MCPRepositoryUpdateRequest.class.st +++ b/src/MCP/MCPRepositoryUpdateRequest.class.st @@ -5,9 +5,8 @@ It identifies a registered repository and describes package membership or subdir " Class { #name : 'MCPRepositoryUpdateRequest', - #superclass : 'Object', + #superclass : 'MCPRepositoryRequest', #instVars : [ - 'repositoryReference', 'subdirectory', 'packageNames', 'addPackageNames', @@ -63,17 +62,15 @@ MCPRepositoryUpdateRequest >> hasUpdates [ { #category : 'initialization' } MCPRepositoryUpdateRequest >> initializeFromRequest: request [ + super initializeFromRequest: request. suppliedProperties := self updatePropertyNames select: [ :each | request hasArgumentNamed: each ]. - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. subdirectory := request stringArgumentNamed: 'subdirectory'. packageNames := request stringCollectionArgumentNamed: 'packageNames'. addPackageNames := request stringCollectionArgumentNamed: 'addPackageNames'. removePackageNames := request stringCollectionArgumentNamed: - 'removePackageNames'. - ^ self + 'removePackageNames' ] { #category : 'accessing' } @@ -100,21 +97,15 @@ MCPRepositoryUpdateRequest >> repository [ ^ self repositoryReference repository ] -{ #category : 'accessing' } -MCPRepositoryUpdateRequest >> repositoryReference [ - - ^ repositoryReference -] - { #category : 'converting' } MCPRepositoryUpdateRequest >> requestedContext [ | context | context := self repositoryReference requestedContext copy. self suppliedProperties do: [ :propertyName | - context - at: propertyName asSymbol - put: (self contextValueForPropertyNamed: propertyName) ]. + context + at: propertyName asSymbol + put: (self contextValueForPropertyNamed: propertyName) ]. context at: #updateActions put: self requestedRepositoryUpdateActions. ^ context ] diff --git a/src/MCP/MCPRepositoryUpdateResult.class.st b/src/MCP/MCPRepositoryUpdateResult.class.st index 3b5b26a..165ec9c 100644 --- a/src/MCP/MCPRepositoryUpdateResult.class.st +++ b/src/MCP/MCPRepositoryUpdateResult.class.st @@ -3,10 +3,8 @@ Result DTO returned by repository_update. It reports the repository after applyi " Class { #name : 'MCPRepositoryUpdateResult', - #superclass : 'Object', + #superclass : 'MCPRepositorySnapshotResult', #instVars : [ - 'repositoryInfo', - 'packageInfos', 'updateActions', 'addedPackageNames', 'removedPackageNames' @@ -55,29 +53,10 @@ MCPRepositoryUpdateResult >> asDictionary [ { #category : 'initialization' } MCPRepositoryUpdateResult >> initializeRepository: aRepository updateActions: actionNames addedPackageNames: addedNames removedPackageNames: removedNames [ - | packages | - repositoryInfo := MCPRepositoryInfo fromRepository: aRepository. - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - packageInfos := packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ]. + self initializeSnapshotFromRepository: aRepository. updateActions := actionNames ifNil: [ #( ) ]. addedPackageNames := addedNames ifNil: [ #( ) ]. - removedPackageNames := removedNames ifNil: [ #( ) ]. - ^ self -] - -{ #category : 'accessing' } -MCPRepositoryUpdateResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'accessing' } -MCPRepositoryUpdateResult >> packageInfos: aCollection [ - - packageInfos := aCollection ifNil: [ #( ) ] + removedPackageNames := removedNames ifNil: [ #( ) ] ] { #category : 'accessing' } @@ -92,18 +71,6 @@ MCPRepositoryUpdateResult >> removedPackageNames: aCollection [ removedPackageNames := aCollection ifNil: [ #( ) ] ] -{ #category : 'accessing' } -MCPRepositoryUpdateResult >> repositoryInfo [ - - ^ repositoryInfo -] - -{ #category : 'accessing' } -MCPRepositoryUpdateResult >> repositoryInfo: aRepositoryInfo [ - - repositoryInfo := aRepositoryInfo -] - { #category : 'accessing' } MCPRepositoryUpdateResult >> updateActions [ diff --git a/src/MCP/MCPRepositoryVerifyIdentityCommand.class.st b/src/MCP/MCPRepositoryVerifyIdentityCommand.class.st index 4dddf75..9596b7b 100644 --- a/src/MCP/MCPRepositoryVerifyIdentityCommand.class.st +++ b/src/MCP/MCPRepositoryVerifyIdentityCommand.class.st @@ -5,22 +5,12 @@ It performs a read-only identity assertion over a registered Iceberg repository " Class { #name : 'MCPRepositoryVerifyIdentityCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPRepositoryVerifyIdentityCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private - validation' } MCPRepositoryVerifyIdentityCommand >> addMismatchIfExpected: expectedValue actual: actualValue field: fieldName checkedFields: checkedFields mismatches: mismatches [ @@ -145,35 +135,24 @@ MCPRepositoryVerifyIdentityCommand >> checkedFieldsAndMismatchesFor: repositoryI MCPRepositoryVerifyIdentityCommand >> execute [ | repository result validation | - ^ self tool - executeMutationAction: 'verifyIdentity' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'verifyIdentity' work: [ - repository := self repositoryForVerifyIdentity. - validation := self validateRepository: repository. - result := MCPRepositoryVerifyIdentityResult - repository: repository - checkedFields: - (validation at: #checkedFields) ] + repository := self repositoryForVerifyIdentity. + validation := self validateRepository: repository. + result := MCPRepositoryVerifyIdentityResult + repository: repository + checkedFields: (validation at: #checkedFields) ] successResult: [ :warningMessages | - self tool - successResultText: - 'Repository identity verification passed for ' - , result repositoryInfo name , '.' - data: (self tool dataForRepositoryVerifyIdentityResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Repository identity verification passed for ' + , result repositoryInfo name , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to verify repository identity: ' - , (error messageText ifNil: [ error asString ]) ] -] - -{ #category : 'initialization' } -MCPRepositoryVerifyIdentityCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self + 'Failed verify repository identity: ' + , (error messageText ifNil: [ error asString ]) ] ] { #category : 'private - resolving' } @@ -182,26 +161,20 @@ MCPRepositoryVerifyIdentityCommand >> repositoryForVerifyIdentity [ ^ [ self request repository ] on: MCPCommandError do: [ :error | - (self shouldRetryByNameOnlyAfter: error) - ifTrue: [ - (MCPRepositoryReferenceSpec - name: self request repositoryReference name - location: nil) repository ] - ifFalse: [ error signal ] ] -] - -{ #category : 'accessing' } -MCPRepositoryVerifyIdentityCommand >> request [ - - ^ request + (self shouldRetryByNameOnlyAfter: error) + ifTrue: [ + (MCPRepositoryReferenceSpec + name: self request repositoryReference name + location: nil) repository ] + ifFalse: [ error signal ] ] ] { #category : 'private - resolving' } MCPRepositoryVerifyIdentityCommand >> shouldRetryByNameOnlyAfter: anError [ ^ anError errorCode = #RepositoryNotFound and: [ - self request repositoryReference hasName and: [ - self request repositoryReference hasLocation ] ] + self request repositoryReference hasName and: [ + self request repositoryReference hasLocation ] ] ] { #category : 'private - validation' } @@ -210,8 +183,8 @@ MCPRepositoryVerifyIdentityCommand >> signalIdentityMismatchFor: repositoryInfo MCPCommandError signalErrorCode: #RepositoryIdentityMismatch message: - 'Repository identity verification failed for ' , repositoryInfo name - , '.' + 'Repository identity verification failed for ' + , repositoryInfo name , '.' details: (self request requestedContext copy at: #repository put: repositoryInfo asDictionary; at: #mismatches put: mismatches; @@ -232,18 +205,6 @@ MCPRepositoryVerifyIdentityCommand >> signalMissingExpectedIdentityFields [ yourself) ] -{ #category : 'private' } -MCPRepositoryVerifyIdentityCommand >> sortedStringsFrom: aCollection [ - - ^ (aCollection collect: [ :each | each asString ] as: Array) sort -] - -{ #category : 'accessing' } -MCPRepositoryVerifyIdentityCommand >> tool [ - - ^ tool -] - { #category : 'private - validation' } MCPRepositoryVerifyIdentityCommand >> validateRepository: aRepository [ diff --git a/src/MCP/MCPRepositoryVerifyIdentityRequest.class.st b/src/MCP/MCPRepositoryVerifyIdentityRequest.class.st index 054b018..29eb3b5 100644 --- a/src/MCP/MCPRepositoryVerifyIdentityRequest.class.st +++ b/src/MCP/MCPRepositoryVerifyIdentityRequest.class.st @@ -3,10 +3,8 @@ Parsed input for repository_identity_verify. It resolves a registered Iceberg re " Class { #name : 'MCPRepositoryVerifyIdentityRequest', - #superclass : 'Object', + #superclass : 'MCPRepositoryBranchRequest', #instVars : [ - 'repositoryReference', - 'branchName', 'subdirectory', 'packageNames', 'modifiedPackageNames', @@ -27,12 +25,6 @@ MCPRepositoryVerifyIdentityRequest class >> fromRequest: request tool: aTool [ ^ self new initializeFromRequest: request ] -{ #category : 'accessing' } -MCPRepositoryVerifyIdentityRequest >> branchName [ - - ^ branchName ifNil: [ '' ] -] - { #category : 'converting' } MCPRepositoryVerifyIdentityRequest >> commandForTool: aTool [ @@ -43,11 +35,11 @@ MCPRepositoryVerifyIdentityRequest >> commandForTool: aTool [ MCPRepositoryVerifyIdentityRequest >> hasExpectedIdentityFields [ ^ self repositoryReference hasLocation or: [ - self branchName isNotEmpty or: [ - self hasExpectedSubdirectory or: [ - self hasExpectedPackageNames or: [ - self hasExpectedModifiedPackageNames or: [ - self hasExpectedIsModified ] ] ] ] ] + self branchName isNotEmpty or: [ + self hasExpectedSubdirectory or: [ + self hasExpectedPackageNames or: [ + self hasExpectedModifiedPackageNames or: [ + self hasExpectedIsModified ] ] ] ] ] ] { #category : 'testing' } @@ -77,26 +69,27 @@ MCPRepositoryVerifyIdentityRequest >> hasExpectedSubdirectory [ { #category : 'initialization' } MCPRepositoryVerifyIdentityRequest >> initializeFromRequest: request [ - repositoryReference := MCPRepositoryReferenceSpec fromRequest: - request. - branchName := request stringArgumentNamed: 'branchName'. + super initializeFromRequest: request. hasSubdirectory := request hasArgumentNamed: 'subdirectory'. hasPackageNames := request hasArgumentNamed: 'packageNames'. - hasModifiedPackageNames := request hasArgumentNamed: 'modifiedPackageNames'. + hasModifiedPackageNames := request hasArgumentNamed: + 'modifiedPackageNames'. hasIsModified := request hasArgumentNamed: 'isModified'. hasSubdirectory ifTrue: [ - subdirectory := self - stringArgumentNamed: 'subdirectory' - preservingEmptyFrom: request ]. + subdirectory := self + stringArgumentNamed: 'subdirectory' + preservingEmptyFrom: request ]. hasPackageNames ifTrue: [ - packageNames := request uniqueStringCollectionArgumentNamed: - 'packageNames' ]. + packageNames := request uniqueStringCollectionArgumentNamed: + 'packageNames' ]. hasModifiedPackageNames ifTrue: [ - modifiedPackageNames := request uniqueStringCollectionArgumentNamed: - 'modifiedPackageNames' ]. + modifiedPackageNames := request + uniqueStringCollectionArgumentNamed: + 'modifiedPackageNames' ]. hasIsModified ifTrue: [ - isModified := request booleanArgumentNamed: 'isModified' default: false ]. - ^ self + isModified := request + booleanArgumentNamed: 'isModified' + default: false ] ] { #category : 'accessing' } @@ -129,12 +122,6 @@ MCPRepositoryVerifyIdentityRequest >> repository [ ^ self repositoryReference repository ] -{ #category : 'accessing' } -MCPRepositoryVerifyIdentityRequest >> repositoryReference [ - - ^ repositoryReference -] - { #category : 'converting' } MCPRepositoryVerifyIdentityRequest >> requestedContext [ diff --git a/src/MCP/MCPRepositoryVerifyIdentityResult.class.st b/src/MCP/MCPRepositoryVerifyIdentityResult.class.st index f56587b..16f92da 100644 --- a/src/MCP/MCPRepositoryVerifyIdentityResult.class.st +++ b/src/MCP/MCPRepositoryVerifyIdentityResult.class.st @@ -3,10 +3,8 @@ Result DTO returned by repository_identity_verify. It reports the repository sna " Class { #name : 'MCPRepositoryVerifyIdentityResult', - #superclass : 'Object', + #superclass : 'MCPRepositorySnapshotResult', #instVars : [ - 'repositoryInfo', - 'packageInfos', 'checkedFields', 'matched' ], @@ -38,11 +36,9 @@ MCPRepositoryVerifyIdentityResult >> checkedFields [ { #category : 'initialization' } MCPRepositoryVerifyIdentityResult >> initializeRepository: aRepository checkedFields: fieldNames [ - repositoryInfo := MCPRepositoryInfo fromRepository: aRepository. - packageInfos := self packageInfosFromRepository: aRepository. + self initializeSnapshotFromRepository: aRepository. checkedFields := fieldNames ifNil: [ #( ) ]. - matched := true. - ^ self + matched := true ] { #category : 'accessing' } @@ -50,26 +46,3 @@ MCPRepositoryVerifyIdentityResult >> matched [ ^ matched ifNil: [ false ] ] - -{ #category : 'accessing' } -MCPRepositoryVerifyIdentityResult >> packageInfos [ - - ^ packageInfos ifNil: [ #( ) ] -] - -{ #category : 'private' } -MCPRepositoryVerifyIdentityResult >> packageInfosFromRepository: aRepository [ - - | packages | - packages := aRepository workingCopy packages asArray - sort: [ :left :right | - left name asString <= right name asString ]. - ^ packages collect: [ :each | - MCPRepositoryPackageInfo fromPackage: each ] -] - -{ #category : 'accessing' } -MCPRepositoryVerifyIdentityResult >> repositoryInfo [ - - ^ repositoryInfo -] diff --git a/src/MCP/MCPRepositoryWorkingCopyCommand.class.st b/src/MCP/MCPRepositoryWorkingCopyCommand.class.st index 442dde1..bc27bdd 100644 --- a/src/MCP/MCPRepositoryWorkingCopyCommand.class.st +++ b/src/MCP/MCPRepositoryWorkingCopyCommand.class.st @@ -5,11 +5,7 @@ It centralizes shared tool/request plumbing and diff summarization helpers used " Class { #name : 'MCPRepositoryWorkingCopyCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' @@ -21,14 +17,6 @@ MCPRepositoryWorkingCopyCommand class >> isAbstract [ ^ self = MCPRepositoryWorkingCopyCommand ] -{ #category : 'instance creation' } -MCPRepositoryWorkingCopyCommand class >> tool: aTool request: aRequest [ - - ^ self new - initializeTool: aTool request: aRequest; - yourself -] - { #category : 'private - diff' } MCPRepositoryWorkingCopyCommand >> addModifiedPathsFromNode: aNode to: paths [ @@ -49,14 +37,6 @@ MCPRepositoryWorkingCopyCommand >> changedPackageNamesFromDiff: aDiff [ ^ self sortedStringsFrom: names ] -{ #category : 'initialization' } -MCPRepositoryWorkingCopyCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - { #category : 'private - diff' } MCPRepositoryWorkingCopyCommand >> modifiedPathsFromDiff: aDiff [ @@ -74,24 +54,6 @@ MCPRepositoryWorkingCopyCommand >> packageNameFromDiffPackageNode: aNode [ ^ aNode mcpDiffPackageName ] -{ #category : 'accessing' } -MCPRepositoryWorkingCopyCommand >> request [ - - ^ request -] - -{ #category : 'private' } -MCPRepositoryWorkingCopyCommand >> sortedStringsFrom: aCollection [ - - ^ (aCollection collect: [ :each | each asString ]) asSet asArray sort -] - -{ #category : 'accessing' } -MCPRepositoryWorkingCopyCommand >> tool [ - - ^ tool -] - { #category : 'private - execution' } MCPRepositoryWorkingCopyCommand >> withNonInteractiveAuthorDuring: aBlock [ diff --git a/src/MCP/MCPRespondsToUsageRule.class.st b/src/MCP/MCPRespondsToUsageRule.class.st index 0d501f4..86fa4d6 100644 --- a/src/MCP/MCPRespondsToUsageRule.class.st +++ b/src/MCP/MCPRespondsToUsageRule.class.st @@ -26,7 +26,7 @@ MCPRespondsToUsageRule class >> forbiddenSelector [ { #category : 'accessing' } MCPRespondsToUsageRule class >> group [ - ^ self designFlawGroup + ^ #'Design Flaws' ] { #category : 'accessing' } diff --git a/src/MCP/MCPResult.class.st b/src/MCP/MCPResult.class.st new file mode 100644 index 0000000..cf28e53 --- /dev/null +++ b/src/MCP/MCPResult.class.st @@ -0,0 +1,24 @@ +" +Abstract base for MCP result objects. + +Dictionary-style results implement #asDictionary. +" +Class { + #name : 'MCPResult', + #superclass : 'Object', + #category : 'MCP-Results', + #package : 'MCP', + #tag : 'Results' +} + +{ #category : 'testing' } +MCPResult class >> isAbstract [ + + ^ self == MCPResult +] + +{ #category : 'converting' } +MCPResult >> asDictionary [ + + self subclassResponsibility +] diff --git a/src/MCP/MCPRewriteMethodsCommand.class.st b/src/MCP/MCPRewriteMethodsCommand.class.st index 37d6c34..9a06907 100644 --- a/src/MCP/MCPRewriteMethodsCommand.class.st +++ b/src/MCP/MCPRewriteMethodsCommand.class.st @@ -5,22 +5,12 @@ It resolves the method scope, delegates pattern matching to the NewTools rewrite " Class { #name : 'MCPRewriteMethodsCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPRewriteMethodsCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private - rewriting' } MCPRewriteMethodsCommand >> applyChanges: changes [ @@ -35,9 +25,9 @@ MCPRewriteMethodsCommand >> changeInfosForChanges: changes [ ^ changes collect: [ :each | - MCPMethodRewriteChangeInfo - fromChange: each - includeSources: self request includeSources ] + MCPMethodRewriteChangeInfo + fromChange: each + includeSources: self request includeSources ] as: Array ] @@ -111,26 +101,12 @@ MCPRewriteMethodsCommand >> hashForChange: aChange [ into: [ :hash :valueHash | (hash bitXor: valueHash) hashMultiply ] ] -{ #category : 'initialization' } -MCPRewriteMethodsCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - { #category : 'private - rewriting' } MCPRewriteMethodsCommand >> refactoringChangeManager [ ^ PharoCompatibility refactoringChangeManagerClass instance ] -{ #category : 'accessing' } -MCPRewriteMethodsCommand >> request [ - - ^ request -] - { #category : 'private - rewriting' } MCPRewriteMethodsCommand >> rewriteChanges [ @@ -188,8 +164,8 @@ MCPRewriteMethodsCommand >> stableHashForSource: aString [ | hash | hash := 5381. aString do: [ :character | - character isSeparator ifFalse: [ - hash := (hash bitXor: character asciiValue) hashMultiply ] ]. + character isSeparator ifFalse: [ + hash := (hash bitXor: character asciiValue) hashMultiply ] ]. ^ hash abs ] @@ -217,18 +193,12 @@ MCPRewriteMethodsCommand >> stableHashForValue: anObject [ MCPRewriteMethodsCommand >> successSummaryForReport: report [ report apply ifTrue: [ - ^ 'Applied ' , report appliedCount asString - , ' method rewrite change(s).' ]. + ^ 'Applied ' , report appliedCount asString + , ' method rewrite change(s).' ]. ^ 'Previewed ' , report changeCount asString , ' method rewrite change(s).' ] -{ #category : 'accessing' } -MCPRewriteMethodsCommand >> tool [ - - ^ tool -] - { #category : 'private - validating' } MCPRewriteMethodsCommand >> validateExpectedChangeSetHash: changeSetHashInteger [ diff --git a/src/MCP/MCPRunTestsCommand.class.st b/src/MCP/MCPRunTestsCommand.class.st index b9aa8bc..388c909 100644 --- a/src/MCP/MCPRunTestsCommand.class.st +++ b/src/MCP/MCPRunTestsCommand.class.st @@ -5,22 +5,12 @@ It resolves MCPTestRunRequest objects to MCPValidatedTestRunRequest objects, exe " Class { #name : 'MCPRunTestsCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPRunTestsCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private' } MCPRunTestsCommand >> addTestCasesFrom: aTestOrSuite to: testCases [ @@ -46,11 +36,7 @@ MCPRunTestsCommand >> coverableMethodsForCoverageRequest: aCoverageRequest [ { #category : 'private - coverage' } MCPRunTestsCommand >> coverageCollectorClass [ - ^ Smalltalk globals at: #CoverageCollector ifAbsent: [ - MCPCommandError - signalErrorCode: #CoverageUnavailable - message: 'CoverageCollector is not available in this image.' - details: Dictionary new ] + ^ CoverageCollector ] { #category : 'private - coverage' } @@ -104,14 +90,6 @@ MCPRunTestsCommand >> hasTimedOutAt: deadline [ ^ (self millisecondsRemainingUntil: deadline) <= 0 ] -{ #category : 'initialization' } -MCPRunTestsCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - { #category : 'private - timeout' } MCPRunTestsCommand >> millisecondsRemainingUntil: deadline [ @@ -133,12 +111,6 @@ MCPRunTestsCommand >> refreshRegisteredRepositoryDirtyPackages [ repository workingCopy refreshDirtyPackages ] ] ] -{ #category : 'accessing' } -MCPRunTestsCommand >> request [ - - ^ request -] - { #category : 'private' } MCPRunTestsCommand >> resultForValidatedRequest: validatedRequest deadline: deadline seenTestCaseNames: seenTestCaseNames [ @@ -162,12 +134,12 @@ MCPRunTestsCommand >> resultForValidatedRequest: validatedRequest deadline: dead testRunInfoForTestResult: result validatedRequest: validatedRequest selectedTestCount: selectedTestCount ]. - unrunTestRequests := timedOutIndex - ifNil: [ #( ) ] - ifNotNil: [ - self - testRequestsForTestCases: testCases - startingAt: timedOutIndex ]. + unrunTestRequests := timedOutIndex ifNil: [ #( ) ] ifNotNil: [ + self + unrunRequestsForValidatedRequest: + validatedRequest + testCases: testCases + startingAt: timedOutIndex ]. ^ MCPTestRunResult resultInfo: resultInfo timedOut: timedOutIndex notNil @@ -182,16 +154,16 @@ MCPRunTestsCommand >> runCoverageForValidatedRequests: validatedRequests deadlin methods := self coverableMethodsForCoverageRequest: coverageRequest. collector := self coverageCollectorForMethods: methods. [ - collector installOn: [ - collector reset. - runResult := self - runValidatedRequests: validatedRequests - deadline: deadline. - "Collect before resetting annotations so partial node coverage remains observable." - collector remapMethods. - coverageResult := collector basicCollectResult. - partialMethods := self partiallyCoveredMethodsFromCoverageResult: - coverageResult ] ] ensure: [ collector reset ]. + collector installOn: [ + collector reset. + runResult := self + runValidatedRequests: validatedRequests + deadline: deadline. + "Collect before resetting annotations so partial node coverage remains observable." + collector remapMethods. + coverageResult := collector basicCollectResult. + partialMethods := self partiallyCoveredMethodsFromCoverageResult: + coverageResult ] ] ensure: [ collector reset ]. runResult coverage: (MCPTestCoverageResult coverageResult: coverageResult includeCoveredMethods: coverageRequest includeCoveredMethods @@ -207,8 +179,8 @@ MCPRunTestsCommand >> runTestCase: aTestCase into: aResult deadline: deadline [ remaining := self millisecondsRemainingUntil: deadline. remaining <= 0 ifTrue: [ ^ true ]. ^ [ - aTestCase run: aResult. - false ] valueWithinMilliseconds: remaining onTimeout: [ true ] + aTestCase run: aResult. + false ] valueWithinMilliseconds: remaining onTimeout: [ true ] ] { #category : 'private' } @@ -281,15 +253,27 @@ MCPRunTestsCommand >> testCaseDeduplicationKeyFor: aTestCase [ nextPutAll: aTestCase nameForReport ] ] +{ #category : 'private' } +MCPRunTestsCommand >> testCasesForPackageRequest: validatedRequest [ + + ^ Array streamContents: [ :stream | + (self testClassesInPackageNamed: validatedRequest packageName) + do: [ :testClass | + (self testCasesFromSuite: testClass suite) do: [ :testCase | + stream nextPut: testCase ] ] ] +] + { #category : 'private' } MCPRunTestsCommand >> testCasesForValidatedRequest: validatedRequest [ | suite testCases testMethodSelector | + validatedRequest isPackageRequest ifTrue: [ + ^ self testCasesForPackageRequest: validatedRequest ]. suite := validatedRequest testClass suite. testCases := self testCasesFromSuite: suite. validatedRequest testMethodName ifNotNil: [ :testMethodName | - testMethodSelector := testMethodName asSymbol. - ^ testCases select: [ :each | each selector = testMethodSelector ] ]. + testMethodSelector := testMethodName asSymbol. + ^ testCases select: [ :each | each selector = testMethodSelector ] ]. ^ testCases ] @@ -302,6 +286,19 @@ MCPRunTestsCommand >> testCasesFromSuite: aSuite [ ^ testCases asArray ] +{ #category : 'private' } +MCPRunTestsCommand >> testClassesInPackageNamed: packageName [ + + | package | + package := MCPImageLookup + packageNamed: packageName + scopeName: 'packages'. + ^ (package definedClasses select: [ :each | + each isTestCase and: [ each isAbstract not ] ]) asArray sort: [ + :left + :right | left name <= right name ] +] + { #category : 'private' } MCPRunTestsCommand >> testRequestForTestCase: aTestCase [ @@ -310,6 +307,26 @@ MCPRunTestsCommand >> testRequestForTestCase: aTestCase [ testMethodName: aTestCase selector asString ] +{ #category : 'private' } +MCPRunTestsCommand >> testRequestsByClassForTestCases: testCases startingAt: startIndex [ + + | firstClass requests seenClassNames | + requests := OrderedCollection new. + seenClassNames := Set new. + firstClass := (testCases at: startIndex) class. + startIndex to: testCases size do: [ :index | + | className testCase | + testCase := testCases at: index. + className := testCase class name asString. + testCase class = firstClass + ifTrue: [ requests add: (self testRequestForTestCase: testCase) ] + ifFalse: [ + (seenClassNames includes: className) ifFalse: [ + seenClassNames add: className. + requests add: (MCPTestRunRequest className: className) ] ] ]. + ^ requests asArray +] + { #category : 'private' } MCPRunTestsCommand >> testRequestsForTestCases: testCases startingAt: startIndex [ @@ -338,18 +355,21 @@ MCPRunTestsCommand >> testRunInfoForTestResult: aResult validatedRequest: valida issues: issues ] -{ #category : 'accessing' } -MCPRunTestsCommand >> tool [ +{ #category : 'private' } +MCPRunTestsCommand >> uniqueTestCasesForValidatedRequest: validatedRequest seenTestCaseNames: seenTestCaseNames [ - ^ tool + ^ self + uniqueTestCasesFrom: + (self testCasesForValidatedRequest: validatedRequest) + seenTestCaseNames: seenTestCaseNames ] { #category : 'private' } -MCPRunTestsCommand >> uniqueTestCasesForValidatedRequest: validatedRequest seenTestCaseNames: seenTestCaseNames [ +MCPRunTestsCommand >> uniqueTestCasesFrom: testCases seenTestCaseNames: seenTestCaseNames [ | uniqueTestCases | uniqueTestCases := OrderedCollection new. - (self testCasesForValidatedRequest: validatedRequest) do: [ :testCase | + testCases do: [ :testCase | | testCaseName | testCaseName := self testCaseDeduplicationKeyFor: testCase. (seenTestCaseNames includes: testCaseName) ifFalse: [ @@ -358,6 +378,31 @@ MCPRunTestsCommand >> uniqueTestCasesForValidatedRequest: validatedRequest seenT ^ uniqueTestCases asArray ] +{ #category : 'private' } +MCPRunTestsCommand >> unrunRequestsForValidatedRequest: validatedRequest seenTestCaseNames: seenTestCaseNames [ + + | testCases uniqueTestCases | + testCases := self testCasesForValidatedRequest: validatedRequest. + uniqueTestCases := self + uniqueTestCasesFrom: testCases + seenTestCaseNames: seenTestCaseNames. + uniqueTestCases ifEmpty: [ ^ #( ) ]. + (validatedRequest hasTestMethod not and: [ + uniqueTestCases size = testCases size ]) ifTrue: [ + ^ { validatedRequest testRunRequest } ]. + ^ self testRequestsForTestCases: uniqueTestCases startingAt: 1 +] + +{ #category : 'private' } +MCPRunTestsCommand >> unrunRequestsForValidatedRequest: validatedRequest testCases: testCases startingAt: startIndex [ + + validatedRequest isPackageRequest ifTrue: [ + ^ self + testRequestsByClassForTestCases: testCases + startingAt: startIndex ]. + ^ self testRequestsForTestCases: testCases startingAt: startIndex +] + { #category : 'private' } MCPRunTestsCommand >> unrunTestsFrom: validatedRequests startingAt: startIndex seenTestCaseNames: seenTestCaseNames [ @@ -365,11 +410,8 @@ MCPRunTestsCommand >> unrunTestsFrom: validatedRequests startingAt: startIndex s unrun := OrderedCollection new. startIndex to: validatedRequests size do: [ :index | unrun addAll: (self - testRequestsForTestCases: (self - uniqueTestCasesForValidatedRequest: - (validatedRequests at: index) - seenTestCaseNames: seenTestCaseNames) - startingAt: 1) ]. + unrunRequestsForValidatedRequest: (validatedRequests at: index) + seenTestCaseNames: seenTestCaseNames) ]. ^ unrun asArray ] @@ -377,13 +419,20 @@ MCPRunTestsCommand >> unrunTestsFrom: validatedRequests startingAt: startIndex s MCPRunTestsCommand >> validatedRequestsFrom: testRequests [ ^ testRequests collect: [ :each | - | testClass | - testClass := MCPImageLookup classNamed: each className. - each testMethodName ifNotNil: [ :testMethodName | - testClass compiledMethodAt: testMethodName asSymbol ifAbsent: [ - MCPCommandError - signalMissingMethodInClassName: each className - classSide: false - selector: testMethodName ] ]. - MCPValidatedTestRunRequest request: each testClass: testClass ] + each isPackageRequest + ifTrue: [ + self testClassesInPackageNamed: each packageName. + MCPValidatedTestRunRequest request: each testClass: nil ] + ifFalse: [ + | testClass | + testClass := MCPImageLookup classNamed: each className. + each testMethodName ifNotNil: [ :testMethodName | + testClass + compiledMethodAt: testMethodName asSymbol + ifAbsent: [ + MCPCommandError + signalMissingMethodInClassName: each className + classSide: false + selector: testMethodName ] ]. + MCPValidatedTestRunRequest request: each testClass: testClass ] ] ] diff --git a/src/MCP/MCPRunTestsRequest.class.st b/src/MCP/MCPRunTestsRequest.class.st index b4c3805..eae5011 100644 --- a/src/MCP/MCPRunTestsRequest.class.st +++ b/src/MCP/MCPRunTestsRequest.class.st @@ -1,5 +1,7 @@ " -Parsed request for the shared test runner command. It contains parsed test requests, the timeout converted to milliseconds, and the internal operation selected by the concrete tool. Coverage requests are supplied by MCPToolRunTestCoverage. +Parsed request shared by test_run and test_coverage_run. + +It stores compact test selections, timeout converted to milliseconds, and the internal operation selected by the concrete tool. Coverage requests are supplied by MCPToolRunTestCoverage. " Class { #name : 'MCPRunTestsRequest', @@ -15,12 +17,34 @@ Class { #tag : 'Requests' } +{ #category : 'private - parsing' } +MCPRunTestsRequest class >> addClassNames: classNames to: requests [ + + classNames do: [ :className | + requests add: (MCPTestRunRequest className: className) ] +] + +{ #category : 'private - parsing' } +MCPRunTestsRequest class >> addMethodReferences: methodReferences to: requests [ + + methodReferences do: [ :methodReference | + requests add: + (MCPTestRunRequest fromMethodReference: methodReference) ] +] + +{ #category : 'private - parsing' } +MCPRunTestsRequest class >> addPackageNames: packageNames to: requests [ + + packageNames do: [ :packageName | + requests add: (MCPTestRunRequest packageName: packageName) ] +] + { #category : 'instance creation' } MCPRunTestsRequest class >> fromRequest: aRequest tool: aTool operation: operation [ | coverageRequest | (#( 'run' 'coverage' ) includes: operation) ifFalse: [ - Error signal: 'operation must be one of run or coverage.' ]. + Error signal: 'operation must be run or coverage.' ]. coverageRequest := operation = 'coverage' ifTrue: [ MCPTestCoverageRequest fromValue: @@ -43,26 +67,31 @@ MCPRunTestsRequest class >> fromRequest: aRequest tool: aTool operation: operati { #category : 'private - parsing' } MCPRunTestsRequest class >> testRequestsFromToolRequest: request [ - | requests | - requests := request objectCollectionArgumentNamed: 'tests'. + | classNames methodReferences packageNames requests | + packageNames := request + uniqueStringCollectionArgumentNamed: 'packages' + default: #( ). + classNames := request + uniqueStringCollectionArgumentNamed: 'classes' + default: #( ). + methodReferences := request + uniqueStringCollectionArgumentNamed: 'methods' + default: #( ). + (packageNames isEmpty and: [ + classNames isEmpty and: [ methodReferences isEmpty ] ]) ifTrue: [ + Error signal: 'Provide at least one package, class, or method.' ]. + requests := OrderedCollection new. + self addPackageNames: packageNames to: requests. + self addClassNames: classNames to: requests. + self addMethodReferences: methodReferences to: requests. requests ifEmpty: [ - Error signal: 'tests must contain at least one test request.' ]. - ^ (requests collect: [ :each | - MCPTestRunRequest fromValue: each usingToolRequest: request ]) - asArray + Error signal: 'No test classes or methods matched request.' ]. + ^ requests asArray ] { #category : 'private - parsing' } MCPRunTestsRequest class >> timeoutMillisecondsFromToolRequest: request defaultSeconds: defaultSeconds [ - ((request hasArgumentNamed: 'timeoutSeconds') and: [ - request hasArgumentNamed: 'timeoutMilliseconds' ]) ifTrue: [ - Error signal: - 'timeoutSeconds and timeoutMilliseconds cannot both be provided.' ]. - (request hasArgumentNamed: 'timeoutMilliseconds') ifTrue: [ - ^ request - nonNegativeIntegerArgumentNamed: 'timeoutMilliseconds' - default: defaultSeconds * 1000 ]. ^ (request nonNegativeIntegerArgumentNamed: 'timeoutSeconds' default: defaultSeconds) * 1000 diff --git a/src/MCP/MCPRunTestsResult.class.st b/src/MCP/MCPRunTestsResult.class.st index 74080a8..eaf231a 100644 --- a/src/MCP/MCPRunTestsResult.class.st +++ b/src/MCP/MCPRunTestsResult.class.st @@ -1,11 +1,11 @@ " -Aggregate result DTO produced by the test_run command. +Aggregate result DTO produced by test_run. -It carries structured per-selection results plus timeout state and unrun MCPTestRunRequest objects for resumable output. Coverage operation results additionally attach an MCPTestCoverageResult. +It exposes compact public output: aggregate counts, compact failure/error details, skipped test references, timeout leftovers, and optional coverage. " Class { #name : 'MCPRunTestsResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'results', 'timedOut', @@ -29,14 +29,46 @@ MCPRunTestsResult class >> results: resultCollection timedOut: aBoolean unrunTes { #category : 'converting' } MCPRunTestsResult >> asDictionary [ - | data | + | data errors failures skipped unrunClasses unrunMethods unrunPackages | data := Dictionary new. - data at: #results put: self resultDictionaries. + data at: #runCount put: self runCount. + data at: #passedCount put: self passedCount. + skipped := self skippedTestReferences. + skipped ifNotEmpty: [ data at: #skipped put: skipped ]. + failures := self failureDictionaries. + failures ifNotEmpty: [ data at: #failures put: failures ]. + errors := self errorDictionaries. + errors ifNotEmpty: [ data at: #errors put: errors ]. self coverage ifNotNil: [ :coverageResult | data at: #coverage put: coverageResult asDictionary ]. self timedOut ifTrue: [ - data at: #timedOut put: true. - data at: #unrunTests put: self unrunTestDictionaries ]. + data at: #timedOut put: true. + unrunPackages := self unrunPackageNames. + unrunPackages ifNotEmpty: [ + data at: #unrunPackages put: unrunPackages ]. + unrunClasses := self unrunClassNames. + unrunClasses ifNotEmpty: [ + data at: #unrunClasses put: unrunClasses ]. + unrunMethods := self unrunMethodReferences. + unrunMethods ifNotEmpty: [ + data at: #unrunMethods put: unrunMethods ] ]. + ^ data +] + +{ #category : 'converting' } +MCPRunTestsResult >> compactIssueFor: issue [ + + | data | + data := Dictionary new. + data at: #test put: (self testReferenceForIssue: issue). + issue at: #message ifPresent: [ :message | + message isEmpty ifFalse: [ data at: #message put: message ] ]. + (issue at: #kind ifAbsent: [ nil ]) = 'error' ifTrue: [ + issue + at: #errorClass + ifPresent: [ :className | data at: #errorClass put: className ] ]. + issue at: #parameters ifPresent: [ :parameters | + parameters ifNotEmpty: [ data at: #parameters put: parameters ] ]. ^ data ] @@ -52,6 +84,22 @@ MCPRunTestsResult >> coverage: aCoverageResult [ coverage := aCoverageResult ] +{ #category : 'converting' } +MCPRunTestsResult >> errorDictionaries [ + + ^ Array streamContents: [ :stream | + (self issuesOfKind: 'error') do: [ :issue | + stream nextPut: (self compactIssueFor: issue) ] ] +] + +{ #category : 'converting' } +MCPRunTestsResult >> failureDictionaries [ + + ^ Array streamContents: [ :stream | + (self issuesOfKind: 'failure') do: [ :issue | + stream nextPut: (self compactIssueFor: issue) ] ] +] + { #category : 'initialization' } MCPRunTestsResult >> initializeResults: resultCollection timedOut: aBoolean unrunTests: testCollection [ @@ -61,6 +109,24 @@ MCPRunTestsResult >> initializeResults: resultCollection timedOut: aBoolean unru ^ self ] +{ #category : 'converting' } +MCPRunTestsResult >> issuesOfKind: issueKind [ + + ^ Array streamContents: [ :stream | + self results do: [ :resultInfo | + resultInfo issues do: [ :issue | + (issue at: #kind ifAbsent: [ nil ]) = issueKind ifTrue: [ + stream nextPut: issue ] ] ] ] +] + +{ #category : 'converting' } +MCPRunTestsResult >> passedCount [ + + ^ self results + inject: 0 + into: [ :sum :each | sum + each passedCount ] +] + { #category : 'converting' } MCPRunTestsResult >> resultDictionaries [ @@ -73,12 +139,73 @@ MCPRunTestsResult >> results [ ^ results ] +{ #category : 'converting' } +MCPRunTestsResult >> runCount [ + + ^ self results inject: 0 into: [ :sum :each | sum + each runCount ] +] + +{ #category : 'converting' } +MCPRunTestsResult >> skippedTestReferences [ + + ^ self uniqueStringsFrom: + ((self issuesOfKind: 'skipped') collect: [ :issue | + self testReferenceForIssue: issue ]) +] + +{ #category : 'converting' } +MCPRunTestsResult >> testReferenceForIssue: issue [ + + ^ (issue at: #className) asString , '>>#' + , (issue at: #testMethodName) asString +] + { #category : 'accessing' } MCPRunTestsResult >> timedOut [ ^ timedOut ] +{ #category : 'converting' } +MCPRunTestsResult >> uniqueStringsFrom: strings [ + + | seen | + seen := Set new. + ^ Array streamContents: [ :stream | + strings do: [ :each | + (seen includes: each) ifFalse: [ + seen add: each. + stream nextPut: each ] ] ] +] + +{ #category : 'converting' } +MCPRunTestsResult >> unrunClassNames [ + + ^ self uniqueStringsFrom: (Array streamContents: [ :stream | + self unrunTests do: [ :request | + (request isPackageRequest not and: [ + request hasTestMethod not ]) ifTrue: [ + stream nextPut: request className ] ] ]) +] + +{ #category : 'converting' } +MCPRunTestsResult >> unrunMethodReferences [ + + ^ self uniqueStringsFrom: (Array streamContents: [ :stream | + self unrunTests do: [ :request | + request hasTestMethod ifTrue: [ + stream nextPut: request displayName ] ] ]) +] + +{ #category : 'converting' } +MCPRunTestsResult >> unrunPackageNames [ + + ^ self uniqueStringsFrom: (Array streamContents: [ :stream | + self unrunTests do: [ :request | + request isPackageRequest ifTrue: [ + stream nextPut: request packageName ] ] ]) +] + { #category : 'converting' } MCPRunTestsResult >> unrunTestDictionaries [ diff --git a/src/MCP/MCPScopeNameSuggester.class.st b/src/MCP/MCPScopeNameSuggester.class.st index b90b370..5120699 100644 --- a/src/MCP/MCPScopeNameSuggester.class.st +++ b/src/MCP/MCPScopeNameSuggester.class.st @@ -6,9 +6,9 @@ It scores nearby names and limits repeated suggestions from the same package or Class { #name : 'MCPScopeNameSuggester', #superclass : 'Object', - #category : 'MCP-Queries', + #category : 'MCP-Utilities', #package : 'MCP', - #tag : 'Queries' + #tag : 'Utilities' } { #category : 'suggesting' } @@ -33,9 +33,9 @@ MCPScopeNameSuggester class >> classSuggestionCandidates [ | candidates | candidates := OrderedCollection new. Smalltalk globals allClasses do: [ :eachClass | - candidates add: { - (#name -> eachClass name asString). - (#bucket -> eachClass package name asString) } asDictionary ]. + candidates add: { + (#name -> eachClass name asString). + (#bucket -> eachClass package name asString) } asDictionary ]. ^ candidates asArray ] @@ -62,18 +62,20 @@ MCPScopeNameSuggester class >> editDistanceBetween: leftString and: rightString rightString isEmpty ifTrue: [ ^ leftString size ]. previous := (0 to: rightString size) asArray. 1 to: leftString size do: [ :leftIndex | - current := Array new: rightString size + 1. - current at: 1 put: leftIndex. - 1 to: rightString size do: [ :rightIndex | - | cost delete insert replace | - cost := (leftString at: leftIndex) = (rightString at: rightIndex) - ifTrue: [ 0 ] - ifFalse: [ 1 ]. - delete := (previous at: rightIndex + 1) + 1. - insert := (current at: rightIndex) + 1. - replace := (previous at: rightIndex) + cost. - current at: rightIndex + 1 put: ((delete min: insert) min: replace) ]. - previous := current ]. + current := Array new: rightString size + 1. + current at: 1 put: leftIndex. + 1 to: rightString size do: [ :rightIndex | + | cost delete insert replace | + cost := (leftString at: leftIndex) = (rightString at: rightIndex) + ifTrue: [ 0 ] + ifFalse: [ 1 ]. + delete := (previous at: rightIndex + 1) + 1. + insert := (current at: rightIndex) + 1. + replace := (previous at: rightIndex) + cost. + current + at: rightIndex + 1 + put: ((delete min: insert) min: replace) ]. + previous := current ]. ^ previous last ] @@ -91,19 +93,19 @@ MCPScopeNameSuggester class >> missingClassWarningFor: className scope: scopeNam MCPScopeNameSuggester class >> missingNameWarningForKind: kind name: missingName scope: scopeName suggestions: suggestions [ ^ String streamContents: [ :stream | - stream - nextPutAll: kind; - space; - nextPutAll: missingName asString; - nextPutAll: ' does not exist in '; - nextPutAll: scopeName asString; - nextPutAll: ' scope.'. - suggestions ifNotEmpty: [ - stream nextPutAll: ' Did you mean: '. - suggestions - do: [ :each | stream nextPutAll: each ] - separatedBy: [ stream nextPutAll: ', ' ]. - stream nextPut: $. ] ] + stream + nextPutAll: kind; + space; + nextPutAll: missingName asString; + nextPutAll: ' does not exist in '; + nextPutAll: scopeName asString; + nextPutAll: ' scope.'. + suggestions ifNotEmpty: [ + stream nextPutAll: ' Did you mean: '. + suggestions + do: [ :each | stream nextPutAll: each ] + separatedBy: [ stream nextPutAll: ', ' ]. + stream nextPut: $. ] ] ] { #category : 'warnings' } @@ -120,9 +122,9 @@ MCPScopeNameSuggester class >> missingPackageWarningFor: packageName scope: scop MCPScopeNameSuggester class >> packageSuggestionCandidates [ ^ PackageOrganizer default packages collect: [ :eachPackage | - { - (#name -> eachPackage name asString). - (#bucket -> eachPackage name asString) } asDictionary ] + { + (#name -> eachPackage name asString). + (#bucket -> eachPackage name asString) } asDictionary ] ] { #category : 'suggesting' } @@ -162,36 +164,36 @@ MCPScopeNameSuggester class >> suggestionsFor: requestedName candidates: candida matchesRequested: requestedName ]. filtered isEmpty ifTrue: [ ^ #( ) ]. scored := filtered collect: [ :eachCandidate | - eachCandidate copy - at: #score put: (self - scoreForRequested: requestedName - candidate: (eachCandidate at: #name)); - yourself ]. + eachCandidate copy + at: #score put: (self + scoreForRequested: requestedName + candidate: (eachCandidate at: #name)); + yourself ]. sorted := scored asSortedCollection: [ :left :right | - (left at: #score) = (right at: #score) - ifTrue: [ (left at: #name) <= (right at: #name) ] - ifFalse: [ (left at: #score) < (right at: #score) ] ]. + (left at: #score) = (right at: #score) + ifTrue: [ (left at: #name) <= (right at: #name) ] + ifFalse: [ (left at: #score) < (right at: #score) ] ]. chosen := OrderedCollection new. chosenNames := Set new. bucketCounts := Dictionary new. sorted do: [ :eachCandidate | - chosen size < maxCount ifTrue: [ - | bucket count candidateName | - candidateName := eachCandidate at: #name. - bucket := eachCandidate at: #bucket ifAbsent: [ '' ]. - count := bucketCounts at: bucket ifAbsent: [ 0 ]. - (count < 2 and: [ (chosenNames includes: candidateName) not ]) - ifTrue: [ - chosen add: candidateName. - chosenNames add: candidateName. - bucketCounts at: bucket put: count + 1 ] ] ]. - chosen size < maxCount ifTrue: [ - sorted do: [ :eachCandidate | chosen size < maxCount ifTrue: [ - | candidateName | - candidateName := eachCandidate at: #name. - (chosenNames includes: candidateName) ifFalse: [ - chosen add: candidateName. - chosenNames add: candidateName ] ] ] ]. + | bucket count candidateName | + candidateName := eachCandidate at: #name. + bucket := eachCandidate at: #bucket ifAbsent: [ '' ]. + count := bucketCounts at: bucket ifAbsent: [ 0 ]. + (count < 2 and: [ (chosenNames includes: candidateName) not ]) + ifTrue: [ + chosen add: candidateName. + chosenNames add: candidateName. + bucketCounts at: bucket put: count + 1 ] ] ]. + chosen size < maxCount ifTrue: [ + sorted do: [ :eachCandidate | + chosen size < maxCount ifTrue: [ + | candidateName | + candidateName := eachCandidate at: #name. + (chosenNames includes: candidateName) ifFalse: [ + chosen add: candidateName. + chosenNames add: candidateName ] ] ] ]. ^ chosen asArray ] diff --git a/src/MCP/MCPScopeQuery.class.st b/src/MCP/MCPScopeQuery.class.st new file mode 100644 index 0000000..e9423d3 --- /dev/null +++ b/src/MCP/MCPScopeQuery.class.st @@ -0,0 +1,158 @@ +" +Abstract query over named class/package scopes. + +Subclasses add the concrete entity lookup, but common scope names, completeness handling, and missing-name warnings live here. +" +Class { + #name : 'MCPScopeQuery', + #superclass : 'Object', + #instVars : [ + 'packageNames', + 'classNames', + 'hierarchyClassNames', + 'subclassClassNames', + 'parentClassNames', + 'warnings', + 'requiresCompleteScope' + ], + #category : 'MCP-Queries', + #package : 'MCP', + #tag : 'Queries' +} + +{ #category : 'accessing' } +MCPScopeQuery >> classNames [ + + ^ classNames ifNil: [ #( ) ] +] + +{ #category : 'accessing' } +MCPScopeQuery >> classNames: aCollection [ + + classNames := aCollection +] + +{ #category : 'accessing' } +MCPScopeQuery >> hierarchyClassNames [ + + ^ hierarchyClassNames ifNil: [ #( ) ] +] + +{ #category : 'accessing' } +MCPScopeQuery >> hierarchyClassNames: aCollection [ + + hierarchyClassNames := aCollection +] + +{ #category : 'accessing' } +MCPScopeQuery >> packageNames [ + + ^ packageNames ifNil: [ #( ) ] +] + +{ #category : 'accessing' } +MCPScopeQuery >> packageNames: aCollection [ + + packageNames := aCollection +] + +{ #category : 'accessing' } +MCPScopeQuery >> parentClassNames [ + + ^ parentClassNames ifNil: [ #( ) ] +] + +{ #category : 'accessing' } +MCPScopeQuery >> parentClassNames: aCollection [ + + parentClassNames := aCollection +] + +{ #category : 'private - resolution' } +MCPScopeQuery >> recordMissingClassNamed: className inScope: scopeName [ + + | suggestions | + suggestions := MCPScopeNameSuggester classSuggestionsFor: className. + self requiresCompleteScope ifTrue: [ + ^ MCPCommandError + signalMissingClassNamed: className + scopeName: scopeName ]. + warnings ifNil: [ self resetWarnings ]. + warnings add: (MCPScopeNameSuggester + missingNameWarningForKind: 'Class' + name: className + scope: scopeName + suggestions: suggestions). + ^ nil +] + +{ #category : 'private - resolution' } +MCPScopeQuery >> recordMissingPackageNamed: packageName inScope: scopeName [ + + | suggestions | + suggestions := MCPScopeNameSuggester packageSuggestionsFor: + packageName. + self requiresCompleteScope ifTrue: [ + ^ MCPCommandError + signalMissingPackageNamed: packageName + scopeName: scopeName ]. + warnings ifNil: [ self resetWarnings ]. + warnings add: (MCPScopeNameSuggester + missingNameWarningForKind: 'Package' + name: packageName + scope: scopeName + suggestions: suggestions). + ^ nil +] + +{ #category : 'configuring' } +MCPScopeQuery >> requireCompleteScope [ + + self requiresCompleteScope: true +] + +{ #category : 'accessing' } +MCPScopeQuery >> requiresCompleteScope [ + + ^ requiresCompleteScope ifNil: [ false ] +] + +{ #category : 'accessing' } +MCPScopeQuery >> requiresCompleteScope: aBoolean [ + + requiresCompleteScope := aBoolean +] + +{ #category : 'private - resolution' } +MCPScopeQuery >> resetWarnings [ + + warnings := OrderedCollection new +] + +{ #category : 'accessing' } +MCPScopeQuery >> subclassClassNames [ + + ^ subclassClassNames ifNil: [ #( ) ] +] + +{ #category : 'accessing' } +MCPScopeQuery >> subclassClassNames: aCollection [ + + subclassClassNames := aCollection +] + +{ #category : 'private - source' } +MCPScopeQuery >> usesImplicitImageScope [ + + ^ self packageNames isEmpty and: [ + self classNames isEmpty and: [ + self hierarchyClassNames isEmpty and: [ + self subclassClassNames isEmpty and: [ + self parentClassNames isEmpty ] ] ] ] +] + +{ #category : 'accessing' } +MCPScopeQuery >> warnings [ + + ^ warnings ifNil: [ #( ) ] +] diff --git a/src/MCP/MCPScreenshotCommand.class.st b/src/MCP/MCPScreenshotCommand.class.st index 4c95335..d9aa228 100644 --- a/src/MCP/MCPScreenshotCommand.class.st +++ b/src/MCP/MCPScreenshotCommand.class.st @@ -5,10 +5,8 @@ It supports the world target and uses an injectable form provider so tests can e " Class { #name : 'MCPScreenshotCommand', - #superclass : 'Object', + #superclass : 'MCPToolRequestCommand', #instVars : [ - 'tool', - 'request', 'formProvider' ], #category : 'MCP-Commands', @@ -72,20 +70,6 @@ MCPScreenshotCommand >> formProvider [ { #category : 'initialization' } MCPScreenshotCommand >> initializeTool: aTool request: aRequest formProvider: aBlock [ - tool := aTool. - request := aRequest. - formProvider := aBlock ifNil: [ [ self captureWorldForm ] ]. - ^ self -] - -{ #category : 'accessing' } -MCPScreenshotCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPScreenshotCommand >> tool [ - - ^ tool + super initializeTool: aTool request: aRequest. + formProvider := aBlock ifNil: [ [ self captureWorldForm ] ] ] diff --git a/src/MCP/MCPScreenshotResult.class.st b/src/MCP/MCPScreenshotResult.class.st index b8122fa..011cbca 100644 --- a/src/MCP/MCPScreenshotResult.class.st +++ b/src/MCP/MCPScreenshotResult.class.st @@ -5,7 +5,7 @@ It keeps the MCP image content block separate from the structured metadata so to " Class { #name : 'MCPScreenshotResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'target', 'width', diff --git a/src/MCP/MCPSearchToolCommand.class.st b/src/MCP/MCPSearchToolCommand.class.st index 190a868..b1f16c5 100644 --- a/src/MCP/MCPSearchToolCommand.class.st +++ b/src/MCP/MCPSearchToolCommand.class.st @@ -3,51 +3,14 @@ Command object used by search tools. It executes a parsed search request against " Class { #name : 'MCPSearchToolCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPSearchToolCommand class >> tool: aTool request: aRequest [ - - ^ self new - tool: aTool; - request: aRequest; - yourself -] - { #category : 'executing' } MCPSearchToolCommand >> execute [ ^ tool queryEntriesForQueryRequest: request ] - -{ #category : 'accessing' } -MCPSearchToolCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPSearchToolCommand >> request: anObject [ - - request := anObject -] - -{ #category : 'accessing' } -MCPSearchToolCommand >> tool [ - - ^ tool -] - -{ #category : 'accessing' } -MCPSearchToolCommand >> tool: anObject [ - - tool := anObject -] diff --git a/src/MCP/MCPSearchToolsCommand.class.st b/src/MCP/MCPSearchToolsCommand.class.st index 601363f..c41a294 100644 --- a/src/MCP/MCPSearchToolsCommand.class.st +++ b/src/MCP/MCPSearchToolsCommand.class.st @@ -5,12 +5,7 @@ This command supports the discoverable-tool workflow: agents can search by text " Class { #name : 'MCPSearchToolsCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request', - 'toolExposurePolicy' - ], + #superclass : 'MCPToolCatalogCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' @@ -25,16 +20,6 @@ MCPSearchToolsCommand class >> tool: aTool request: aRequest [ toolExposurePolicy: MCPToolExposurePolicy default ] -{ #category : 'instance creation' } -MCPSearchToolsCommand class >> tool: aTool request: aRequest toolExposurePolicy: aToolExposurePolicy [ - - ^ self new - tool: aTool; - request: aRequest; - toolExposurePolicy: aToolExposurePolicy; - yourself -] - { #category : 'executing' } MCPSearchToolsCommand >> execute [ @@ -50,40 +35,3 @@ MCPSearchToolsCommand >> execute [ usingPolicy: self toolExposurePolicy ]) asArray) } asDictionary ] - -{ #category : 'accessing' } -MCPSearchToolsCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPSearchToolsCommand >> request: anObject [ - - request := anObject -] - -{ #category : 'accessing' } -MCPSearchToolsCommand >> tool [ - - ^ tool -] - -{ #category : 'accessing' } -MCPSearchToolsCommand >> tool: anObject [ - - tool := anObject -] - -{ #category : 'accessing' } -MCPSearchToolsCommand >> toolExposurePolicy [ - - ^ toolExposurePolicy ifNil: [ MCPToolExposurePolicy default ] -] - -{ #category : 'accessing' } -MCPSearchToolsCommand >> toolExposurePolicy: aToolExposurePolicy [ - - toolExposurePolicy := aToolExposurePolicy ifNil: [ - MCPToolExposurePolicy default ] -] diff --git a/src/MCP/MCPSlotResult.class.st b/src/MCP/MCPSlotResult.class.st index ec81670..aaed110 100644 --- a/src/MCP/MCPSlotResult.class.st +++ b/src/MCP/MCPSlotResult.class.st @@ -3,7 +3,7 @@ Captures the updated class state after a slot update. " Class { #name : 'MCPSlotResult', - #superclass : 'Object', + #superclass : 'MCPClassResult', #instVars : [ 'classInfo', 'slotName', @@ -28,7 +28,7 @@ MCPSlotResult class >> classInfo: aClassInfo slotName: aSlotName classSide: aBoo MCPSlotResult >> asDictionary [ | data | - data := self classInfo asDictionary copy. + data := self newClassInfoDictionary. data at: #slotName put: self slotName. data at: #classSide put: self classSide. ^ data diff --git a/src/MCP/MCPStructureInitialize.class.st b/src/MCP/MCPStructureInitialize.class.st index ad70305..73a4e4e 100644 --- a/src/MCP/MCPStructureInitialize.class.st +++ b/src/MCP/MCPStructureInitialize.class.st @@ -22,9 +22,9 @@ MCPStructureInitialize >> asJRPCJSON [ | dic | dic := { - (#capabilities -> self capabilities asJRPCJSON). - (#protocolVersion -> self protocolVersion asJRPCJSON). - (#serverInfo -> self serverInfo asJRPCJSON) } asDictionary. + (#capabilities -> self capabilities asJRPCJSON). + (#protocolVersion -> self protocolVersion asJRPCJSON). + (#serverInfo -> self serverInfo asJRPCJSON) } asDictionary. self metadata ifNotNil: [ dic at: #_meta put: self metadata asJRPCJSON ]. ^ dic diff --git a/src/MCP/MCPStructuredTestResult.class.st b/src/MCP/MCPStructuredTestResult.class.st index 6343d4e..f1fbf8a 100644 --- a/src/MCP/MCPStructuredTestResult.class.st +++ b/src/MCP/MCPStructuredTestResult.class.st @@ -74,15 +74,15 @@ MCPStructuredTestResult >> recordIssueFrom: anException forTestCase: aTestCase [ MCPStructuredTestResult >> runCase: aTestCase [ [ - aTestCase announce: TestCaseStarted withResult: self. - aTestCase runCaseManaged. - aTestCase announce: TestCaseEnded withResult: self. - self addPass: aTestCase ] + aTestCase announce: TestCaseStarted withResult: self. + aTestCase runCaseManaged. + aTestCase announce: TestCaseEnded withResult: self. + self addPass: aTestCase ] on: self class failure , self class skip , self class warning , self class error do: [ :ex | - ex sunitAnnounce: aTestCase toResult: self. - self recordIssueFrom: ex forTestCase: aTestCase ] + ex sunitAnnounce: aTestCase toResult: self. + self recordIssueFrom: ex forTestCase: aTestCase ] ] { #category : 'private' } diff --git a/src/MCP/MCPSwitchRepositoryBranchCommand.class.st b/src/MCP/MCPSwitchRepositoryBranchCommand.class.st index 298c048..e6f8276 100644 --- a/src/MCP/MCPSwitchRepositoryBranchCommand.class.st +++ b/src/MCP/MCPSwitchRepositoryBranchCommand.class.st @@ -3,65 +3,33 @@ Command wrapper for repository_branch_switch. It calls IceRepository>>switchToBr " Class { #name : 'MCPSwitchRepositoryBranchCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPRepositoryCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPSwitchRepositoryBranchCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'executing' } MCPSwitchRepositoryBranchCommand >> execute [ | beforeInfo repository result | - ^ self tool - executeMutationAction: 'switchBranch' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'switchBranch' work: [ - repository := self request repository. - beforeInfo := MCPRepositoryInfo fromRepository: repository. - repository switchToBranchNamed: self request branchName. - result := MCPRepositoryBranchResult - repositoryBefore: beforeInfo - after: repository ] + repository := self request repository. + beforeInfo := MCPRepositoryInfo fromRepository: repository. + repository switchToBranchNamed: self request branchName. + result := MCPRepositoryBranchResult + repositoryBefore: beforeInfo + after: repository ] successResult: [ :warningMessages | - self tool - successResultText: - 'Switched repository ' , result repositoryInfo name - , ' to branch ' , self request branchName , '.' - data: (self tool dataForRepositorySwitchBranchResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Switched repository ' , result repositoryInfo name + , ' branch ' , self request branchName , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to switch repository branch: ' - , (error messageText ifNil: [ error asString ]) ] -] - -{ #category : 'initialization' } -MCPSwitchRepositoryBranchCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self -] - -{ #category : 'accessing' } -MCPSwitchRepositoryBranchCommand >> request [ - - ^ request -] - -{ #category : 'accessing' } -MCPSwitchRepositoryBranchCommand >> tool [ - - ^ tool + 'Failed to switch repository branch: ' + , (error messageText ifNil: [ error asString ]) ] ] diff --git a/src/MCP/MCPTestCoverageResult.class.st b/src/MCP/MCPTestCoverageResult.class.st index 7543fa1..8dafb83 100644 --- a/src/MCP/MCPTestCoverageResult.class.st +++ b/src/MCP/MCPTestCoverageResult.class.st @@ -3,7 +3,7 @@ Structured coverage result DTO returned by test_coverage_run. " Class { #name : 'MCPTestCoverageResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'coverageResult', 'includeCoveredMethods', @@ -61,12 +61,12 @@ MCPTestCoverageResult >> asDictionary [ at: #partiallyCoveredMethodsTruncated put: (self isListTruncated: partialMethods). self includeCoveredMethods ifTrue: [ - data - at: #coveredMethods - put: (self methodDictionariesFor: coveredMethods). - data - at: #coveredMethodsTruncated - put: (self isListTruncated: coveredMethods) ]. + data + at: #coveredMethods + put: (self methodDictionariesFor: coveredMethods). + data + at: #coveredMethodsTruncated + put: (self isListTruncated: coveredMethods) ]. ^ data ] @@ -149,12 +149,12 @@ MCPTestCoverageResult >> methodLimit [ MCPTestCoverageResult >> methodSortKeyFor: aCompiledMethod [ ^ String streamContents: [ :stream | - stream nextPutAll: aCompiledMethod methodClass instanceSide name. - aCompiledMethod methodClass isMeta ifTrue: [ - stream nextPutAll: ' class' ]. - stream - nextPutAll: '>>'; - nextPutAll: aCompiledMethod selector asString ] + stream nextPutAll: aCompiledMethod methodClass instanceSide name. + aCompiledMethod methodClass isMeta ifTrue: [ + stream nextPutAll: ' class' ]. + stream + nextPutAll: '>>'; + nextPutAll: aCompiledMethod selector asString ] ] { #category : 'private - coverage' } diff --git a/src/MCP/MCPTestRunInfo.class.st b/src/MCP/MCPTestRunInfo.class.st index 669844e..3cfc0a1 100644 --- a/src/MCP/MCPTestRunInfo.class.st +++ b/src/MCP/MCPTestRunInfo.class.st @@ -1,11 +1,11 @@ " -DTO for one completed test_run selection. +Internal DTO for one executed test_run selection. -It records the selected test class or method, the number of executed tests, and structured issue dictionaries captured during the run. +It records counts and normalized issue dictionaries so MCPRunTestsResult can build compact aggregate output. " Class { #name : 'MCPTestRunInfo', - #superclass : 'Object', + #superclass : 'MCPDataTransferObject', #instVars : [ 'className', 'testMethodName', diff --git a/src/MCP/MCPTestRunRequest.class.st b/src/MCP/MCPTestRunRequest.class.st index 0c80fba..d9dae67 100644 --- a/src/MCP/MCPTestRunRequest.class.st +++ b/src/MCP/MCPTestRunRequest.class.st @@ -1,12 +1,13 @@ " -Parsed request DTO for one test_run selection. +Parsed test_run selection. -It represents either a full test class run or one specific test method inside the batch. +A request represents one package, one whole test class, or one test method. Package selections remain package requests until execution so timeout reporting can distinguish unentered packages from interrupted classes. " Class { #name : 'MCPTestRunRequest', #superclass : 'Object', #instVars : [ + 'packageName', 'className', 'testMethodName' ], @@ -15,34 +16,56 @@ Class { #tag : 'Requests' } +{ #category : 'instance creation' } +MCPTestRunRequest class >> className: aClassName [ + + ^ self className: aClassName testMethodName: nil +] + { #category : 'instance creation' } MCPTestRunRequest class >> className: aClassName testMethodName: aTestMethodName [ ^ self new - initializeClassName: aClassName + initializePackageName: nil + className: aClassName testMethodName: aTestMethodName ] { #category : 'instance creation' } -MCPTestRunRequest class >> fromValue: rawValue usingToolRequest: toolRequest [ - - | className testMethodName | - className := toolRequest - stringArgumentNamed: 'className' - in: rawValue. - className ifNil: [ - Error signal: 'tests must contain only non-empty class names.' ]. - testMethodName := toolRequest - stringArgumentNamed: 'testMethodName' - in: rawValue. - ^ self className: className testMethodName: testMethodName +MCPTestRunRequest class >> fromMethodReference: aString [ + + | className delimiterIndex selector | + delimiterIndex := aString findString: '>>' startingAt: 1. + delimiterIndex isZero ifTrue: [ + Error signal: 'methods must use Class>>#selector references.' ]. + className := (aString copyFrom: 1 to: delimiterIndex - 1) trimBoth. + selector := (aString copyFrom: delimiterIndex + 2 to: aString size) + trimBoth. + (selector notEmpty and: [ selector first = $# ]) ifTrue: [ + selector := selector allButFirst ]. + (className isEmpty or: [ selector isEmpty ]) ifTrue: [ + Error signal: 'methods must use Class>>#selector references.' ]. + ^ self className: className testMethodName: selector +] + +{ #category : 'instance creation' } +MCPTestRunRequest class >> packageName: aPackageName [ + + ^ self new + initializePackageName: aPackageName + className: nil + testMethodName: nil ] { #category : 'converting' } MCPTestRunRequest >> asDictionary [ | data | - data := { (#className -> self className) } asDictionary. + data := Dictionary new. + self isPackageRequest ifTrue: [ + data at: #packageName put: self packageName. + ^ data ]. + data at: #className put: self className. self testMethodName ifNotNil: [ data at: #testMethodName put: self testMethodName ]. ^ data @@ -54,12 +77,13 @@ MCPTestRunRequest >> className [ ^ className ] -{ #category : 'printing' } +{ #category : 'accessing' } MCPTestRunRequest >> displayName [ + self isPackageRequest ifTrue: [ ^ self packageName ]. ^ self testMethodName ifNil: [ self className ] - ifNotNil: [ :methodName | self className , '>>' , methodName ] + ifNotNil: [ :methodName | self className , '>>#' , methodName ] ] { #category : 'testing' } @@ -71,9 +95,30 @@ MCPTestRunRequest >> hasTestMethod [ { #category : 'initialization' } MCPTestRunRequest >> initializeClassName: aClassName testMethodName: aTestMethodName [ + self + initializePackageName: nil + className: aClassName + testMethodName: aTestMethodName +] + +{ #category : 'initialization' } +MCPTestRunRequest >> initializePackageName: aPackageName className: aClassName testMethodName: aTestMethodName [ + + packageName := aPackageName. className := aClassName. - testMethodName := aTestMethodName. - ^ self + testMethodName := aTestMethodName +] + +{ #category : 'testing' } +MCPTestRunRequest >> isPackageRequest [ + + ^ self packageName notNil +] + +{ #category : 'accessing' } +MCPTestRunRequest >> packageName [ + + ^ packageName ] { #category : 'printing' } diff --git a/src/MCP/MCPTestRunResult.class.st b/src/MCP/MCPTestRunResult.class.st index e631078..b2bb2fa 100644 --- a/src/MCP/MCPTestRunResult.class.st +++ b/src/MCP/MCPTestRunResult.class.st @@ -5,7 +5,7 @@ It carries the structured result entry when any tests ran, timeout state, and re " Class { #name : 'MCPTestRunResult', - #superclass : 'Object', + #superclass : 'MCPResult', #instVars : [ 'timedOut', 'unrunTestRequests', diff --git a/src/MCP/MCPTool.class.st b/src/MCP/MCPTool.class.st index 2ea528f..dcc79e3 100644 --- a/src/MCP/MCPTool.class.st +++ b/src/MCP/MCPTool.class.st @@ -234,8 +234,8 @@ MCPTool >> executeParsedRequestFrom: request do: executionBlock onError: errorBl | parsedRequest | ^ [ - parsedRequest := self parsedRequestFromToolRequest: request. - executionBlock value: parsedRequest ] + parsedRequest := self parsedRequestFromToolRequest: request. + executionBlock value: parsedRequest ] on: Exception do: [ :error | errorBlock value: error value: parsedRequest ] ] @@ -260,16 +260,16 @@ MCPTool >> failureMessageFor: anError [ ifNil: [ '' ] ifNotNil: [ :text | text asString ]. ^ String streamContents: [ :stream | - stream - nextPutAll: 'Tool '; - nextPutAll: self name; - nextPutAll: ' failed ('; - nextPutAll: anError class name; - nextPutAll: ')'. - message isEmpty ifFalse: [ stream - nextPutAll: ': '; - nextPutAll: message ] ] + nextPutAll: 'Tool '; + nextPutAll: self name; + nextPutAll: ' failed ('; + nextPutAll: anError class name; + nextPutAll: ')'. + message isEmpty ifFalse: [ + stream + nextPutAll: ': '; + nextPutAll: message ] ] ] { #category : 'metadata' } @@ -332,10 +332,7 @@ MCPTool >> pngCompositeBaseIconNamed: aBaseIconSymbol badgeIconNamed: aBadgeIcon { #category : 'private - icons' } MCPTool >> pngDataUriForForm: aForm [ - | bytes | - bytes := ByteArray streamContents: [ :stream | - PNGReadWriter putForm: aForm onStream: stream ]. - ^ 'data:image/png;base64,' , bytes base64Encoded + ^ MCPStructureIcon pngDataUriForForm: aForm ] { #category : 'private - icons' } diff --git a/src/MCP/MCPToolCaptureScreenshot.class.st b/src/MCP/MCPToolCaptureScreenshot.class.st index 239e4eb..9403304 100644 --- a/src/MCP/MCPToolCaptureScreenshot.class.st +++ b/src/MCP/MCPToolCaptureScreenshot.class.st @@ -104,14 +104,14 @@ MCPToolCaptureScreenshot >> parsedRequestFromToolRequest: request [ MCPToolCaptureScreenshot >> successSummaryForResult: aScreenshotResult [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Captured '; - nextPutAll: aScreenshotResult target; - nextPutAll: ' screenshot ('; - print: aScreenshotResult width; - nextPutAll: 'x'; - print: aScreenshotResult height; - nextPutAll: ').' ] + stream + nextPutAll: 'Captured '; + nextPutAll: aScreenshotResult target; + nextPutAll: ' screenshot ('; + print: aScreenshotResult width; + nextPutAll: 'x'; + print: aScreenshotResult height; + nextPutAll: ').' ] ] { #category : 'metadata' } diff --git a/src/MCP/MCPToolCatalogCommand.class.st b/src/MCP/MCPToolCatalogCommand.class.st new file mode 100644 index 0000000..dc94986 --- /dev/null +++ b/src/MCP/MCPToolCatalogCommand.class.st @@ -0,0 +1,41 @@ +" +Abstract command for tool-catalog operations that need the current exposure policy. +" +Class { + #name : 'MCPToolCatalogCommand', + #superclass : 'MCPToolRequestCommand', + #instVars : [ + 'toolExposurePolicy' + ], + #category : 'MCP-Commands', + #package : 'MCP', + #tag : 'Commands' +} + +{ #category : 'testing' } +MCPToolCatalogCommand class >> isAbstract [ + + ^ self == MCPToolCatalogCommand +] + +{ #category : 'instance creation' } +MCPToolCatalogCommand class >> tool: aTool request: aRequest toolExposurePolicy: aToolExposurePolicy [ + + ^ self new + initializeTool: aTool request: aRequest; + toolExposurePolicy: aToolExposurePolicy; + yourself +] + +{ #category : 'accessing' } +MCPToolCatalogCommand >> toolExposurePolicy [ + + ^ toolExposurePolicy ifNil: [ MCPToolExposurePolicy default ] +] + +{ #category : 'accessing' } +MCPToolCatalogCommand >> toolExposurePolicy: aToolExposurePolicy [ + + toolExposurePolicy := aToolExposurePolicy ifNil: [ + MCPToolExposurePolicy default ] +] diff --git a/src/MCP/MCPToolChangeHistory.class.st b/src/MCP/MCPToolChangeHistory.class.st index 0626ff2..f157e3b 100644 --- a/src/MCP/MCPToolChangeHistory.class.st +++ b/src/MCP/MCPToolChangeHistory.class.st @@ -117,27 +117,28 @@ MCPToolChangeHistory >> changeHistoryLogSchemaProperty [ MCPToolChangeHistory >> commandForRequest: changeHistoryRequest [ changeHistoryRequest operation = 'listFiles' ifTrue: [ - ^ MCPListChangeHistoryLogsCommand - tool: self - request: changeHistoryRequest ]. + ^ MCPListChangeHistoryLogsCommand + tool: self + request: changeHistoryRequest ]. changeHistoryRequest operation = 'listEntries' ifTrue: [ - ^ MCPListChangeHistoryEntriesCommand - tool: self - request: changeHistoryRequest ]. + ^ MCPListChangeHistoryEntriesCommand + tool: self + request: changeHistoryRequest ]. (#( 'applyEntries' 'revertEntries' ) includes: changeHistoryRequest operation) ifTrue: [ - ^ MCPChangeHistorySelectionCommand - tool: self - request: changeHistoryRequest ]. + ^ MCPChangeHistorySelectionCommand + tool: self + request: changeHistoryRequest ]. MCPCommandError signalErrorCode: #UnsupportedChangeHistoryAction - message: 'Unsupported change history action: ' , changeHistoryRequest operation + message: + 'Unsupported change history action: ' + , changeHistoryRequest operation details: { (#action -> changeHistoryRequest operation). (#supportedActions -> #( 'listFiles' 'listEntries' 'applyEntries' 'revertEntries' )) } asDictionary - ] { #category : 'executing' } diff --git a/src/MCP/MCPToolClassMutation.class.st b/src/MCP/MCPToolClassMutation.class.st index 0dd99e0..cd977e1 100644 --- a/src/MCP/MCPToolClassMutation.class.st +++ b/src/MCP/MCPToolClassMutation.class.st @@ -22,20 +22,7 @@ MCPToolClassMutation class >> isAbstract [ { #category : 'private - schema' } MCPToolClassMutation >> atLeastOneInputProperties [ - ^ self classToolSpec - at: #atLeastOneProperties - ifAbsent: [ #( ) ] -] - -{ #category : 'metadata' } -MCPToolClassMutation >> buildInputSchema [ - - ^ MCPStructureInputSchema new - type: 'object'; - properties: self inputProperties; - required: self requiredInputProperties; - additionalProperties: false; - yourself + ^ self classToolSpec at: #atLeastOneProperties ifAbsent: [ #( ) ] ] { #category : 'metadata' } @@ -126,45 +113,45 @@ MCPToolClassMutation >> failureMessageForAddSlotNamed: slotName onClassNamed: cl MCPToolClassMutation >> failureMessageForCreateClassNamed: className superclassName: superclassName packageName: packageName error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to create class '; - nextPutAll: className; - nextPutAll: ' < '; - nextPutAll: superclassName; - nextPutAll: ' in package '; - nextPutAll: packageName; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to create class '; + nextPutAll: className; + nextPutAll: ' < '; + nextPutAll: superclassName; + nextPutAll: ' in package '; + nextPutAll: packageName; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForMoveClassNamed: className packageName: packageName tag: tag error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to move class '; - nextPutAll: className; - nextPutAll: ' to package '; - nextPutAll: packageName. - tag ifNotNil: [ stream - nextPutAll: ' tag '; - nextPutAll: tag ]. - stream - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + nextPutAll: 'Unable to move class '; + nextPutAll: className; + nextPutAll: ' to package '; + nextPutAll: packageName. + tag ifNotNil: [ + stream + nextPutAll: ' tag '; + nextPutAll: tag ]. + stream + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForMoveSlotNamed: slotName onClassNamed: className classSide: classSide operation: operation error: anError [ operation = 'pullUpSlot' ifTrue: [ - ^ 'Failed to pull up ' - , (self slotDescriptionForClassSide: classSide) , ' ' , slotName - , ' to class ' , className , ': ' - , (self normalizedCauseMessageForMutationError: anError) ]. + ^ 'Failed to pull up ' + , (self slotDescriptionForClassSide: classSide) , ' ' , slotName + , ' to class ' , className , ': ' + , (self normalizedCauseMessageForMutationError: anError) ]. ^ 'Failed to push down ' , (self slotDescriptionForClassSide: classSide) , ' ' , slotName , ' from class ' , className , ': ' @@ -183,14 +170,14 @@ MCPToolClassMutation >> failureMessageForRemoveSlotNamed: slotName onClassNamed: MCPToolClassMutation >> failureMessageForRenameClassNamed: className to: newClassName error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to rename class '; - nextPutAll: className; - nextPutAll: ' to '; - nextPutAll: newClassName; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to rename class '; + nextPutAll: className; + nextPutAll: ' to '; + nextPutAll: newClassName; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } @@ -205,106 +192,104 @@ MCPToolClassMutation >> failureMessageForRenameSlotNamed: slotName to: newSlotNa MCPToolClassMutation >> failureMessageForReparentClassNamed: className superclassName: superclassName error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to reparent class '; - nextPutAll: className; - nextPutAll: ' to superclass '; - nextPutAll: superclassName; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to reparent class '; + nextPutAll: className; + nextPutAll: ' to superclass '; + nextPutAll: superclassName; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForReplaceClassTraitsOnClassNamed: className error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to replace class-side traits for class '; - nextPutAll: className; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to replace class-side traits for class '; + nextPutAll: className; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForReplaceDefinitionOnClassNamed: className error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to replace slot definition for class '; - nextPutAll: className; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to replace slot definition for class '; + nextPutAll: className; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForReplaceLayoutOnClassNamed: className error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to replace layout for class '; - nextPutAll: className; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to replace layout for class '; + nextPutAll: className; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForReplaceSharedPoolsOnClassNamed: className error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to replace shared pools for class '; - nextPutAll: className; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to replace shared pools for class '; + nextPutAll: className; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForReplaceSharedVariablesOnClassNamed: className error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to replace shared variables for class '; - nextPutAll: className; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to replace shared variables for class '; + nextPutAll: className; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForReplaceTraitsOnClassNamed: className error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to replace traits for class '; - nextPutAll: className; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to replace traits for class '; + nextPutAll: className; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } MCPToolClassMutation >> failureMessageForSetCommentOnClassNamed: className error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to set comment for class '; - nextPutAll: className; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to set comment for class '; + nextPutAll: className; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private - specs' } MCPToolClassMutation >> fixedArguments [ - ^ self classToolSpec - at: #fixedArguments - ifAbsent: [ Dictionary new ] + ^ self classToolSpec at: #fixedArguments ifAbsent: [ Dictionary new ] ] { #category : 'private - schema' } @@ -378,9 +363,9 @@ MCPToolClassMutation >> parsedRequestFromToolRequest: request [ self fixedArguments keysAndValuesDo: [ :key :value | arguments at: key put: value ]. mutationToolRequest := MCPToolRequest new - tool: self; - arguments: arguments; - yourself. + tool: self; + arguments: arguments; + yourself. requestClass := self mutationAction = 'create' ifTrue: [ MCPClassCreateRequest ] ifFalse: [ MCPClassUpdateRequest ]. @@ -493,10 +478,6 @@ MCPToolClassMutation >> validateAtLeastOneInputPropertyIn: request [ { #category : 'validating' } MCPToolClassMutation >> validateRequest: request [ - self requiredInputProperties do: [ :each | - (request argumentNamed: each ifAbsent: [ nil ]) ifNil: [ - MCPInvalidToolInput - signalMissingRequiredArgumentNamed: each - forTool: self ] ]. + super validateRequest: request. self validateAtLeastOneInputPropertyIn: request ] diff --git a/src/MCP/MCPToolDebug.class.st b/src/MCP/MCPToolDebug.class.st index 3d5f360..a3d1b9d 100644 --- a/src/MCP/MCPToolDebug.class.st +++ b/src/MCP/MCPToolDebug.class.st @@ -29,6 +29,17 @@ MCPToolDebug >> boundedIntegerSchemaPropertyNamed: propertyName description: pro ^ property ] +{ #category : 'metadata' } +MCPToolDebug >> buildInputSchema [ + + ^ MCPStructureInputSchema new + type: 'object'; + properties: self inputProperties; + required: self requiredInputProperties; + additionalProperties: false; + yourself +] + { #category : 'private - execution' } MCPToolDebug >> commandForRequest: debugRequest [ @@ -65,6 +76,12 @@ MCPToolDebug >> executeWithRequest: request [ onError: [ :error :ignored | self errorResultForDebugError: error ] ] +{ #category : 'private - schema' } +MCPToolDebug >> inputProperties [ + + ^ #( ) +] + { #category : 'private - schema' } MCPToolDebug >> nonNegativeIntegerSchemaPropertyNamed: propertyName description: propertyDescription default: defaultValue [ @@ -77,6 +94,12 @@ MCPToolDebug >> nonNegativeIntegerSchemaPropertyNamed: propertyName description: ^ property ] +{ #category : 'private - schema' } +MCPToolDebug >> requiredInputProperties [ + + ^ #( ) +] + { #category : 'private - execution' } MCPToolDebug >> resultForCommandResult: commandResult [ @@ -90,6 +113,16 @@ MCPToolDebug >> resultForCommandResult: commandResult [ warnings: commandResult warnings ] +{ #category : 'private - schema' } +MCPToolDebug >> sessionIdSchemaProperty [ + + ^ self + schemaPropertyNamed: 'sessionId' + type: 'string' + description: + 'Opaque debug session identifier returned by debug_session_list, debug_capture, debug_test_run, or debug_candidate_attach.' +] + { #category : 'private - schema' } MCPToolDebug >> sourceContextLinesSchemaPropertyWithDescription: aDescription default: defaultValue [ diff --git a/src/MCP/MCPToolDebugBreakpointOperation.class.st b/src/MCP/MCPToolDebugBreakpointOperation.class.st index 6bd9e46..efa311e 100644 --- a/src/MCP/MCPToolDebugBreakpointOperation.class.st +++ b/src/MCP/MCPToolDebugBreakpointOperation.class.st @@ -71,17 +71,6 @@ MCPToolDebugBreakpointOperation >> breakpointToolSpec [ self subclassResponsibility ] -{ #category : 'metadata' } -MCPToolDebugBreakpointOperation >> buildInputSchema [ - - ^ MCPStructureInputSchema new - type: 'object'; - properties: self inputProperties; - required: self requiredInputProperties; - additionalProperties: false; - yourself -] - { #category : 'metadata' } MCPToolDebugBreakpointOperation >> buildOutputSchema [ @@ -168,9 +157,7 @@ MCPToolDebugBreakpointOperation >> description [ { #category : 'private - schema' } MCPToolDebugBreakpointOperation >> inputProperties [ - ^ self breakpointToolSpec - at: #inputProperties - ifAbsent: [ #( ) ] + ^ self breakpointToolSpec at: #inputProperties ifAbsent: [ #( ) ] ] { #category : 'private - request' } @@ -185,9 +172,7 @@ MCPToolDebugBreakpointOperation >> parsedRequestFromToolRequest: request [ { #category : 'private - schema' } MCPToolDebugBreakpointOperation >> requiredInputProperties [ - ^ self breakpointToolSpec - at: #requiredProperties - ifAbsent: [ #( ) ] + ^ self breakpointToolSpec at: #requiredProperties ifAbsent: [ #( ) ] ] { #category : 'metadata' } diff --git a/src/MCP/MCPToolDebugSessionControlOperation.class.st b/src/MCP/MCPToolDebugSessionControlOperation.class.st index c996d11..ed97bdc 100644 --- a/src/MCP/MCPToolDebugSessionControlOperation.class.st +++ b/src/MCP/MCPToolDebugSessionControlOperation.class.st @@ -158,16 +158,6 @@ MCPToolDebugSessionControlOperation >> parsedRequestFromToolRequest: request [ operation: self actionName ] -{ #category : 'private - schema' } -MCPToolDebugSessionControlOperation >> sessionIdSchemaProperty [ - - ^ self - schemaPropertyNamed: 'sessionId' - type: 'string' - description: - 'Opaque debug session identifier returned by debug_session_list, debug_capture, debug_test_run, or debug_candidate_attach.' -] - { #category : 'private - schema' } MCPToolDebugSessionControlOperation >> stateIdSchemaProperty [ @@ -221,9 +211,7 @@ MCPToolDebugSessionControlOperation >> title [ { #category : 'private - specs' } MCPToolDebugSessionControlOperation >> usesFrameReference [ - ^ self controlToolSpec - at: #usesFrameReference - ifAbsent: [ false ] + ^ self controlToolSpec at: #usesFrameReference ifAbsent: [ false ] ] { #category : 'private - specs' } diff --git a/src/MCP/MCPToolDebugSessionOperation.class.st b/src/MCP/MCPToolDebugSessionOperation.class.st index 3a598cb..c99de2d 100644 --- a/src/MCP/MCPToolDebugSessionOperation.class.st +++ b/src/MCP/MCPToolDebugSessionOperation.class.st @@ -23,17 +23,6 @@ MCPToolDebugSessionOperation >> actionName [ ^ self sessionToolSpec at: #action ] -{ #category : 'metadata' } -MCPToolDebugSessionOperation >> buildInputSchema [ - - ^ MCPStructureInputSchema new - type: 'object'; - properties: self inputProperties; - required: self requiredInputProperties; - additionalProperties: false; - yourself -] - { #category : 'metadata' } MCPToolDebugSessionOperation >> buildOutputSchema [ @@ -128,19 +117,7 @@ MCPToolDebugSessionOperation >> parsedRequestFromToolRequest: request [ { #category : 'private - schema' } MCPToolDebugSessionOperation >> requiredInputProperties [ - ^ self sessionToolSpec - at: #requiredProperties - ifAbsent: [ #( ) ] -] - -{ #category : 'private - schema' } -MCPToolDebugSessionOperation >> sessionIdSchemaProperty [ - - ^ self - schemaPropertyNamed: 'sessionId' - type: 'string' - description: - 'Opaque debug session identifier returned by debug_session_list, debug_capture, debug_test_run, or debug_candidate_attach.' + ^ self sessionToolSpec at: #requiredProperties ifAbsent: [ #( ) ] ] { #category : 'private - specs' } diff --git a/src/MCP/MCPToolEvaluate.class.st b/src/MCP/MCPToolEvaluate.class.st index d70398e..4cd6c1d 100644 --- a/src/MCP/MCPToolEvaluate.class.st +++ b/src/MCP/MCPToolEvaluate.class.st @@ -70,24 +70,24 @@ MCPToolEvaluate >> executeWithRequest: request [ ^ self executeParsedRequestFrom: request do: [ :evaluateRequest | - | commandResult | - commandResult := (self commandForRequest: evaluateRequest) - execute. - commandResult isError - ifTrue: [ - self - errorResultText: commandResult summary - details: commandResult errorDetails ] - ifFalse: [ - self - successResultText: 'Code evaluated successfully.' - data: commandResult data ] ] + | commandResult | + commandResult := (self commandForRequest: evaluateRequest) + execute. + commandResult isError + ifTrue: [ + self + errorResultText: commandResult summary + details: commandResult errorDetails ] + ifFalse: [ + self + successResultText: 'Code evaluated successfully.' + data: commandResult data ] ] onError: [ :error :ignored | - self - errorResultText: (error messageText - ifNil: [ error asString ] - ifNotNil: [ :text | text ]) - details: (self errorDetailsFor: error) ] + self + errorResultText: (error messageText + ifNil: [ error asString ] + ifNotNil: [ :text | text ]) + details: (self errorDetailsFor: error) ] ] { #category : 'private - request' } @@ -110,15 +110,15 @@ MCPToolEvaluate >> runtimeFailureMessageFor: anError [ ifNil: [ anError asString ] ifNotNil: [ :text | text asString ]. ^ String streamContents: [ :stream | - stream - nextPutAll: 'Evaluation failed during execution ('; - nextPutAll: anError class name; - nextPutAll: '): '; - nextPutAll: message. - anError signalerContext ifNotNil: [ :context | stream - nextPutAll: ' Signaler context: '; - nextPutAll: context printString ] ] + nextPutAll: 'Evaluation failed during execution ('; + nextPutAll: anError class name; + nextPutAll: '): '; + nextPutAll: message. + anError signalerContext ifNotNil: [ :context | + stream + nextPutAll: ' Signaler context: '; + nextPutAll: context printString ] ] ] { #category : 'testing' } diff --git a/src/MCP/MCPToolGetClass.class.st b/src/MCP/MCPToolGetClass.class.st index aed66b4..4c9e98a 100644 --- a/src/MCP/MCPToolGetClass.class.st +++ b/src/MCP/MCPToolGetClass.class.st @@ -210,9 +210,9 @@ MCPToolGetClass >> description [ MCPToolGetClass >> descriptionDictionariesForClasses: someClasses includeComment: includeComment [ ^ (someClasses collect: [ :each | - self - descriptionDictionaryForClass: each - includeComment: includeComment ]) asArray + self + descriptionDictionaryForClass: each + includeComment: includeComment ]) asArray ] { #category : 'private - hierarchy' } diff --git a/src/MCP/MCPToolGetMethod.class.st b/src/MCP/MCPToolGetMethod.class.st index 7b3b3fa..215dc33 100644 --- a/src/MCP/MCPToolGetMethod.class.st +++ b/src/MCP/MCPToolGetMethod.class.st @@ -202,9 +202,9 @@ MCPToolGetMethod >> matchingSummaryForNodeName: aName kind: aKind ownerName: anO ^ summaries detect: [ :each | - (each at: #name) = aName and: [ - (each at: #kind) = aKind and: [ - (each at: #ownerName ifAbsent: [ nil ]) = anOwnerName ] ] ] + (each at: #name) = aName and: [ + (each at: #kind) = aKind and: [ + (each at: #ownerName ifAbsent: [ nil ]) = anOwnerName ] ] ] ifNone: [ nil ] ] diff --git a/src/MCP/MCPToolIconSpec.class.st b/src/MCP/MCPToolIconSpec.class.st index cffdd8a..5fab0dc 100644 --- a/src/MCP/MCPToolIconSpec.class.st +++ b/src/MCP/MCPToolIconSpec.class.st @@ -134,6 +134,12 @@ MCPToolIconSpec class >> iconNameForObject: objectString [ ^ self objectIconMap at: objectString asString ifAbsent: [ #info ] ] +{ #category : 'testing' } +MCPToolIconSpec class >> isAbstract [ + + ^ self == MCPToolIconSpec +] + { #category : 'instance creation' } MCPToolIconSpec class >> named: anIconSymbol [ diff --git a/src/MCP/MCPToolMethodMutation.class.st b/src/MCP/MCPToolMethodMutation.class.st index b8317f3..4b0390e 100644 --- a/src/MCP/MCPToolMethodMutation.class.st +++ b/src/MCP/MCPToolMethodMutation.class.st @@ -54,25 +54,18 @@ MCPToolMethodMutation >> allowedNonErrorCritiqueRuleClasses [ ReUnaryAccessingMethodWithoutReturnRule } ] -{ #category : 'metadata' } -MCPToolMethodMutation >> buildInputSchema [ - - ^ MCPStructureInputSchema new - type: 'object'; - properties: self inputProperties; - required: self requiredInputProperties; - additionalProperties: false; - yourself -] - { #category : 'metadata' } MCPToolMethodMutation >> buildOutputSchema [ ^ self - standardOutputSchemaForDataProperties: { - (self schemaPropertyNamed: 'changeKind' type: 'string' description: 'Whether method_compile created or replaced a method.'). - self methodCritiquesSchemaProperty } - required: #( ) + standardOutputSchemaForDataProperties: { + (self + schemaPropertyNamed: 'changeKind' + type: 'string' + description: + 'Whether method_compile created or replaced a method.'). + self methodCritiquesSchemaProperty } + required: #( ) ] { #category : 'private' } @@ -94,9 +87,9 @@ MCPToolMethodMutation >> critiqueDataFor: aCritique [ asDictionary. interval := self sourceIntervalForCritique: aCritique. interval ifNotNil: [ - data - at: #start put: interval first; - at: #stop put: interval last ]. + data + at: #start put: interval first; + at: #stop put: interval last ]. ^ data ] @@ -130,18 +123,18 @@ MCPToolMethodMutation >> failureMessageForArgumentUpdateAction: updateAction cla ifTrue: [ 'add arguments to' ] ifFalse: [ 'remove arguments from' ]. ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to '; - nextPutAll: verb; - nextPutAll: ' method '; - nextPutAll: targetName; - nextPutAll: '>>'; - nextPutAll: oldSelector; - nextPutAll: ' as '; - nextPutAll: newSelector; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to '; + nextPutAll: verb; + nextPutAll: ' method '; + nextPutAll: targetName; + nextPutAll: '>>'; + nextPutAll: oldSelector; + nextPutAll: ' as '; + nextPutAll: newSelector; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } @@ -152,16 +145,16 @@ MCPToolMethodMutation >> failureMessageForChangeProtocolClassNamed: className cl classReferenceNameFor: className classSide: classSide. ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to change protocol for '; - nextPutAll: targetName; - nextPutAll: '>>'; - nextPutAll: selector; - nextPutAll: ' to '; - nextPutAll: protocol; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to change protocol for '; + nextPutAll: targetName; + nextPutAll: '>>'; + nextPutAll: selector; + nextPutAll: ' to '; + nextPutAll: protocol; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } @@ -172,12 +165,12 @@ MCPToolMethodMutation >> failureMessageForCompileClassNamed: className classSide classReferenceNameFor: className classSide: classSide. ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to compile method on '; - nextPutAll: targetName; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to compile method on '; + nextPutAll: targetName; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private' } @@ -188,16 +181,16 @@ MCPToolMethodMutation >> failureMessageForRenameClassNamed: className classSide: classReferenceNameFor: className classSide: classSide. ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to rename method '; - nextPutAll: targetName; - nextPutAll: '>>'; - nextPutAll: oldSelector; - nextPutAll: ' to '; - nextPutAll: newSelector; - nextPutAll: ': '; - nextPutAll: - (self normalizedCauseMessageForMutationError: anError) ] + stream + nextPutAll: 'Unable to rename method '; + nextPutAll: targetName; + nextPutAll: '>>'; + nextPutAll: oldSelector; + nextPutAll: ' to '; + nextPutAll: newSelector; + nextPutAll: ': '; + nextPutAll: + (self normalizedCauseMessageForMutationError: anError) ] ] { #category : 'private - schema' } @@ -277,17 +270,14 @@ MCPToolMethodMutation >> parsedRequestFromToolRequest: request [ | requestClass | requestClass := self mutationAction = 'compile' - ifTrue: [ MCPMethodCompileRequest ] - ifFalse: [ MCPMethodUpdateRequest ]. + ifTrue: [ MCPMethodCompileRequest ] + ifFalse: [ MCPMethodUpdateRequest ]. ^ requestClass fromRequest: request tool: self ] { #category : 'private' } MCPToolMethodMutation >> reformattedMethodForBehavior: aBehavior selector: aSelector [ - | compiledMethod | - compiledMethod := aBehavior >> aSelector. - compiledMethod reformat. ^ aBehavior >> aSelector ] @@ -348,13 +338,3 @@ MCPToolMethodMutation >> title [ ^ self methodToolSpec at: #title ] - -{ #category : 'validating' } -MCPToolMethodMutation >> validateRequest: request [ - - self requiredInputProperties do: [ :each | - (request argumentNamed: each ifAbsent: [ nil ]) ifNil: [ - MCPInvalidToolInput - signalMissingRequiredArgumentNamed: each - forTool: self ] ] -] diff --git a/src/MCP/MCPToolMethodSearch.class.st b/src/MCP/MCPToolMethodSearch.class.st index ddd0b24..0451b37 100644 --- a/src/MCP/MCPToolMethodSearch.class.st +++ b/src/MCP/MCPToolMethodSearch.class.st @@ -146,9 +146,9 @@ MCPToolMethodSearch >> matchingSelectorReferencesForSelector: aSelectorSymbol in specialSelectorIndex := Smalltalk specialSelectorIndexOrNil: aSelectorSymbol. ^ (compiledMethods select: [ :eachMethod | - eachMethod - hasSelector: aSelectorSymbol - specialSelectorIndex: specialSelectorIndex ]) asArray + eachMethod + hasSelector: aSelectorSymbol + specialSelectorIndex: specialSelectorIndex ]) asArray ] { #category : 'private - searching' } @@ -159,8 +159,8 @@ MCPToolMethodSearch >> matchingVariableReferencesNamed: aVariableName scopeQuery variableBindingsNamed: aVariableName inBehaviors: query behaviors. variables ifEmpty: [ - Error signal: 'No variable named ' , aVariableName - , ' is accessible in the requested scope.' ]. + Error signal: 'No variable named ' , aVariableName + , ' is accessible in the requested scope.' ]. ^ (compiledMethods select: [ :eachMethod | self method: eachMethod referencesAnyVariable: variables ]) asArray @@ -293,30 +293,6 @@ MCPToolMethodSearch >> methodQueryScopeInputProperties [ self searchScopeSchemaProperty } ] -{ #category : 'private - methods' } -MCPToolMethodSearch >> methodScopeQueryFromRequest: request [ - - ^ MCPCompiledMethodScopeQuery new - packageNames: (self - searchScopeStringCollectionNamed: 'packages' - fromRequest: request); - classNames: - (self - searchScopeStringCollectionNamed: 'classes' - fromRequest: request); - hierarchyClassNames: (self - searchScopeStringCollectionNamed: 'hierarchies' - fromRequest: request); - subclassClassNames: (self - searchScopeStringCollectionNamed: 'subclassesOf' - fromRequest: request); - parentClassNames: (self - searchScopeStringCollectionNamed: 'superclassesOf' - fromRequest: request); - side: (request stringArgumentNamed: 'side' default: 'both'); - yourself -] - { #category : 'private - filtering' } MCPToolMethodSearch >> needsSourceForFiltering [ @@ -368,16 +344,6 @@ MCPToolMethodSearch >> sortedMethodEntries: entries [ (self methodEntryLabel: left) <= (self methodEntryLabel: right) ] ] -{ #category : 'private - template' } -MCPToolMethodSearch >> successSummaryForQueryRequest: queryRequest page: page [ - - ^ self - successSummaryForScope: - (self classAndMethodScopeSummaryForScopeQuery: - queryRequest scopeQuery) - page: page -] - { #category : 'private - results' } MCPToolMethodSearch >> successSummaryForScope: scopeSummary page: page [ @@ -399,11 +365,11 @@ MCPToolMethodSearch >> variableBindingsNamed: aVariableName inBehaviors: behavio | variables | variables := IdentitySet new. behaviors do: [ :eachBehavior | - eachBehavior allSlots do: [ :eachSlot | - eachSlot name asString = aVariableName ifTrue: [ - variables add: eachSlot ] ]. - (eachBehavior bindingOf: aVariableName) ifNotNil: [ :binding | - variables add: binding ] ]. + eachBehavior allSlots do: [ :eachSlot | + eachSlot name asString = aVariableName ifTrue: [ + variables add: eachSlot ] ]. + (eachBehavior bindingOf: aVariableName) ifNotNil: [ :binding | + variables add: binding ] ]. ^ variables asArray ] diff --git a/src/MCP/MCPToolMutation.class.st b/src/MCP/MCPToolMutation.class.st index 2cdc53e..9042d8e 100644 --- a/src/MCP/MCPToolMutation.class.st +++ b/src/MCP/MCPToolMutation.class.st @@ -33,9 +33,9 @@ MCPToolMutation >> addRefactoringScopeContextFromSpec: scopeSpec toRequestedCont scopeSpec classNames ifNotEmpty: [ requestedContext at: #classNames put: scopeSpec classNames ]. scopeSpec hierarchyClassNames ifNotEmpty: [ - requestedContext - at: #hierarchyClassNames - put: scopeSpec hierarchyClassNames ] + requestedContext + at: #hierarchyClassNames + put: scopeSpec hierarchyClassNames ] ] { #category : 'private - errors' } @@ -75,6 +75,17 @@ MCPToolMutation >> addSupplementalSelectorFromMethodNode: methodNode to: details details at: #selector ifAbsentPut: [ selector asString ] ] ] +{ #category : 'metadata' } +MCPToolMutation >> buildInputSchema [ + + ^ MCPStructureInputSchema new + type: 'object'; + properties: self inputProperties; + required: self requiredInputProperties; + additionalProperties: false; + yourself +] + { #category : 'private - refactoring' } MCPToolMutation >> classesRefactoringEnvironmentForClassNames: classNames baseEnvironment: baseEnvironment [ @@ -116,13 +127,13 @@ MCPToolMutation >> errorResultForCommandError: anError action: action requestedC | details | details := anError structuredDetails copy. requestedContext ifNotNil: [ - requestedContext keysAndValuesDo: [ :key :value | - value ifNotNil: [ details at: key ifAbsentPut: [ value ] ] ] ]. + requestedContext keysAndValuesDo: [ :key :value | + value ifNotNil: [ details at: key ifAbsentPut: [ value ] ] ] ]. (#( 'compile' 'create' 'update' ) includes: action) ifTrue: [ details at: #action put: action ] ifFalse: [ - details at: #action put: 'update'. - details at: #updateAction put: action ]. + details at: #action put: 'update'. + details at: #updateAction put: action ]. ^ self errorResultText: anError messageText details: details ] @@ -189,11 +200,12 @@ MCPToolMutation >> executeWithRequest: request [ ^ self executeParsedRequestFrom: request do: [ :mutationRequest | - (self commandForRequest: mutationRequest) execute ] + (self commandForRequest: mutationRequest) execute ] onError: [ :error :mutationRequest | | action requestedContext | action := self - mutationActionForErrorFromParsedRequest: mutationRequest + mutationActionForErrorFromParsedRequest: + mutationRequest rawRequest: request. requestedContext := self requestedContextForErrorFromParsedRequest: @@ -250,9 +262,10 @@ MCPToolMutation >> hierarchyRefactoringEnvironmentForClassNames: classNames base classNames. environment := nil. resolvedClasses do: [ :eachClass | - environment := self - unionRefactoringEnvironment: environment - with: (baseEnvironment forClassHierarchy: eachClass) ]. + environment := self + unionRefactoringEnvironment: environment + with: + (baseEnvironment forClassHierarchy: eachClass) ]. ^ environment ] @@ -267,9 +280,9 @@ MCPToolMutation >> impactMessageForRefactoringCondition: aCondition [ | message | message := String streamContents: [ :stream | - aCondition violationMessageOn: stream ]. + aCondition violationMessageOn: stream ]. ^ self normalizedRefactoringConditionMessage: - (self normalizedSingleLineText: message) + (self normalizedSingleLineText: message) ] { #category : 'private - warnings' } @@ -292,6 +305,12 @@ MCPToolMutation >> impactMessagesForRefactoringWarning: aWarning [ ^ impactMessages asArray ] +{ #category : 'private - schema' } +MCPToolMutation >> inputProperties [ + + self subclassResponsibility +] + { #category : 'private - errors' } MCPToolMutation >> methodNodeFromError: anError [ @@ -346,8 +365,7 @@ MCPToolMutation >> normalizedCommandErrorForActionFailure: anError action: actio causedBy: anError. self addSupplementalDetailsForMutationError: anError to: details. ^ MCPCommandError new - errorCode: - (self failureErrorCodeFor: anError action: action); + errorCode: (self failureErrorCodeFor: anError action: action); details: details; messageText: normalizedSummary; yourself @@ -370,8 +388,7 @@ MCPToolMutation >> normalizedCommandErrorForRefactoringWarning: aWarning action: details at: #howToProceed put: self howToProceedForRefactoringWarning. details at: #forceSupported put: true. ^ MCPCommandError new - errorCode: - (self failureErrorCodeFor: aWarning action: action); + errorCode: (self failureErrorCodeFor: aWarning action: action); details: details; messageText: summary; yourself @@ -418,25 +435,25 @@ MCPToolMutation >> refactoringEnvironmentForScopeSpec: scopeSpec [ scopeSpec isDefaultImageScope ifTrue: [ ^ baseEnvironment ]. environment := nil. scopeSpec packageNames ifNotEmpty: [ - environment := self - unionRefactoringEnvironment: environment - with: - (baseEnvironment forPackageNames: - scopeSpec packageNames) ]. + environment := self + unionRefactoringEnvironment: environment + with: + (baseEnvironment forPackageNames: + scopeSpec packageNames) ]. scopeSpec classNames ifNotEmpty: [ - environment := self - unionRefactoringEnvironment: environment - with: (self - classesRefactoringEnvironmentForClassNames: - scopeSpec classNames - baseEnvironment: baseEnvironment) ]. + environment := self + unionRefactoringEnvironment: environment + with: (self + classesRefactoringEnvironmentForClassNames: + scopeSpec classNames + baseEnvironment: baseEnvironment) ]. scopeSpec hierarchyClassNames ifNotEmpty: [ - environment := self - unionRefactoringEnvironment: environment - with: (self - hierarchyRefactoringEnvironmentForClassNames: - scopeSpec hierarchyClassNames - baseEnvironment: baseEnvironment) ]. + environment := self + unionRefactoringEnvironment: environment + with: (self + hierarchyRefactoringEnvironmentForClassNames: + scopeSpec hierarchyClassNames + baseEnvironment: baseEnvironment) ]. ^ environment ifNil: [ baseEnvironment ] ] @@ -446,16 +463,17 @@ MCPToolMutation >> refactoringModelForScopeSpec: scopeSpec anchoredAtBehavior: a | details environment | environment := self refactoringEnvironmentForScopeSpec: scopeSpec. (environment includesClass: aBehavior) ifFalse: [ - details := scopeSpec asDictionary copy. - details at: #className put: aBehavior instanceSide name asString. - details at: #classSide put: aBehavior isMeta. - MCPCommandError - signalErrorCode: #RefactoringScopeExcludesTargetClass - message: 'Refactoring scope does not include ' , (aBehavior isMeta - ifTrue: [ 'the class side of ' ] - ifFalse: [ 'class ' ]) , aBehavior instanceSide name asString - , '.' - details: details ]. + details := scopeSpec asDictionary copy. + details at: #className put: aBehavior instanceSide name asString. + details at: #classSide put: aBehavior isMeta. + MCPCommandError + signalErrorCode: #RefactoringScopeExcludesTargetClass + message: + 'Refactoring scope does not include ' , (aBehavior isMeta + ifTrue: [ 'the class side of ' ] + ifFalse: [ 'class ' ]) , aBehavior instanceSide name asString + , '.' + details: details ]. ^ RBNamespace onEnvironment: environment ] @@ -526,6 +544,12 @@ MCPToolMutation >> requestedContextForErrorFromParsedRequest: mutationRequest ra ^ mutationRequest requestedContext ] +{ #category : 'private - schema' } +MCPToolMutation >> requiredInputProperties [ + + self subclassResponsibility +] + { #category : 'private - request' } MCPToolMutation >> resolvedRefactoringScopeClassesFrom: classNames [ @@ -627,6 +651,16 @@ MCPToolMutation >> validateRefactoringScopePackageNamesExist: packageNames [ packageNames do: [ :eachName | MCPImageLookup packageNamed: eachName ] ] +{ #category : 'validating' } +MCPToolMutation >> validateRequest: request [ + + self requiredInputProperties do: [ :each | + (request argumentNamed: each ifAbsent: [ nil ]) ifNil: [ + MCPInvalidToolInput + signalMissingRequiredArgumentNamed: each + forTool: self ] ] +] + { #category : 'private - errors' } MCPToolMutation >> variableNameFromNode: aNode [ diff --git a/src/MCP/MCPToolRegistry.class.st b/src/MCP/MCPToolRegistry.class.st index cb31116..a4a74d1 100644 --- a/src/MCP/MCPToolRegistry.class.st +++ b/src/MCP/MCPToolRegistry.class.st @@ -54,7 +54,8 @@ MCPToolRegistry class >> additionalKeywordsForTool: aTool [ toolName = 'repository_branch_switch' ifTrue: [ ^ #( 'repo' 'iceberg' 'git' 'branch' 'switch' ) ]. toolName = 'repository_branch_checkout' ifTrue: [ - ^ #( 'repo' 'iceberg' 'git' 'branch' 'checkout' 'reload' 'stale' 'verification' ) ]. + ^ #( 'repo' 'iceberg' 'git' 'branch' 'checkout' 'reload' 'stale' + 'verification' ) ]. toolName = 'repository_head_adopt' ifTrue: [ ^ #( 'repo' 'iceberg' 'git' 'head' 'adopt' ) ]. toolName = 'baseline_load' ifTrue: [ @@ -470,7 +471,7 @@ MCPToolRegistry class >> publicToolNames [ { #category : 'tools' } MCPToolRegistry class >> publicTools [ - ^ (self registrations collect: [ :each | each tool ]) asArray + ^ self registrations collect: [ :each | each tool ] ] { #category : 'tools' } diff --git a/src/MCP/MCPToolRemoveClasses.class.st b/src/MCP/MCPToolRemoveClasses.class.st index 7778753..56583c2 100644 --- a/src/MCP/MCPToolRemoveClasses.class.st +++ b/src/MCP/MCPToolRemoveClasses.class.st @@ -115,33 +115,33 @@ MCPToolRemoveClasses >> executeWithRequest: request [ ^ self executeParsedRequestFrom: request do: [ :removeRequest | - | result | - result := (self commandForRequest: removeRequest) execute. - self - successResultText: (self - successSummaryForClassNames: removeRequest classNames - removedClasses: result removedClasses - removedPackageNames: result removedPackageNames - forced: result warningMessages notEmpty) - data: result asDictionary - warnings: result warningMessages ] + | result | + result := (self commandForRequest: removeRequest) execute. + self + successResultText: (self + successSummaryForClassNames: removeRequest classNames + removedClasses: result removedClasses + removedPackageNames: result removedPackageNames + forced: result warningMessages notEmpty) + data: result asDictionary + warnings: result warningMessages ] onError: [ :error :removeRequest | - self errorResultForError: error classNames: (self - classNamesForErrorFromParsedRequest: removeRequest - rawRequest: request) ] + self errorResultForError: error classNames: (self + classNamesForErrorFromParsedRequest: removeRequest + rawRequest: request) ] ] { #category : 'private' } MCPToolRemoveClasses >> failureMessageForClassNames: classNames error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to remove classes: '; - nextPutAll: (', ' join: classNames); - nextPutAll: ' ('; - nextPutAll: anError class name; - nextPutAll: '): '; - nextPutAll: anError messageText ] + stream + nextPutAll: 'Unable to remove classes: '; + nextPutAll: (', ' join: classNames); + nextPutAll: ' ('; + nextPutAll: anError class name; + nextPutAll: '): '; + nextPutAll: anError messageText ] ] { #category : 'private - request' } @@ -162,51 +162,51 @@ MCPToolRemoveClasses >> successSummaryForClassNames: classNames removedClasses: | reparentedSubclassNames | reparentedSubclassNames := OrderedCollection new. removedClasses do: [ :each | - each reparentedSubclassNames do: [ :subclassName | - (reparentedSubclassNames includes: subclassName) ifFalse: [ - reparentedSubclassNames add: subclassName ] ] ]. + each reparentedSubclassNames do: [ :subclassName | + (reparentedSubclassNames includes: subclassName) ifFalse: [ + reparentedSubclassNames add: subclassName ] ] ]. ^ String streamContents: [ :stream | - classNames size = 1 - ifTrue: [ - wasForced - ifTrue: [ - stream - nextPutAll: 'Force-removed class '; - nextPutAll: classNames first; - nextPut: $. ] - ifFalse: [ - stream - nextPutAll: 'Removed class '; - nextPutAll: classNames first; - nextPut: $. ] ] - ifFalse: [ - wasForced - ifTrue: [ - stream - nextPutAll: 'Force-removed '; - nextPutAll: classNames size asString; - nextPutAll: ' classes: '; - nextPutAll: (', ' join: classNames); - nextPut: $. ] - ifFalse: [ - stream - nextPutAll: 'Removed '; - nextPutAll: classNames size asString; - nextPutAll: ' classes: '; - nextPutAll: (', ' join: classNames); - nextPut: $. ] ]. - reparentedSubclassNames ifNotEmpty: [ - stream - space; - nextPutAll: 'Reparented subclasses: '; - nextPutAll: (', ' join: reparentedSubclassNames); - nextPut: $. ]. - removedPackageNames ifNotEmpty: [ - stream - space; - nextPutAll: 'Removed packages: '; - nextPutAll: (', ' join: removedPackageNames); - nextPut: $. ] ] + classNames size = 1 + ifTrue: [ + wasForced + ifTrue: [ + stream + nextPutAll: 'Force-removed class '; + nextPutAll: classNames first; + nextPut: $. ] + ifFalse: [ + stream + nextPutAll: 'Removed class '; + nextPutAll: classNames first; + nextPut: $. ] ] + ifFalse: [ + wasForced + ifTrue: [ + stream + nextPutAll: 'Force-removed '; + nextPutAll: classNames size asString; + nextPutAll: ' classes: '; + nextPutAll: (', ' join: classNames); + nextPut: $. ] + ifFalse: [ + stream + nextPutAll: 'Removed '; + nextPutAll: classNames size asString; + nextPutAll: ' classes: '; + nextPutAll: (', ' join: classNames); + nextPut: $. ] ]. + reparentedSubclassNames ifNotEmpty: [ + stream + space; + nextPutAll: 'Reparented subclasses: '; + nextPutAll: (', ' join: reparentedSubclassNames); + nextPut: $. ]. + removedPackageNames ifNotEmpty: [ + stream + space; + nextPutAll: 'Removed packages: '; + nextPutAll: (', ' join: removedPackageNames); + nextPut: $. ] ] ] { #category : 'metadata' } diff --git a/src/MCP/MCPToolRemoveMethods.class.st b/src/MCP/MCPToolRemoveMethods.class.st index b8fe06b..10506e3 100644 --- a/src/MCP/MCPToolRemoveMethods.class.st +++ b/src/MCP/MCPToolRemoveMethods.class.st @@ -109,27 +109,27 @@ MCPToolRemoveMethods >> executeWithRequest: request [ ^ self executeParsedRequestFrom: request do: [ :removeRequest | - | result | - result := (self commandForRequest: removeRequest) execute. - self - successResultText: (self - successSummaryForClassName: result className - classSide: result classSide - selectors: result selectors) - data: result asDictionary - warnings: result warningMessages ] + | result | + result := (self commandForRequest: removeRequest) execute. + self + successResultText: (self + successSummaryForClassName: result className + classSide: result classSide + selectors: result selectors) + data: result asDictionary + warnings: result warningMessages ] onError: [ :error :removeRequest | - self - errorResultForError: error - className: (self - classNameForErrorFromParsedRequest: removeRequest - rawRequest: request) - classSide: (self - classSideForErrorFromParsedRequest: removeRequest - rawRequest: request) - selectors: (self - selectorsForErrorFromParsedRequest: removeRequest - rawRequest: request) ] + self + errorResultForError: error + className: (self + classNameForErrorFromParsedRequest: removeRequest + rawRequest: request) + classSide: (self + classSideForErrorFromParsedRequest: removeRequest + rawRequest: request) + selectors: (self + selectorsForErrorFromParsedRequest: removeRequest + rawRequest: request) ] ] { #category : 'private' } @@ -140,15 +140,15 @@ MCPToolRemoveMethods >> failureMessageForClassNamed: className classSide: classS ifTrue: [ className , ' class' ] ifFalse: [ className ]. ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to remove methods from '; - nextPutAll: targetName; - nextPutAll: ': '; - nextPutAll: (', ' join: selectors); - nextPutAll: ' ('; - nextPutAll: anError class name; - nextPutAll: '): '; - nextPutAll: anError messageText ] + stream + nextPutAll: 'Unable to remove methods from '; + nextPutAll: targetName; + nextPutAll: ': '; + nextPutAll: (', ' join: selectors); + nextPutAll: ' ('; + nextPutAll: anError class name; + nextPutAll: '): '; + nextPutAll: anError messageText ] ] { #category : 'private' } diff --git a/src/MCP/MCPToolRepositoryOperation.class.st b/src/MCP/MCPToolRepositoryOperation.class.st index 2d66626..57e097d 100644 --- a/src/MCP/MCPToolRepositoryOperation.class.st +++ b/src/MCP/MCPToolRepositoryOperation.class.st @@ -26,17 +26,6 @@ MCPToolRepositoryOperation >> branchNameSchemaProperty [ description: 'Branch name.' ] -{ #category : 'metadata' } -MCPToolRepositoryOperation >> buildInputSchema [ - - ^ MCPStructureInputSchema new - type: 'object'; - properties: self inputProperties; - required: self requiredInputProperties; - additionalProperties: false; - yourself -] - { #category : 'metadata' } MCPToolRepositoryOperation >> buildOutputSchema [ @@ -58,96 +47,12 @@ MCPToolRepositoryOperation >> commandForRequest: repositoryRequest [ ^ self commandClass tool: self request: repositoryRequest ] -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryAdoptHeadResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryAttachResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryCheckoutBranchResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryCommitResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryCreateBranchResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryCreateResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryDiffResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryExportResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryFetchResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryPullResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryPushResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - { #category : 'private - results' } MCPToolRepositoryOperation >> dataForRepositoryResult: aResult [ ^ aResult asDictionary ] -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositorySwitchBranchResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryUpdateResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - -{ #category : 'private - results' } -MCPToolRepositoryOperation >> dataForRepositoryVerifyIdentityResult: aResult [ - - ^ self dataForRepositoryResult: aResult -] - { #category : 'metadata' } MCPToolRepositoryOperation >> description [ @@ -160,8 +65,8 @@ MCPToolRepositoryOperation >> errorResultForCommandError: anError action: action | details | details := anError structuredDetails copy. requestedContext ifNotNil: [ - requestedContext keysAndValuesDo: [ :key :value | - value ifNotNil: [ details at: key ifAbsentPut: [ value ] ] ] ]. + requestedContext keysAndValuesDo: [ :key :value | + value ifNotNil: [ details at: key ifAbsentPut: [ value ] ] ] ]. details at: #action put: action. ^ self errorResultText: anError messageText details: details ] @@ -173,9 +78,7 @@ MCPToolRepositoryOperation >> inputProperties [ at: #referenceInputProperties ifAbsent: [ self repositoryReferenceInputProperties ]) , - (self repositoryToolSpec - at: #inputProperties - ifAbsent: [ #( ) ]) + (self repositoryToolSpec at: #inputProperties ifAbsent: [ #( ) ]) ] { #category : 'private - schema' } @@ -437,13 +340,3 @@ MCPToolRepositoryOperation >> title [ ^ self repositoryToolSpec at: #title ] - -{ #category : 'validating' } -MCPToolRepositoryOperation >> validateRequest: request [ - - self requiredInputProperties do: [ :each | - (request argumentNamed: each ifAbsent: [ nil ]) ifNil: [ - MCPInvalidToolInput - signalMissingRequiredArgumentNamed: each - forTool: self ] ] -] diff --git a/src/MCP/MCPToolRequest.class.st b/src/MCP/MCPToolRequest.class.st index 298cd3c..a9d6c81 100644 --- a/src/MCP/MCPToolRequest.class.st +++ b/src/MCP/MCPToolRequest.class.st @@ -195,8 +195,8 @@ MCPToolRequest >> stringCollectionFrom: aValue [ aValue ifNil: [ ^ #( ) ]. values := OrderedCollection new. aValue do: [ :each | - (self stringValue: each) ifNotNil: [ :normalized | - values add: normalized ] ]. + (self stringValue: each) ifNotNil: [ :normalized | + values add: normalized ] ]. ^ values asArray ] diff --git a/src/MCP/MCPToolRequestCommand.class.st b/src/MCP/MCPToolRequestCommand.class.st new file mode 100644 index 0000000..d9db796 --- /dev/null +++ b/src/MCP/MCPToolRequestCommand.class.st @@ -0,0 +1,47 @@ +" +Abstract command for tool executions that carry the invoking tool and one validated request object. + +Subclasses implement #execute and use #tool and #request to collaborate with the owning tool and request. +" +Class { + #name : 'MCPToolRequestCommand', + #superclass : 'MCPCommand', + #instVars : [ + 'tool', + 'request' + ], + #category : 'MCP-Commands', + #package : 'MCP', + #tag : 'Commands' +} + +{ #category : 'testing' } +MCPToolRequestCommand class >> isAbstract [ + + ^ self == MCPToolRequestCommand +] + +{ #category : 'instance creation' } +MCPToolRequestCommand class >> tool: aTool request: aRequest [ + + ^ self new initializeTool: aTool request: aRequest +] + +{ #category : 'initialization' } +MCPToolRequestCommand >> initializeTool: aTool request: aRequest [ + + tool := aTool. + request := aRequest +] + +{ #category : 'accessing' } +MCPToolRequestCommand >> request [ + + ^ request +] + +{ #category : 'accessing' } +MCPToolRequestCommand >> tool [ + + ^ tool +] diff --git a/src/MCP/MCPToolRewriteMethods.class.st b/src/MCP/MCPToolRewriteMethods.class.st index 3474708..24efe39 100644 --- a/src/MCP/MCPToolRewriteMethods.class.st +++ b/src/MCP/MCPToolRewriteMethods.class.st @@ -69,10 +69,10 @@ MCPToolRewriteMethods >> executeWithRequest: request [ do: [ :rewriteRequest | (self commandForRequest: rewriteRequest) execute ] onError: [ :error :rewriteRequest | - self - errorResultForRewriteError: error - request: rewriteRequest - rawRequest: request ] + self + errorResultForRewriteError: error + request: rewriteRequest + rawRequest: request ] ] { #category : 'private - execution' } @@ -257,7 +257,7 @@ MCPToolRewriteMethods >> validateRequest: request [ ((request booleanArgumentNamed: 'apply' default: false) and: [ (request hasArgumentNamed: 'expectedChangeSetHash') not ]) ifTrue: [ - MCPInvalidToolInput - signalMissingRequiredArgumentNamed: 'expectedChangeSetHash' - forTool: self ] + MCPInvalidToolInput + signalMissingRequiredArgumentNamed: 'expectedChangeSetHash' + forTool: self ] ] diff --git a/src/MCP/MCPToolRunTestCoverage.class.st b/src/MCP/MCPToolRunTestCoverage.class.st index 4d352b3..5bd3bc5 100644 --- a/src/MCP/MCPToolRunTestCoverage.class.st +++ b/src/MCP/MCPToolRunTestCoverage.class.st @@ -18,60 +18,35 @@ MCPToolRunTestCoverage class >> toolName [ { #category : 'metadata' } MCPToolRunTestCoverage >> buildInputSchema [ + | timeoutProperty | + timeoutProperty := self + integerSchemaPropertyNamed: 'timeoutSeconds' + description: + 'Timeout seconds; 0 returns immediately.' + default: self defaultTimeoutSeconds. + timeoutProperty minimum: 0. ^ MCPStructureInputSchema new type: 'object'; - properties: { - ((MCPStructureProperties new - name: 'tests'; - type: 'array'; - description: 'Test requests.') - items: self testRequestObjectSchema; - yourself). - self coverageOptionsObjectSchema. - (self - integerSchemaPropertyNamed: 'timeoutSeconds' - description: 'Timeout in seconds; 0 returns immediately.' - default: self defaultTimeoutSeconds). - (self - integerSchemaPropertyNamed: 'timeoutMilliseconds' - description: 'Timeout in milliseconds.') }; - required: #( 'tests' 'coverage' ); + properties: self testSelectionInputProperties , { + self coverageOptionsObjectSchema. + timeoutProperty }; + required: #( 'coverage' ); yourself ] { #category : 'metadata' } MCPToolRunTestCoverage >> buildOutputSchema [ - | coverageProperty resultsProperty unrunTestsProperty | - resultsProperty := self - schemaPropertyNamed: 'results' - type: 'array' - description: - 'Structured results for each test execution request in the batch that completed before timeout.'. - resultsProperty items: self testResultObjectSchema. - unrunTestsProperty := self - schemaPropertyNamed: 'unrunTests' - type: 'array' - description: - 'Test execution requests that did not run because the batch timed out. Pass this array to test_coverage_run to continue from the timeout point.'. - unrunTestsProperty items: self testRequestObjectSchema. - coverageProperty := self coverageResultObjectSchema. ^ self - standardOutputSchemaForDataProperties: { - resultsProperty. - coverageProperty. - (self - booleanSchemaPropertyNamed: 'timedOut' - description: - 'Whether the batch stopped early because timeoutSeconds elapsed.'). - unrunTestsProperty } - required: #( 'results' 'coverage' ) + standardOutputSchemaForDataProperties: + self testRunDataProperties , { self coverageResultObjectSchema } + required: #( 'runCount' 'passedCount' 'coverage' ) ] { #category : 'metadata' } MCPToolRunTestCoverage >> description [ - ^ 'Run test classes or individual test methods under coverage and return aggregated test and method coverage results.' + ^ 'Run tests under coverage return compact aggregate test coverage results.' ] { #category : 'private - request' } diff --git a/src/MCP/MCPToolRunTests.class.st b/src/MCP/MCPToolRunTests.class.st index 199fea5..4da250a 100644 --- a/src/MCP/MCPToolRunTests.class.st +++ b/src/MCP/MCPToolRunTests.class.st @@ -1,5 +1,7 @@ " -Run SUnit test classes or individual methods and return structured per-selection results. Coverage is exposed by MCPToolRunTestCoverage while both tools share the same command pipeline. +Run test packages, classes, or methods and return compact aggregate results. + +MCPToolRunTestCoverage reuses the same selection and execution pipeline with coverage collection enabled. " Class { #name : 'MCPToolRunTests', @@ -20,51 +22,26 @@ MCPToolRunTests class >> toolName [ { #category : 'metadata' } MCPToolRunTests >> buildInputSchema [ + | timeoutProperty | + timeoutProperty := self + integerSchemaPropertyNamed: 'timeoutSeconds' + description: + 'Timeout seconds; 0 returns immediately.' + default: self defaultTimeoutSeconds. + timeoutProperty minimum: 0. ^ MCPStructureInputSchema new type: 'object'; - properties: { - ((MCPStructureProperties new - name: 'tests'; - type: 'array'; - description: 'Test requests.') - items: self testRequestObjectSchema; - yourself). - (self - integerSchemaPropertyNamed: 'timeoutSeconds' - description: 'Timeout in seconds; 0 returns immediately.' - default: self defaultTimeoutSeconds). - (self - integerSchemaPropertyNamed: 'timeoutMilliseconds' - description: 'Timeout in milliseconds.') }; - required: #( 'tests' ); + properties: + self testSelectionInputProperties , { timeoutProperty }; yourself ] { #category : 'metadata' } MCPToolRunTests >> buildOutputSchema [ - | resultsProperty unrunTestsProperty | - resultsProperty := self - schemaPropertyNamed: 'results' - type: 'array' - description: - 'Structured results for each test execution request in the batch that completed before timeout.'. - resultsProperty items: self testResultObjectSchema. - unrunTestsProperty := self - schemaPropertyNamed: 'unrunTests' - type: 'array' - description: - 'Test execution requests that did not run because the batch timed out. Pass this array to test_run to continue from the timeout point.'. - unrunTestsProperty items: self testRequestObjectSchema. ^ self - standardOutputSchemaForDataProperties: { - resultsProperty. - (self - booleanSchemaPropertyNamed: 'timedOut' - description: - 'Whether the batch stopped early because timeoutSeconds elapsed.'). - unrunTestsProperty } - required: #( 'results' ) + standardOutputSchemaForDataProperties: self testRunDataProperties + required: #( 'runCount' 'passedCount' ) ] { #category : 'private - execution' } @@ -246,7 +223,7 @@ MCPToolRunTests >> defaultTimeoutSeconds [ { #category : 'metadata' } MCPToolRunTests >> description [ - ^ 'Run test classes or individual test methods as a batch and return aggregated results.' + ^ 'Run test packages, classes, methods return compact aggregate results.' ] { #category : 'private' } @@ -263,8 +240,7 @@ MCPToolRunTests >> errorResultForError: anError testNames: testNames [ (self failureMessageForTestNames: testNames error: toolError) details: { (#errorClass -> toolError class name). - (#message -> toolError messageText). - (#tests -> testNames) } asDictionary ] + (#message -> toolError messageText) } asDictionary ] ] { #category : 'executing' } @@ -289,9 +265,12 @@ MCPToolRunTests >> executeWithRequest: request [ MCPToolRunTests >> failureMessageForTestNames: testNames error: anError [ ^ String streamContents: [ :stream | + stream nextPutAll: 'Unable to run tests'. + testNames ifNotEmpty: [ + stream + nextPutAll: ': '; + nextPutAll: (', ' join: testNames) ]. stream - nextPutAll: 'Unable to run tests: '; - nextPutAll: (', ' join: testNames); nextPutAll: ' ('; nextPutAll: anError class name; nextPutAll: '): '; @@ -304,220 +283,109 @@ MCPToolRunTests >> parsedRequestFromToolRequest: request [ ^ MCPRunTestsRequest fromRequest: request tool: self operation: 'run' ] -{ #category : 'private - tests' } -MCPToolRunTests >> standardTestDataPropertiesIncludingMethodName: includeMethodName [ - - | issuesProperty properties | - properties := OrderedCollection withAll: { - (self - schemaPropertyNamed: 'className' - type: 'string' - description: 'The test class that was executed.'). - (self - integerSchemaPropertyNamed: 'selectedTestCount' - description: - 'The number of unique concrete test cases selected for this request after batch deduplication.'). - (self - integerSchemaPropertyNamed: 'runCount' - description: - 'The number of non-skipped test cases that ran.'). - (self - integerSchemaPropertyNamed: 'passedCount' - description: - 'The number of test cases that passed.'). - (self - integerSchemaPropertyNamed: 'skippedCount' - description: - 'The number of test cases that were skipped.'). - (self - integerSchemaPropertyNamed: 'failureCount' - description: - 'The number of test cases that failed assertions.'). - (self - integerSchemaPropertyNamed: 'errorCount' - description: - 'The number of test cases that raised errors.') }. - includeMethodName ifTrue: [ - properties add: (self - schemaPropertyNamed: 'testMethodName' - type: 'string' - description: 'The single test method that was executed.') ]. - issuesProperty := self - schemaPropertyNamed: 'issues' - type: 'array' - description: - 'Detailed issues captured while running tests.'. - issuesProperty items: self testIssueObjectSchema. - properties add: issuesProperty. - ^ properties asArray +{ #category : 'private - errors' } +MCPToolRunTests >> rawStringCollectionNamed: argumentName fromRequest: rawRequest [ + + | value | + value := rawRequest argumentNamed: argumentName ifAbsent: [ ^ #( ) ]. + value isArray ifFalse: [ ^ #( ) ]. + ^ (value collect: [ :each | each asString ]) asArray ] -{ #category : 'private - tests' } -MCPToolRunTests >> standardTestRequiredFieldsIncludingMethodName: includeMethodName [ - - | required | - required := OrderedCollection withAll: - #( 'className' 'selectedTestCount' 'runCount' 'passedCount' - 'skippedCount' 'failureCount' 'errorCount' ). - includeMethodName ifTrue: [ required add: 'testMethodName' ]. - ^ required asArray +{ #category : 'private - errors' } +MCPToolRunTests >> rawTestNamesFromRequest: rawRequest [ + + ^ Array streamContents: [ :stream | + #( 'packages' 'classes' 'methods' ) do: [ :argumentName | + (self + rawStringCollectionNamed: argumentName + fromRequest: rawRequest) do: [ :each | stream nextPut: each ] ] ] ] { #category : 'private' } MCPToolRunTests >> successSummaryForData: data [ - | coverage errorCount failureCount failureLikeCount results runCount selectedTestCount selectionCount selectionWord skippedCount timedOut unrunCount | - results := data at: #results. - selectionCount := results size. - selectionWord := selectionCount = 1 - ifTrue: [ 'test selection' ] - ifFalse: [ 'test selections' ]. - selectedTestCount := results - inject: 0 - into: [ :sum :each | - sum + (each at: #selectedTestCount) ]. - runCount := results - inject: 0 - into: [ :sum :each | sum + (each at: #runCount) ]. - skippedCount := results - inject: 0 - into: [ :sum :each | sum + (each at: #skippedCount) ]. - failureCount := results - inject: 0 - into: [ :sum :each | sum + (each at: #failureCount) ]. - errorCount := results - inject: 0 - into: [ :sum :each | sum + (each at: #errorCount) ]. - failureLikeCount := failureCount + errorCount. + | coverage errorCount failureCount passedCount runCount skippedCount timedOut unrunCount | + runCount := data at: #runCount. + passedCount := data at: #passedCount. + skippedCount := (data at: #skipped ifAbsent: [ #( ) ]) size. + failureCount := (data at: #failures ifAbsent: [ #( ) ]) size. + errorCount := (data at: #errors ifAbsent: [ #( ) ]) size. timedOut := data at: #timedOut ifAbsent: [ false ]. - unrunCount := (data at: #unrunTests ifAbsent: [ #( ) ]) size. + unrunCount := (data at: #unrunPackages ifAbsent: [ #( ) ]) size + + (data at: #unrunClasses ifAbsent: [ #( ) ]) size + + (data at: #unrunMethods ifAbsent: [ #( ) ]) size. coverage := data at: #coverage ifAbsent: [ nil ]. ^ String streamContents: [ :stream | timedOut ifTrue: [ stream nextPutAll: 'Timed out. ' ]. stream - nextPutAll: 'Executed '; - nextPutAll: selectionCount asString; - nextPutAll: ' '; - nextPutAll: selectionWord; - nextPutAll: ' covering '; - nextPutAll: selectedTestCount asString; - nextPutAll: ' unique tests ('; + nextPutAll: 'Ran '; nextPutAll: runCount asString; - nextPutAll: ' ran'. + nextPutAll: ' tests ('; + nextPutAll: passedCount asString; + nextPutAll: ' passed'. skippedCount > 0 ifTrue: [ stream nextPutAll: ', '; nextPutAll: skippedCount asString; nextPutAll: ' skipped' ]. stream nextPutAll: ').'. - failureLikeCount > 0 ifTrue: [ + failureCount + errorCount > 0 ifTrue: [ stream space; nextPutAll: failureCount asString; - nextPutAll: ' failures and '; + nextPutAll: ' failures, '; nextPutAll: errorCount asString; - nextPutAll: ' errors were reported.' ]. - timedOut ifTrue: [ + nextPutAll: ' errors.' ]. + unrunCount > 0 ifTrue: [ stream space; nextPutAll: unrunCount asString; - nextPutAll: ' test requests remain in unrunTests.' ]. - coverage ifNotNil: [ + nextPutAll: ' selections left unrun.' ]. + coverage ifNotNil: [ :coverageData | stream space; nextPutAll: 'Coverage: '; - nextPutAll: (self coveragePercentageTextFor: coverage); - nextPutAll: ' over '; - nextPutAll: (coverage at: #methodCount) asString; - nextPutAll: ' methods; '; - nextPutAll: (coverage at: #uncoveredMethodCount) asString; - nextPutAll: ' uncovered, '; - nextPutAll: - (coverage at: #partiallyCoveredMethodCount) asString; - nextPutAll: ' partially covered.' ] ] + nextPutAll: (self coveragePercentageTextFor: coverageData); + nextPutAll: '%.' ] ] ] { #category : 'private - tests' } -MCPToolRunTests >> testIssueObjectSchema [ +MCPToolRunTests >> testIssueArraySchemaNamed: propertyName description: propertyDescription [ - | issueProperty | - issueProperty := MCPStructureProperties new - type: 'object'; - description: - 'A single test issue recorded while running tests.'; - properties: { - (self - schemaPropertyNamed: 'kind' - type: 'string' - description: - 'The issue category, such as failure, error, or skipped.'). - (self - schemaPropertyNamed: 'className' - type: 'string' - description: - 'The test class that produced the issue.'). - (self - schemaPropertyNamed: 'testMethodName' - type: 'string' - description: - 'The test method that produced the issue.'). - (self - schemaPropertyNamed: 'testCaseName' - type: 'string' - description: - 'The concrete test case name, including parameter values when available.'). - (self - stringArraySchemaNamed: 'parameters' - description: - 'Parameter bindings for the concrete test case when the issue came from a parameterized test.' - itemDescription: - 'A printed parameter binding, such as #encoding->''UTF-16''.'). - (self - schemaPropertyNamed: 'errorClass' - type: 'string' - description: - 'The exception class captured for the issue.'). - (self - schemaPropertyNamed: 'message' - type: 'string' - description: - 'The exception message for the issue.'). - (self - schemaPropertyNamed: 'description' - type: 'string' - description: - 'A longer textual description of the issue when available.'). - (self - schemaPropertyNamed: 'signalerContext' - type: 'string' - description: - 'The signaler context captured for the issue when available.') }; - required: - #( 'kind' 'className' 'testMethodName' - 'errorClass' 'message' ); - additionalProperties: false; - yourself. - ^ issueProperty + ^ (self + schemaPropertyNamed: propertyName + type: 'array' + description: propertyDescription) + items: self testIssueObjectSchema; + yourself ] -{ #category : 'private - errors' } -MCPToolRunTests >> testNameFromRawTestValue: rawValue request: rawRequest [ - - | className testMethodName | - rawValue isDictionary ifFalse: [ ^ rawValue asString ]. - className := rawRequest - valueNamed: 'className' - in: rawValue - ifAbsent: [ ^ rawValue asString ]. - className ifNil: [ ^ rawValue asString ]. - testMethodName := rawRequest - valueNamed: 'testMethodName' - in: rawValue - ifAbsent: [ nil ]. - ^ testMethodName - ifNil: [ className asString ] - ifNotNil: [ :methodName | - className asString , '>>' , methodName asString ] +{ #category : 'private - tests' } +MCPToolRunTests >> testIssueObjectSchema [ + + ^ MCPStructureProperties new + type: 'object'; + properties: { + (self + schemaPropertyNamed: 'test' + type: 'string' + description: 'Test reference.'). + (self + schemaPropertyNamed: 'message' + type: 'string' + description: 'Failure or error message.'). + (self + schemaPropertyNamed: 'errorClass' + type: 'string' + description: 'Error class.'). + (self + stringArraySchemaNamed: 'parameters' + description: 'Parameterized test values.' + itemDescription: nil) }; + required: #( 'test' ); + additionalProperties: false; + yourself ] { #category : 'private - errors' } @@ -525,9 +393,7 @@ MCPToolRunTests >> testNamesForErrorFromParsedRequest: runTestsRequest rawReques runTestsRequest ifNotNil: [ ^ self testNamesFromRequests: runTestsRequest testRequests ]. - ^ ((rawRequest objectCollectionArgumentNamed: 'tests') collect: [ - :each | self testNameFromRawTestValue: each request: rawRequest ]) - asArray + ^ self rawTestNamesFromRequest: rawRequest ] { #category : 'private - errors' } @@ -536,47 +402,59 @@ MCPToolRunTests >> testNamesFromRequests: testRequests [ ^ (testRequests collect: [ :each | each displayName ]) asArray ] -{ #category : 'private' } -MCPToolRunTests >> testRequestObjectSchema [ - - ^ MCPStructureProperties new - type: 'object'; - description: 'Test request.'; - properties: { - (self - schemaPropertyNamed: 'className' - type: 'string' - description: 'Test class.'). - (self - schemaPropertyNamed: 'testMethodName' - type: 'string' - description: 'Test method.') }; - required: #( 'className' ); - additionalProperties: false; - yourself +{ #category : 'private - tests' } +MCPToolRunTests >> testRunDataProperties [ + + ^ { + (self + integerSchemaPropertyNamed: 'runCount' + description: 'Tests run.'). + (self + integerSchemaPropertyNamed: 'passedCount' + description: 'Tests passed.'). + (self + stringArraySchemaNamed: 'skipped' + description: 'Skipped tests.' + itemDescription: nil). + (self + testIssueArraySchemaNamed: 'failures' + description: 'Failed tests.'). + (self + testIssueArraySchemaNamed: 'errors' + description: 'Errored tests.'). + (self + booleanSchemaPropertyNamed: 'timedOut' + description: 'Timeout stopped run.'). + (self + stringArraySchemaNamed: 'unrunPackages' + description: 'Unrun test packages.' + itemDescription: nil). + (self + stringArraySchemaNamed: 'unrunClasses' + description: 'Unrun test classes.' + itemDescription: nil). + (self + stringArraySchemaNamed: 'unrunMethods' + description: 'Unrun test methods.' + itemDescription: nil) } ] -{ #category : 'private' } -MCPToolRunTests >> testResultObjectSchema [ - - | properties | - properties := OrderedCollection withAll: - (self standardTestDataPropertiesIncludingMethodName: - false). - properties add: (self - schemaPropertyNamed: 'testMethodName' - type: 'string' - description: - 'The single test method that was executed when the batch entry targeted one method.'). - ^ MCPStructureProperties new - type: 'object'; - description: - 'Structured results for one test execution request in the batch.'; - properties: properties asArray; - required: - (self standardTestRequiredFieldsIncludingMethodName: false); - additionalProperties: false; - yourself +{ #category : 'private - tests' } +MCPToolRunTests >> testSelectionInputProperties [ + + ^ { + (self + stringArraySchemaNamed: 'packages' + description: 'Test packages run.' + itemDescription: nil). + (self + stringArraySchemaNamed: 'classes' + description: 'Test classes run.' + itemDescription: nil). + (self + stringArraySchemaNamed: 'methods' + description: 'Test methods as Class>>#selector.' + itemDescription: nil) } ] { #category : 'metadata' } diff --git a/src/MCP/MCPToolSearch.class.st b/src/MCP/MCPToolSearch.class.st index 96dfd35..d7ff006 100644 --- a/src/MCP/MCPToolSearch.class.st +++ b/src/MCP/MCPToolSearch.class.st @@ -53,8 +53,8 @@ MCPToolSearch >> classAndMethodScopeSummaryFromAssociations: scopeAssociations [ | labels | labels := OrderedCollection new. scopeAssociations do: [ :eachAssociation | - eachAssociation value notEmpty ifTrue: [ - self addScopeLabel: eachAssociation key to: labels ] ]. + eachAssociation value notEmpty ifTrue: [ + self addScopeLabel: eachAssociation key to: labels ] ]. ^ self scopeSummaryFromLabels: labels ] @@ -160,23 +160,23 @@ MCPToolSearch >> executeWithRequest: request [ ^ self executeParsedRequestFrom: request do: [ :queryRequest | - | command page | - command := self commandForRequest: queryRequest. - page := self - queryPageForEntries: command execute - limit: (self limitFromQueryRequest: queryRequest) - offset: (self offsetFromQueryRequest: queryRequest). - self - successResultText: - (self successSummaryForQueryRequest: queryRequest page: page) - data: - (self queryResultDataForQueryRequest: queryRequest page: page) - warnings: (self warningsForQueryRequest: queryRequest) ] + | command page | + command := self commandForRequest: queryRequest. + page := self + queryPageForEntries: command execute + limit: (self limitFromQueryRequest: queryRequest) + offset: (self offsetFromQueryRequest: queryRequest). + self + successResultText: + (self successSummaryForQueryRequest: queryRequest page: page) + data: + (self queryResultDataForQueryRequest: queryRequest page: page) + warnings: (self warningsForQueryRequest: queryRequest) ] onError: [ :error :ignored | - self - errorResultForQueryError: error - requestedContext: - (self requestedContextForErrorFromRequest: request) ] + self + errorResultForQueryError: error + requestedContext: + (self requestedContextForErrorFromRequest: request) ] ] { #category : 'private - template' } @@ -286,27 +286,27 @@ MCPToolSearch >> matcherForPattern: aPattern mode: aMode caseSensitive: aBoolean | normalizedPattern regex | aPattern ifNil: [ ^ [ :candidate | true ] ]. aMode = 'regex' ifTrue: [ - regex := aBoolean - ifTrue: [ aPattern asRegex ] - ifFalse: [ aPattern asRegexIgnoringCase ]. - ^ [ :candidate | - regex search: - (candidate ifNil: [ '' ] ifNotNil: [ candidate asString ]) ] ]. + regex := aBoolean + ifTrue: [ aPattern asRegex ] + ifFalse: [ aPattern asRegexIgnoringCase ]. + ^ [ :candidate | + regex search: + (candidate ifNil: [ '' ] ifNotNil: [ candidate asString ]) ] ]. normalizedPattern := self normalizeFilterString: aPattern caseSensitive: aBoolean. aMode = 'substring' ifTrue: [ - ^ [ :candidate | - (self normalizeFilterString: candidate caseSensitive: aBoolean) - includesSubstring: normalizedPattern ] ]. + ^ [ :candidate | + (self normalizeFilterString: candidate caseSensitive: aBoolean) + includesSubstring: normalizedPattern ] ]. aMode = 'prefix' ifTrue: [ - ^ [ :candidate | - (self normalizeFilterString: candidate caseSensitive: aBoolean) - beginsWith: normalizedPattern ] ]. + ^ [ :candidate | + (self normalizeFilterString: candidate caseSensitive: aBoolean) + beginsWith: normalizedPattern ] ]. aMode = 'exact' ifTrue: [ - ^ [ :candidate | - (self normalizeFilterString: candidate caseSensitive: aBoolean) - = normalizedPattern ] ]. + ^ [ :candidate | + (self normalizeFilterString: candidate caseSensitive: aBoolean) + = normalizedPattern ] ]. Error signal: 'Unsupported filter mode: ' , aMode ] @@ -431,7 +431,10 @@ MCPToolSearch >> queryInputSchemaWithProperties: inputProperties [ { #category : 'private - pagination' } MCPToolSearch >> queryPageForEntries: entries limit: limit offset: offset [ - ^ MCPPaginationResult fromEntries: entries limit: limit offset: offset + ^ MCPPaginationResult + fromEntries: entries + limit: limit + offset: offset ] { #category : 'private - template' } @@ -464,15 +467,15 @@ MCPToolSearch >> requestedContextFromRequest: request [ MCPToolSearch >> scopeQueryFailureMessageFor: resultKind scope: scopeSummary error: anError [ ^ String streamContents: [ :stream | - stream - nextPutAll: 'Unable to query '; - nextPutAll: resultKind; - nextPutAll: ' [scope='; - nextPutAll: scopeSummary; - nextPutAll: '] ('; - nextPutAll: anError class name; - nextPutAll: '): '; - nextPutAll: anError messageText ] + stream + nextPutAll: 'Unable to query '; + nextPutAll: resultKind; + nextPutAll: ' [scope='; + nextPutAll: scopeSummary; + nextPutAll: '] ('; + nextPutAll: anError class name; + nextPutAll: '): '; + nextPutAll: anError messageText ] ] { #category : 'private - results' } @@ -498,9 +501,9 @@ MCPToolSearch >> scopeSummaryFromLabels: labels [ labels ifEmpty: [ ^ 'image' ]. ^ String streamContents: [ :stream | - labels doWithIndex: [ :each :index | - index > 1 ifTrue: [ stream nextPut: $+ ]. - stream nextPutAll: each ] ] + labels doWithIndex: [ :each :index | + index > 1 ifTrue: [ stream nextPut: $+ ]. + stream nextPutAll: each ] ] ] { #category : 'private - template' } @@ -550,6 +553,16 @@ MCPToolSearch >> searchScopeStringCollectionNamed: aName fromRequest: request [ { #category : 'private - template' } MCPToolSearch >> successSummaryForQueryRequest: queryRequest page: page [ + ^ self + successSummaryForScope: + (self classAndMethodScopeSummaryForScopeQuery: + queryRequest scopeQuery) + page: page +] + +{ #category : 'private - results' } +MCPToolSearch >> successSummaryForScope: scopeDescription page: page [ + self subclassResponsibility ] diff --git a/src/MCP/MCPToolSearchClasses.class.st b/src/MCP/MCPToolSearchClasses.class.st index 8ef3995..0cd02de 100644 --- a/src/MCP/MCPToolSearchClasses.class.st +++ b/src/MCP/MCPToolSearchClasses.class.st @@ -200,16 +200,6 @@ MCPToolSearchClasses >> searchRequestFromToolRequest: request [ ^ MCPSearchClassesRequest fromRequest: request tool: self ] -{ #category : 'private - template' } -MCPToolSearchClasses >> successSummaryForQueryRequest: queryRequest page: page [ - - ^ self - successSummaryForScope: - (self classAndMethodScopeSummaryForScopeQuery: - queryRequest scopeQuery) - page: page -] - { #category : 'private - results' } MCPToolSearchClasses >> successSummaryForScope: scopeSummary page: page [ diff --git a/src/MCP/MCPToolSearchRepositories.class.st b/src/MCP/MCPToolSearchRepositories.class.st index e0cf486..bfbb11e 100644 --- a/src/MCP/MCPToolSearchRepositories.class.st +++ b/src/MCP/MCPToolSearchRepositories.class.st @@ -273,8 +273,8 @@ MCPToolSearchRepositories >> repositoryScopeSummaryForAssociations: scopeAssocia | labels | labels := OrderedCollection new. scopeAssociations do: [ :eachAssociation | - eachAssociation value ifTrue: [ - self addScopeLabel: eachAssociation key to: labels ] ]. + eachAssociation value ifTrue: [ + self addScopeLabel: eachAssociation key to: labels ] ]. ^ self scopeSummaryFromLabels: labels ] diff --git a/src/MCP/MCPToolUpdateDebugMethod.class.st b/src/MCP/MCPToolUpdateDebugMethod.class.st index 4d333a9..e5a71e3 100644 --- a/src/MCP/MCPToolUpdateDebugMethod.class.st +++ b/src/MCP/MCPToolUpdateDebugMethod.class.st @@ -91,7 +91,8 @@ MCPToolUpdateDebugMethod >> buildOutputSchema [ (self schemaPropertyNamed: 'stateId' type: 'string' - description: 'Debug state token after the update/proceed cycle.'). + description: + 'Debug state token after the update/proceed cycle.'). (self schemaPropertyNamed: 'frameRef' type: 'string' @@ -143,7 +144,8 @@ MCPToolUpdateDebugMethod >> buildOutputSchema [ (self schemaPropertyNamed: 'repairActions' type: 'array' - description: 'Repair actions still available after the update.'). + description: + 'Repair actions still available after the update.'). (self stringArraySchemaNamed: 'warnings' description: 'Update-specific warnings.' diff --git a/src/MCP/MCPUpdateClassCommand.class.st b/src/MCP/MCPUpdateClassCommand.class.st index 8c5fa01..6df8962 100644 --- a/src/MCP/MCPUpdateClassCommand.class.st +++ b/src/MCP/MCPUpdateClassCommand.class.st @@ -5,7 +5,7 @@ It builds an MCPClassUpdatePlanInfo for the selected internal update action, dis " Class { #name : 'MCPUpdateClassCommand', - #superclass : 'Object', + #superclass : 'MCPCommand', #instVars : [ 'tool', 'classRequest' @@ -42,10 +42,10 @@ MCPUpdateClassCommand >> execute [ [ plan := self updatePlan ] on: MCPCommandError do: [ :error | - ^ self tool - errorResultForCommandError: error - action: 'update' - requestedContext: self validationContext ]. + ^ self tool + errorResultForCommandError: error + action: 'update' + requestedContext: self validationContext ]. ^ self executePlan: plan ] @@ -58,27 +58,27 @@ MCPUpdateClassCommand >> executeAddSlotWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPAddSlotCommand - className: self classRequest className - slotName: self classRequest slotName - classSide: self classRequest classSide) execute ] + result := (MCPAddSlotCommand + className: self classRequest className + slotName: self classRequest slotName + classSide: self classRequest classSide) execute ] successResult: [ :warningMessages | - self tool - successResultText: 'Added ' - , - (self tool slotDescriptionForClassSide: - self classRequest classSide) , ' ' - , self classRequest slotName , ' to class ' - , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: 'Added ' + , + (self tool slotDescriptionForClassSide: + self classRequest classSide) , ' ' + , self classRequest slotName , ' to class ' + , self classRequest className , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForAddSlotNamed: self classRequest slotName - onClassNamed: self classRequest className - classSide: self classRequest classSide - error: error ] + self tool + failureMessageForAddSlotNamed: self classRequest slotName + onClassNamed: self classRequest className + classSide: self classRequest classSide + error: error ] ] { #category : 'private - planning' } @@ -119,25 +119,25 @@ MCPUpdateClassCommand >> executeMoveSlotAction: operation withPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPMoveSlotCommand - className: self classRequest className - slotName: self classRequest slotName - direction: operation - classSide: self classRequest classSide) execute ] + result := (MCPMoveSlotCommand + className: self classRequest className + slotName: self classRequest slotName + direction: operation + classSide: self classRequest classSide) execute ] successResult: [ :warningMessages | - self tool - successResultText: - (self successMessageForMoveSlotAction: operation) - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + (self successMessageForMoveSlotAction: operation) + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForMoveSlotNamed: self classRequest slotName - onClassNamed: self classRequest className - classSide: self classRequest classSide - operation: operation - error: error ] + self tool + failureMessageForMoveSlotNamed: self classRequest slotName + onClassNamed: self classRequest className + classSide: self classRequest classSide + operation: operation + error: error ] ] { #category : 'executing - class' } @@ -150,24 +150,24 @@ MCPUpdateClassCommand >> executeMoveWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPMoveClassCommand - className: self classRequest className - packageName: packageName - tag: self classRequest tag) execute ] + result := (MCPMoveClassCommand + className: self classRequest className + packageName: packageName + tag: self classRequest tag) execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Moved class ' , self classRequest className , ' to package ' - , packageName , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Moved class ' , self classRequest className , ' to package ' + , packageName , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForMoveClassNamed: self classRequest className - packageName: packageName - tag: self classRequest tag - error: error ] + self tool + failureMessageForMoveClassNamed: self classRequest className + packageName: packageName + tag: self classRequest tag + error: error ] ] { #category : 'executing' } @@ -208,27 +208,27 @@ MCPUpdateClassCommand >> executeRemoveSlotWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPRemoveSlotCommand - className: self classRequest className - slotName: self classRequest slotName - classSide: self classRequest classSide) execute ] + result := (MCPRemoveSlotCommand + className: self classRequest className + slotName: self classRequest slotName + classSide: self classRequest classSide) execute ] successResult: [ :warningMessages | - self tool - successResultText: 'Removed ' - , - (self tool slotDescriptionForClassSide: - self classRequest classSide) , ' ' - , self classRequest slotName , ' from class ' - , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: 'Removed ' + , + (self tool slotDescriptionForClassSide: + self classRequest classSide) , ' ' + , self classRequest slotName , ' from class ' + , self classRequest className , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForRemoveSlotNamed: self classRequest slotName - onClassNamed: self classRequest className - classSide: self classRequest classSide - error: error ] + self tool + failureMessageForRemoveSlotNamed: self classRequest slotName + onClassNamed: self classRequest className + classSide: self classRequest classSide + error: error ] ] { #category : 'executing - slot' } @@ -240,27 +240,27 @@ MCPUpdateClassCommand >> executeRenameSlotWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPRenameSlotCommand - className: self classRequest className - slotName: self classRequest slotName - newSlotName: self classRequest newSlotName - classSide: self classRequest classSide) execute ] + result := (MCPRenameSlotCommand + className: self classRequest className + slotName: self classRequest slotName + newSlotName: self classRequest newSlotName + classSide: self classRequest classSide) execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Renamed slot ' , self classRequest slotName , ' to ' - , self classRequest newSlotName , ' in class ' - , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Renamed slot ' , self classRequest slotName , ' to ' + , self classRequest newSlotName , ' in class ' + , self classRequest className , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForRenameSlotNamed: self classRequest slotName - to: self classRequest newSlotName - onClassNamed: self classRequest className - classSide: self classRequest classSide - error: error ] + self tool + failureMessageForRenameSlotNamed: self classRequest slotName + to: self classRequest newSlotName + onClassNamed: self classRequest className + classSide: self classRequest classSide + error: error ] ] { #category : 'executing - class' } @@ -272,29 +272,29 @@ MCPUpdateClassCommand >> executeRenameWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - targetClass := MCPImageLookup classNamed: - self classRequest className. - refactoringModel := self tool - refactoringModelForScopeSpec: - self classRequest refactoringScopeSpec - anchoredAtBehavior: targetClass. - result := (MCPRenameClassCommand - className: self classRequest className - newClassName: self classRequest newClassName - model: refactoringModel) execute ] + targetClass := MCPImageLookup classNamed: + self classRequest className. + refactoringModel := self tool + refactoringModelForScopeSpec: + self classRequest refactoringScopeSpec + anchoredAtBehavior: targetClass. + result := (MCPRenameClassCommand + className: self classRequest className + newClassName: self classRequest newClassName + model: refactoringModel) execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Renamed class ' , self classRequest className , ' to ' - , self classRequest newClassName , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Renamed class ' , self classRequest className , ' to ' + , self classRequest newClassName , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForRenameClassNamed: self classRequest className - to: self classRequest newClassName - error: error ] + self tool + failureMessageForRenameClassNamed: self classRequest className + to: self classRequest newClassName + error: error ] ] { #category : 'executing - class' } @@ -306,23 +306,24 @@ MCPUpdateClassCommand >> executeReparentWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPReparentClassCommand - className: self classRequest className - superclassName: self classRequest superclassName) - execute ] + result := (MCPReparentClassCommand + className: self classRequest className + superclassName: self classRequest superclassName) + execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Reparented class ' , self classRequest className - , ' to superclass ' , self classRequest superclassName , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Reparented class ' , self classRequest className + , ' to superclass ' , self classRequest superclassName , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForReparentClassNamed: self classRequest className - superclassName: self classRequest superclassName - error: error ] + self tool + failureMessageForReparentClassNamed: + self classRequest className + superclassName: self classRequest superclassName + error: error ] ] { #category : 'executing - class' } @@ -334,23 +335,23 @@ MCPUpdateClassCommand >> executeReplaceClassTraitsWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPReplaceClassSideTraitsCommand - className: self classRequest className - classTraitNames: self classRequest classTraits) - execute ] + result := (MCPReplaceClassSideTraitsCommand + className: self classRequest className + classTraitNames: self classRequest classTraits) + execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Replaced class-side traits for class ' - , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Replaced class-side traits for class ' + , self classRequest className , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForReplaceClassTraitsOnClassNamed: - self classRequest className - error: error ] + self tool + failureMessageForReplaceClassTraitsOnClassNamed: + self classRequest className + error: error ] ] { #category : 'executing - class' } @@ -371,18 +372,18 @@ MCPUpdateClassCommand >> executeReplaceDefinitionWithPlan: plan [ requestedContext: plan requestedContext work: [ result := command execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Replaced slot definition for class ' - , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Replaced slot definition for class ' + , self classRequest className , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForReplaceDefinitionOnClassNamed: - self classRequest className - error: error ] + self tool + failureMessageForReplaceDefinitionOnClassNamed: + self classRequest className + error: error ] ] { #category : 'executing - class' } @@ -394,21 +395,22 @@ MCPUpdateClassCommand >> executeReplaceLayoutWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPReplaceClassLayoutCommand - className: self classRequest className - layout: self classRequest layout) execute ] + result := (MCPReplaceClassLayoutCommand + className: self classRequest className + layout: self classRequest layout) execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Replaced layout for class ' , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Replaced layout for class ' , self classRequest className + , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForReplaceLayoutOnClassNamed: - self classRequest className - error: error ] + self tool + failureMessageForReplaceLayoutOnClassNamed: + self classRequest className + error: error ] ] { #category : 'executing - class' } @@ -420,23 +422,23 @@ MCPUpdateClassCommand >> executeReplaceSharedPoolsWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPReplaceClassSharedPoolsCommand - className: self classRequest className - sharedPoolNames: self classRequest sharedPools) - execute ] + result := (MCPReplaceClassSharedPoolsCommand + className: self classRequest className + sharedPoolNames: self classRequest sharedPools) + execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Replaced shared pools for class ' , self classRequest className - , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Replaced shared pools for class ' + , self classRequest className , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForReplaceSharedPoolsOnClassNamed: - self classRequest className - error: error ] + self tool + failureMessageForReplaceSharedPoolsOnClassNamed: + self classRequest className + error: error ] ] { #category : 'executing - class' } @@ -448,23 +450,23 @@ MCPUpdateClassCommand >> executeReplaceSharedVariablesWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPReplaceClassSharedVariablesCommand - className: self classRequest className - sharedVariableNames: - self classRequest sharedVariables) execute ] + result := (MCPReplaceClassSharedVariablesCommand + className: self classRequest className + sharedVariableNames: + self classRequest sharedVariables) execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Replaced shared variables for class ' - , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Replaced shared variables for class ' + , self classRequest className , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForReplaceSharedVariablesOnClassNamed: - self classRequest className - error: error ] + self tool + failureMessageForReplaceSharedVariablesOnClassNamed: + self classRequest className + error: error ] ] { #category : 'executing - class' } @@ -476,21 +478,22 @@ MCPUpdateClassCommand >> executeReplaceTraitsWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPReplaceClassTraitsCommand - className: self classRequest className - traitNames: self classRequest traits) execute ] + result := (MCPReplaceClassTraitsCommand + className: self classRequest className + traitNames: self classRequest traits) execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Replaced traits for class ' , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Replaced traits for class ' , self classRequest className + , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForReplaceTraitsOnClassNamed: - self classRequest className - error: error ] + self tool + failureMessageForReplaceTraitsOnClassNamed: + self classRequest className + error: error ] ] { #category : 'executing - class' } @@ -502,21 +505,22 @@ MCPUpdateClassCommand >> executeSetCommentWithPlan: plan [ force: self classRequest force requestedContext: plan requestedContext work: [ - result := (MCPChangeClassCommentCommand - className: self classRequest className - classComment: self classRequest classComment) execute ] + result := (MCPChangeClassCommentCommand + className: self classRequest className + classComment: self classRequest classComment) + execute ] successResult: [ :warningMessages | - self tool - successResultText: - 'Set comment for class ' , self classRequest className , '.' - data: (self tool dataForAppliedUpdateResult: - (self appliedUpdateResultFor: result plan: plan)) - warnings: warningMessages ] + self tool + successResultText: + 'Set comment for class ' , self classRequest className , '.' + data: (self tool dataForAppliedUpdateResult: + (self appliedUpdateResultFor: result plan: plan)) + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForSetCommentOnClassNamed: - self classRequest className - error: error ] + self tool + failureMessageForSetCommentOnClassNamed: + self classRequest className + error: error ] ] { #category : 'initialization' } @@ -550,12 +554,12 @@ MCPUpdateClassCommand >> requestedContextForAction: action [ | context | action = 'move' ifTrue: [ ^ self moveRequestedContext ]. action = 'rename' ifTrue: [ - context := self classRequest requestedContext. - self tool - addRefactoringScopeContextFromSpec: - self classRequest refactoringScopeSpec - toRequestedContext: context. - ^ context ]. + context := self classRequest requestedContext. + self tool + addRefactoringScopeContextFromSpec: + self classRequest refactoringScopeSpec + toRequestedContext: context. + ^ context ]. action = 'renameSlot' ifTrue: [ ^ self classRequest renameSlotRequestedContext ]. (#( 'addSlot' 'removeSlot' 'pullUpSlot' 'pushDownSlot' ) includes: @@ -592,8 +596,8 @@ MCPUpdateClassCommand >> successMessageForMoveSlotAction: operation [ slotDescription := self tool slotDescriptionForClassSide: self classRequest classSide. operation = 'pullUpSlot' ifTrue: [ - ^ 'Pulled up ' , slotDescription , ' ' , self classRequest slotName - , ' to class ' , self classRequest className , '.' ]. + ^ 'Pulled up ' , slotDescription , ' ' , self classRequest slotName + , ' to class ' , self classRequest className , '.' ]. ^ 'Pushed down ' , slotDescription , ' ' , self classRequest slotName , ' from class ' , self classRequest className , '.' ] diff --git a/src/MCP/MCPUpdateDebugMethodCommand.class.st b/src/MCP/MCPUpdateDebugMethodCommand.class.st index 47d1d90..e835ca0 100644 --- a/src/MCP/MCPUpdateDebugMethodCommand.class.st +++ b/src/MCP/MCPUpdateDebugMethodCommand.class.st @@ -57,8 +57,13 @@ MCPUpdateDebugMethodCommand >> compileForRecord: aRecord context: aContext updat updateKind: updateKind ]. (#( 'recompile' 'shouldBeImplemented' 'notYetImplemented' ) includes: updateKind) ifTrue: [ - ^ self recompileContext: aContext record: aRecord updateKind: updateKind ]. - ^ self signalUnsupportedUpdateForRecord: aRecord updateKind: updateKind + ^ self + recompileContext: aContext + record: aRecord + updateKind: updateKind ]. + ^ self + signalUnsupportedUpdateForRecord: aRecord + updateKind: updateKind ] { #category : 'private - compiling' } @@ -70,9 +75,9 @@ MCPUpdateDebugMethodCommand >> compileImplementationForRecord: aRecord context: messageForException: analyzer exception context: aContext. message ifNil: [ - ^ self - signalUnsupportedUpdateForRecord: aRecord - updateKind: updateKind ]. + ^ self + signalUnsupportedUpdateForRecord: aRecord + updateKind: updateKind ]. behavior := analyzer behaviorForContext: aContext. source := self methodSourceOrNil ifNil: [ analyzer @@ -148,7 +153,6 @@ MCPUpdateDebugMethodCommand >> compiledMethodForContext: aContext [ MCPUpdateDebugMethodCommand >> critiqueDataForMethod: aCompiledMethod [ ^ MCPToolCompileMethod new critiqueDataForMethod: aCompiledMethod - ] { #category : 'executing' } @@ -219,13 +223,6 @@ MCPUpdateDebugMethodCommand >> frameIndexForContext: aContext record: aRecord fa ^ (rawContexts indexOf: aContext ifAbsent: [ fallbackIndex + 1 ]) - 1 ] -{ #category : 'private - frames' } -MCPUpdateDebugMethodCommand >> frameRefForRecord: aRecord frameIndex: frameIndex [ - - ^ aRecord sessionId , '/' , aRecord stateId , '/frame-' - , frameIndex asString -] - { #category : 'private - data' } MCPUpdateDebugMethodCommand >> methodDataFor: aCompiledMethod [ @@ -270,7 +267,8 @@ MCPUpdateDebugMethodCommand >> proceedContinuation: aContinuation forRecord: aRe aRecord debugSession: nil; continuation: nil; - advanceStateForStatus: 'completed' reason: 'debugMethodUpdateProceed'. + advanceStateForStatus: 'completed' + reason: 'debugMethodUpdateProceed'. ^ self proceedDataForCompletedAnswer: answer limit: aContinuation resultPreviewCharacterLimit ]. @@ -280,10 +278,14 @@ MCPUpdateDebugMethodCommand >> proceedContinuation: aContinuation forRecord: aRe advanceStateForStatus: 'paused' reason: 'capturedException'. ^ self proceedDataForOutcome: 'paused' timedOut: false ]. status = #paused ifTrue: [ - aRecord advanceStateForStatus: 'paused' reason: 'debugMethodUpdateProceed'. + aRecord + advanceStateForStatus: 'paused' + reason: 'debugMethodUpdateProceed'. ^ self proceedDataForOutcome: 'paused' timedOut: false ]. status = #running ifTrue: [ - aRecord advanceStateForStatus: 'running' reason: 'debugMethodUpdateProceed'. + aRecord + advanceStateForStatus: 'running' + reason: 'debugMethodUpdateProceed'. ^ self proceedDataForOutcome: 'running' timedOut: false ]. status = #timedOut ifTrue: [ aContinuation terminateWorker. @@ -295,7 +297,8 @@ MCPUpdateDebugMethodCommand >> proceedContinuation: aContinuation forRecord: aRe status = #terminated ifTrue: [ aRecord continuation: nil; - advanceStateForStatus: 'terminated' reason: 'debugMethodUpdateProceed'. + advanceStateForStatus: 'terminated' + reason: 'debugMethodUpdateProceed'. ^ self proceedDataForOutcome: 'terminated' timedOut: false ]. ^ self proceedDataForOutcome: status asString timedOut: false ] @@ -352,7 +355,9 @@ MCPUpdateDebugMethodCommand >> proceedDebugSessionForRecord: aRecord [ ^ self proceedDataForOutcome: 'unavailable' timedOut: false ]. [ aRecord debugSession resume. - aRecord advanceStateForStatus: 'running' reason: 'debugMethodUpdateProceed' ] + aRecord + advanceStateForStatus: 'running' + reason: 'debugMethodUpdateProceed' ] on: Exception do: [ :error | aRecord @@ -437,18 +442,6 @@ MCPUpdateDebugMethodCommand >> resultDataUsing: details critiques: critiques pro ^ data ] -{ #category : 'private - frames' } -MCPUpdateDebugMethodCommand >> selectedContextForRecord: aRecord frameIndex: frameIndex [ - - | contexts stateInfo | - stateInfo := MCPDebugStateInfo fromRecord: aRecord request: request. - contexts := stateInfo rawContexts. - ^ contexts - at: frameIndex + 1 - ifAbsent: [ - self signalMissingFrameIndex: frameIndex record: aRecord ] -] - { #category : 'private - critiques' } MCPUpdateDebugMethodCommand >> shouldBlockProceedForCritiques: critiqueData [ @@ -456,23 +449,6 @@ MCPUpdateDebugMethodCommand >> shouldBlockProceedForCritiques: critiqueData [ ^ request ignoreCritiques not ] -{ #category : 'private - errors' } -MCPUpdateDebugMethodCommand >> signalMissingFrameIndex: frameIndex record: aRecord [ - - ^ MCPCommandError - signalErrorCode: #DebugFrameNotFound - message: - 'Debug frame ' , frameIndex asString - , ' was not found for session ' , aRecord sessionId , '.' - details: { - (#sessionId -> aRecord sessionId). - (#stateId -> aRecord stateId). - (#frameIndex -> frameIndex). - (#frameRef - -> (self frameRefForRecord: aRecord frameIndex: frameIndex)) } - asDictionary -] - { #category : 'private - errors' } MCPUpdateDebugMethodCommand >> signalRecompileFailedForRecord: aRecord frameIndex: frameIndex updateKind: updateKind [ diff --git a/src/MCP/MCPUpdateMethodCommand.class.st b/src/MCP/MCPUpdateMethodCommand.class.st index dbc13bb..877a699 100644 --- a/src/MCP/MCPUpdateMethodCommand.class.st +++ b/src/MCP/MCPUpdateMethodCommand.class.st @@ -3,22 +3,12 @@ Command for applying one method update patch. It selects an internal method upda " Class { #name : 'MCPUpdateMethodCommand', - #superclass : 'Object', - #instVars : [ - 'tool', - 'request' - ], + #superclass : 'MCPToolRequestCommand', #category : 'MCP-Commands', #package : 'MCP', #tag : 'Commands' } -{ #category : 'instance creation' } -MCPUpdateMethodCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private - results' } MCPUpdateMethodCommand >> appliedUpdateResultFor: aChangeResult plan: plan [ @@ -34,10 +24,10 @@ MCPUpdateMethodCommand >> execute [ [ plan := self updatePlan ] on: MCPCommandError do: [ :error | - ^ self tool - errorResultForCommandError: error - action: 'update' - requestedContext: self request requestedContext ]. + ^ self tool + errorResultForCommandError: error + action: 'update' + requestedContext: self request requestedContext ]. ^ self executePlan: plan ] @@ -52,60 +42,60 @@ MCPUpdateMethodCommand >> executeAddArgumentsWithPlan: plan [ force: self request force requestedContext: plan requestedContext work: [ - behavior := self tool - behaviorNamed: self request className - classSide: self request classSide. - behavior compiledMethodAt: oldSelectorSymbol ifAbsent: [ - MCPCommandError - signalMissingMethodInClassName: self request className - classSide: self request classSide - selector: self request selector ]. - refactoringModel := self tool - refactoringModelForScopeSpec: - self request refactoringScopeSpec - anchoredAtBehavior: behavior. - oldMethodReference := self tool - methodReferenceForBehavior: behavior - selector: oldSelectorSymbol. - refactoring := self tool - addParameterRefactoringForSelector: - oldSelectorSymbol - inBehavior: behavior - to: newSelectorSymbol - permutation: self request permutation - newArgs: self request newArgumentSpecs - model: refactoringModel. - renameMap := self request argumentRenameMapForBehavior: behavior. - renameMap ifNotEmpty: [ refactoring renameMap: renameMap ]. - refactoring execute. - newCompiledMethod := self tool - reformattedMethodForBehavior: behavior - selector: newSelectorSymbol. - changeResult := (MCPMethodUpdateChangeResult - updateAction: 'addArguments' - method: newCompiledMethod) - oldSelector: self request selector; - newSelector: self request newSelector; - yourself ] + behavior := self tool + behaviorNamed: self request className + classSide: self request classSide. + behavior compiledMethodAt: oldSelectorSymbol ifAbsent: [ + MCPCommandError + signalMissingMethodInClassName: self request className + classSide: self request classSide + selector: self request selector ]. + refactoringModel := self tool + refactoringModelForScopeSpec: + self request refactoringScopeSpec + anchoredAtBehavior: behavior. + oldMethodReference := self tool + methodReferenceForBehavior: behavior + selector: oldSelectorSymbol. + refactoring := self tool + addParameterRefactoringForSelector: + oldSelectorSymbol + inBehavior: behavior + to: newSelectorSymbol + permutation: self request permutation + newArgs: self request newArgumentSpecs + model: refactoringModel. + renameMap := self request argumentRenameMapForBehavior: behavior. + renameMap ifNotEmpty: [ refactoring renameMap: renameMap ]. + refactoring execute. + newCompiledMethod := self tool + reformattedMethodForBehavior: behavior + selector: newSelectorSymbol. + changeResult := (MCPMethodUpdateChangeResult + updateAction: 'addArguments' + method: newCompiledMethod) + oldSelector: self request selector; + newSelector: self request newSelector; + yourself ] successResult: [ :warningMessages | - self tool - successResultText: - 'Added arguments to ' , oldMethodReference , ' as ' - , (self tool - methodReferenceForBehavior: behavior - selector: newSelectorSymbol) , '.' - data: - (self appliedUpdateResultFor: changeResult plan: plan) - asDictionary - warnings: warningMessages ] + self tool + successResultText: + 'Added arguments to ' , oldMethodReference , ' as ' + , (self tool + methodReferenceForBehavior: behavior + selector: newSelectorSymbol) , '.' + data: + (self appliedUpdateResultFor: changeResult plan: plan) + asDictionary + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForArgumentUpdateAction: 'addArguments' - classNamed: self request className - classSide: self request classSide - selector: self request selector - newSelector: self request newSelector - error: error ] + self tool + failureMessageForArgumentUpdateAction: 'addArguments' + classNamed: self request className + classSide: self request classSide + selector: self request selector + newSelector: self request newSelector + error: error ] ] { #category : 'private - planning' } @@ -132,48 +122,48 @@ MCPUpdateMethodCommand >> executeChangeProtocolWithPlan: plan [ force: self request force requestedContext: plan requestedContext work: [ - behavior := self tool - behaviorNamed: self request className - classSide: self request classSide. - oldCompiledMethod := behavior - compiledMethodAt: selectorSymbol - ifAbsent: [ - MCPCommandError - signalMissingMethodInClassName: - self request className - classSide: self request classSide - selector: self request selector ]. - oldProtocol := self protocolNameForMethod: oldCompiledMethod. - (RBMethodProtocolTransformation - protocol: self request protocol - inMethod: selectorSymbol - inClass: (self tool - classReferenceNameFor: self request className - classSide: self request classSide)) execute. - newCompiledMethod := behavior compiledMethodAt: selectorSymbol. - changeResult := (MCPMethodUpdateChangeResult - updateAction: 'changeProtocol' - method: newCompiledMethod) - oldProtocol: oldProtocol; - newProtocol: self request protocol; - yourself ] + behavior := self tool + behaviorNamed: self request className + classSide: self request classSide. + oldCompiledMethod := behavior + compiledMethodAt: selectorSymbol + ifAbsent: [ + MCPCommandError + signalMissingMethodInClassName: + self request className + classSide: self request classSide + selector: self request selector ]. + oldProtocol := self protocolNameForMethod: oldCompiledMethod. + (RBMethodProtocolTransformation + protocol: self request protocol + inMethod: selectorSymbol + inClass: (self tool + classReferenceNameFor: self request className + classSide: self request classSide)) execute. + newCompiledMethod := behavior compiledMethodAt: selectorSymbol. + changeResult := (MCPMethodUpdateChangeResult + updateAction: 'changeProtocol' + method: newCompiledMethod) + oldProtocol: oldProtocol; + newProtocol: self request protocol; + yourself ] successResult: [ :warningMessages | - self tool - successResultText: 'Changed protocol for ' , (self tool - methodReferenceForBehavior: behavior - selector: selectorSymbol) , '.' - data: - (self appliedUpdateResultFor: changeResult plan: plan) - asDictionary - warnings: warningMessages ] + self tool + successResultText: 'Changed protocol for ' , (self tool + methodReferenceForBehavior: behavior + selector: selectorSymbol) , '.' + data: + (self appliedUpdateResultFor: changeResult plan: plan) + asDictionary + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForChangeProtocolClassNamed: - self request className - classSide: self request classSide - selector: self request selector - protocol: self request protocol - error: error ] + self tool + failureMessageForChangeProtocolClassNamed: + self request className + classSide: self request classSide + selector: self request selector + protocol: self request protocol + error: error ] ] { #category : 'executing' } @@ -204,74 +194,74 @@ MCPUpdateMethodCommand >> executeRemoveArgumentsWithPlan: plan [ force: self request force requestedContext: plan requestedContext work: [ - behavior := self tool - behaviorNamed: self request className - classSide: self request classSide. - behavior compiledMethodAt: oldSelectorSymbol ifAbsent: [ - MCPCommandError - signalMissingMethodInClassName: self request className - classSide: self request classSide - selector: self request selector ]. - oldArgumentNames := (behavior parseTreeForSelector: - oldSelectorSymbol) argumentNames. - removedArgumentNames := self request - removedArgumentNamesInRemovalOrderFrom: - oldArgumentNames. - refactoringModel := self tool - refactoringModelForScopeSpec: - self request refactoringScopeSpec - anchoredAtBehavior: behavior. - oldMethodReference := self tool - methodReferenceForBehavior: behavior - selector: oldSelectorSymbol. - currentSelector := oldSelectorSymbol. - removedArgumentNames doWithIndex: [ :argumentName :index | - | nextSelector | - nextSelector := index = removedArgumentNames size - ifTrue: [ newSelectorSymbol ] - ifFalse: [ - self - selectorAfterRemovingArgumentNamed: - argumentName - fromBehavior: behavior - selector: currentSelector ]. - refactoring := self tool - removeParameterRefactoringForArgumentNamed: - argumentName - inBehavior: behavior - selector: currentSelector - model: refactoringModel. - refactoring newSelector: nextSelector. - refactoring execute. - currentSelector := nextSelector ]. - newCompiledMethod := self tool - reformattedMethodForBehavior: behavior - selector: newSelectorSymbol. - changeResult := (MCPMethodUpdateChangeResult - updateAction: 'removeArguments' - method: newCompiledMethod) - oldSelector: self request selector; - newSelector: self request newSelector; - yourself ] + behavior := self tool + behaviorNamed: self request className + classSide: self request classSide. + behavior compiledMethodAt: oldSelectorSymbol ifAbsent: [ + MCPCommandError + signalMissingMethodInClassName: self request className + classSide: self request classSide + selector: self request selector ]. + oldArgumentNames := (behavior parseTreeForSelector: + oldSelectorSymbol) argumentNames. + removedArgumentNames := self request + removedArgumentNamesInRemovalOrderFrom: + oldArgumentNames. + refactoringModel := self tool + refactoringModelForScopeSpec: + self request refactoringScopeSpec + anchoredAtBehavior: behavior. + oldMethodReference := self tool + methodReferenceForBehavior: behavior + selector: oldSelectorSymbol. + currentSelector := oldSelectorSymbol. + removedArgumentNames doWithIndex: [ :argumentName :index | + | nextSelector | + nextSelector := index = removedArgumentNames size + ifTrue: [ newSelectorSymbol ] + ifFalse: [ + self + selectorAfterRemovingArgumentNamed: + argumentName + fromBehavior: behavior + selector: currentSelector ]. + refactoring := self tool + removeParameterRefactoringForArgumentNamed: + argumentName + inBehavior: behavior + selector: currentSelector + model: refactoringModel. + refactoring newSelector: nextSelector. + refactoring execute. + currentSelector := nextSelector ]. + newCompiledMethod := self tool + reformattedMethodForBehavior: behavior + selector: newSelectorSymbol. + changeResult := (MCPMethodUpdateChangeResult + updateAction: 'removeArguments' + method: newCompiledMethod) + oldSelector: self request selector; + newSelector: self request newSelector; + yourself ] successResult: [ :warningMessages | - self tool - successResultText: - 'Removed arguments from ' , oldMethodReference , ' as ' - , (self tool - methodReferenceForBehavior: behavior - selector: newSelectorSymbol) , '.' - data: - (self appliedUpdateResultFor: changeResult plan: plan) - asDictionary - warnings: warningMessages ] + self tool + successResultText: + 'Removed arguments from ' , oldMethodReference , ' as ' + , (self tool + methodReferenceForBehavior: behavior + selector: newSelectorSymbol) , '.' + data: + (self appliedUpdateResultFor: changeResult plan: plan) + asDictionary + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForArgumentUpdateAction: 'removeArguments' - classNamed: self request className - classSide: self request classSide - selector: self request selector - newSelector: self request newSelector - error: error ] + self tool + failureMessageForArgumentUpdateAction: 'removeArguments' + classNamed: self request className + classSide: self request classSide + selector: self request selector + newSelector: self request newSelector + error: error ] ] { #category : 'executing - method' } @@ -285,64 +275,56 @@ MCPUpdateMethodCommand >> executeRenameWithPlan: plan [ force: self request force requestedContext: plan requestedContext work: [ - behavior := self tool - behaviorNamed: self request className - classSide: self request classSide. - behavior compiledMethodAt: oldSelectorSymbol ifAbsent: [ - MCPCommandError - signalMissingMethodInClassName: self request className - classSide: self request classSide - selector: self request selector ]. - refactoringModel := self tool - refactoringModelForScopeSpec: - self request refactoringScopeSpec - anchoredAtBehavior: behavior. - oldMethodReference := self tool - methodReferenceForBehavior: behavior - selector: oldSelectorSymbol. - refactoring := self tool - renameRefactoringForSelector: oldSelectorSymbol - inBehavior: behavior - to: newSelectorSymbol - permutation: self request permutation - model: refactoringModel. - renameMap := self request argumentRenameMapForBehavior: behavior. - renameMap ifNotEmpty: [ refactoring renameMap: renameMap ]. - refactoring execute. - newCompiledMethod := self tool - reformattedMethodForBehavior: behavior - selector: newSelectorSymbol. - changeResult := (MCPMethodUpdateChangeResult - updateAction: 'rename' - method: newCompiledMethod) - oldSelector: self request selector; - newSelector: self request newSelector; - yourself ] + behavior := self tool + behaviorNamed: self request className + classSide: self request classSide. + behavior compiledMethodAt: oldSelectorSymbol ifAbsent: [ + MCPCommandError + signalMissingMethodInClassName: self request className + classSide: self request classSide + selector: self request selector ]. + refactoringModel := self tool + refactoringModelForScopeSpec: + self request refactoringScopeSpec + anchoredAtBehavior: behavior. + oldMethodReference := self tool + methodReferenceForBehavior: behavior + selector: oldSelectorSymbol. + refactoring := self tool + renameRefactoringForSelector: oldSelectorSymbol + inBehavior: behavior + to: newSelectorSymbol + permutation: self request permutation + model: refactoringModel. + renameMap := self request argumentRenameMapForBehavior: behavior. + renameMap ifNotEmpty: [ refactoring renameMap: renameMap ]. + refactoring execute. + newCompiledMethod := self tool + reformattedMethodForBehavior: behavior + selector: newSelectorSymbol. + changeResult := (MCPMethodUpdateChangeResult + updateAction: 'rename' + method: newCompiledMethod) + oldSelector: self request selector; + newSelector: self request newSelector; + yourself ] successResult: [ :warningMessages | - self tool - successResultText: - 'Renamed ' , oldMethodReference , ' to ' , (self tool - methodReferenceForBehavior: behavior - selector: newSelectorSymbol) , '.' - data: - (self appliedUpdateResultFor: changeResult plan: plan) - asDictionary - warnings: warningMessages ] + self tool + successResultText: + 'Renamed ' , oldMethodReference , ' to ' , (self tool + methodReferenceForBehavior: behavior + selector: newSelectorSymbol) , '.' + data: + (self appliedUpdateResultFor: changeResult plan: plan) + asDictionary + warnings: warningMessages ] failureSummary: [ :error | - self tool - failureMessageForRenameClassNamed: self request className - classSide: self request classSide - selector: self request selector - newSelector: self request newSelector - error: error ] -] - -{ #category : 'initialization' } -MCPUpdateMethodCommand >> initializeTool: aTool request: aRequest [ - - tool := aTool. - request := aRequest. - ^ self + self tool + failureMessageForRenameClassNamed: self request className + classSide: self request classSide + selector: self request selector + newSelector: self request newSelector + error: error ] ] { #category : 'private - methods' } @@ -353,12 +335,6 @@ MCPUpdateMethodCommand >> protocolNameForMethod: aCompiledMethod [ ifNotNil: [ :aProtocol | aProtocol name asString ] ] -{ #category : 'accessing' } -MCPUpdateMethodCommand >> request [ - - ^ request -] - { #category : 'private - planning' } MCPUpdateMethodCommand >> requestedContextForAction: action [ @@ -366,10 +342,10 @@ MCPUpdateMethodCommand >> requestedContextForAction: action [ context := self request requestedContext copy. (#( 'rename' 'addArguments' 'removeArguments' ) includes: action) ifTrue: [ - self tool - addRefactoringScopeContextFromSpec: - self request refactoringScopeSpec - toRequestedContext: context ]. + self tool + addRefactoringScopeContextFromSpec: + self request refactoringScopeSpec + toRequestedContext: context ]. ^ context ] @@ -413,12 +389,6 @@ MCPUpdateMethodCommand >> signalNoUpdateRequested [ details: self request requestedContext ] -{ #category : 'accessing' } -MCPUpdateMethodCommand >> tool [ - - ^ tool -] - { #category : 'accessing' } MCPUpdateMethodCommand >> updateAction [ diff --git a/src/MCP/MCPUpdateRepositoryCommand.class.st b/src/MCP/MCPUpdateRepositoryCommand.class.st index 33586bc..fcd0b7c 100644 --- a/src/MCP/MCPUpdateRepositoryCommand.class.st +++ b/src/MCP/MCPUpdateRepositoryCommand.class.st @@ -3,10 +3,8 @@ Command wrapper for repository_update. It applies repository package membership " Class { #name : 'MCPUpdateRepositoryCommand', - #superclass : 'Object', + #superclass : 'MCPRepositoryCommand', #instVars : [ - 'tool', - 'request', 'addedPackageNames', 'removedPackageNames' ], @@ -15,12 +13,6 @@ Class { #tag : 'Commands' } -{ #category : 'instance creation' } -MCPUpdateRepositoryCommand class >> tool: aTool request: aRequest [ - - ^ self new initializeTool: aTool request: aRequest -] - { #category : 'private - packages' } MCPUpdateRepositoryCommand >> addPackageNamed: packageName to: aRepository [ @@ -53,51 +45,46 @@ MCPUpdateRepositoryCommand >> currentPackageNamesIn: aRepository [ MCPUpdateRepositoryCommand >> execute [ | repository result | - ^ self tool - executeMutationAction: 'update' - force: false - requestedContext: self request requestedContext + ^ self + executeRepositoryAction: 'update' work: [ - self request hasUpdates ifFalse: [ self signalNoUpdateRequested ]. - repository := self request repository. - (self request hasSuppliedPropertyNamed: 'subdirectory') ifTrue: [ - self setSubdirectoryOn: repository ]. - (self request hasSuppliedPropertyNamed: 'packageNames') ifTrue: [ - self replacePackagesIn: repository ]. - self addPackagesTo: repository. - self removePackagesFrom: repository. - result := MCPRepositoryUpdateResult - repository: repository - updateActions: - self request requestedRepositoryUpdateActions - addedPackageNames: self sortedAddedPackageNames - removedPackageNames: self sortedRemovedPackageNames ] + self request hasUpdates ifFalse: [ self signalNoUpdateRequested ]. + repository := self request repository. + (self request hasSuppliedPropertyNamed: 'subdirectory') ifTrue: [ + self setSubdirectoryOn: repository ]. + (self request hasSuppliedPropertyNamed: 'packageNames') ifTrue: [ + self replacePackagesIn: repository ]. + self addPackagesTo: repository. + self removePackagesFrom: repository. + result := MCPRepositoryUpdateResult + repository: repository + updateActions: + self request requestedRepositoryUpdateActions + addedPackageNames: self sortedAddedPackageNames + removedPackageNames: self sortedRemovedPackageNames ] successResult: [ :warningMessages | - self tool - successResultText: - 'Updated repository ' , result repositoryInfo name , '.' - data: (self tool dataForRepositoryUpdateResult: result) - warnings: warningMessages ] + self tool + successResultText: + 'Updated repository ' , result repositoryInfo name , '.' + data: (self tool dataForRepositoryResult: result) + warnings: warningMessages ] failureSummary: [ :error | - 'Failed to update repository: ' - , (error messageText ifNil: [ error asString ]) ] + 'Failed to update repository: ' + , (error messageText ifNil: [ error asString ]) ] ] { #category : 'initialization' } MCPUpdateRepositoryCommand >> initializeTool: aTool request: aRequest [ - tool := aTool. - request := aRequest. + super initializeTool: aTool request: aRequest. addedPackageNames := OrderedCollection new. - removedPackageNames := OrderedCollection new. - ^ self + removedPackageNames := OrderedCollection new ] { #category : 'private' } MCPUpdateRepositoryCommand >> normalizedPackageNames: packageNames [ - ^ (packageNames collect: [ :each | each asString ]) asSet asArray - sort + ^ self sortedStringsFrom: packageNames ] { #category : 'private - packages' } @@ -139,12 +126,6 @@ MCPUpdateRepositoryCommand >> replacePackagesIn: aRepository [ thenDo: [ :each | self addPackageNamed: each to: aRepository ] ] -{ #category : 'accessing' } -MCPUpdateRepositoryCommand >> request [ - - ^ request -] - { #category : 'private - metadata' } MCPUpdateRepositoryCommand >> setSubdirectoryOn: aRepository [ @@ -172,9 +153,3 @@ MCPUpdateRepositoryCommand >> sortedRemovedPackageNames [ ^ self normalizedPackageNames: self removedPackageNames ] - -{ #category : 'accessing' } -MCPUpdateRepositoryCommand >> tool [ - - ^ tool -] diff --git a/src/MCP/MCPValidatedTestRunRequest.class.st b/src/MCP/MCPValidatedTestRunRequest.class.st index d4f600e..601ef9a 100644 --- a/src/MCP/MCPValidatedTestRunRequest.class.st +++ b/src/MCP/MCPValidatedTestRunRequest.class.st @@ -1,7 +1,7 @@ " Validated test_run selection. -It pairs the parsed test run request with the resolved test class that the command will execute. +Class and method selections store their resolved test class. Package selections keep a nil test class and are expanded by MCPRunTestsCommand when execution reaches them. " Class { #name : 'MCPValidatedTestRunRequest', @@ -53,6 +53,18 @@ MCPValidatedTestRunRequest >> initializeRequest: aTestRunRequest testClass: aTes ^ self ] +{ #category : 'testing' } +MCPValidatedTestRunRequest >> isPackageRequest [ + + ^ self testRunRequest isPackageRequest +] + +{ #category : 'accessing' } +MCPValidatedTestRunRequest >> packageName [ + + ^ self testRunRequest packageName +] + { #category : 'accessing' } MCPValidatedTestRunRequest >> testClass [ diff --git a/src/MCP/TMCPMethodTool.trait.st b/src/MCP/TMCPMethodTool.trait.st index a551817..b08c3a7 100644 --- a/src/MCP/TMCPMethodTool.trait.st +++ b/src/MCP/TMCPMethodTool.trait.st @@ -36,10 +36,10 @@ TMCPMethodTool >> methodForClassNamed: className selector: selectorString classS behavior := self behaviorNamed: className classSide: classSide. selectorSymbol := selectorString asSymbol. (behavior includesSelector: selectorSymbol) ifFalse: [ - MCPCommandError - signalMissingMethodInClassName: className - classSide: classSide - selector: selectorString ]. + MCPCommandError + signalMissingMethodInClassName: className + classSide: classSide + selector: selectorString ]. ^ behavior compiledMethodAt: selectorSymbol ] @@ -55,20 +55,20 @@ TMCPMethodTool >> methodQueryScopeInputProperties [ TMCPMethodTool >> methodReferenceForBehavior: aBehavior selector: aSelector [ ^ String streamContents: [ :stream | - stream nextPutAll: (self targetNameForBehavior: aBehavior). - stream nextPutAll: '>>'. - stream nextPutAll: aSelector asString ] + stream nextPutAll: (self targetNameForBehavior: aBehavior). + stream nextPutAll: '>>'. + stream nextPutAll: aSelector asString ] ] { #category : 'private - methods' } TMCPMethodTool >> methodReferenceForClassName: aClassName selector: aSelector isClassSide: isClassSide [ ^ String streamContents: [ :stream | - stream nextPutAll: aClassName. - isClassSide ifTrue: [ stream nextPutAll: ' class' ]. - stream - nextPutAll: '>>'; - nextPutAll: aSelector ] + stream nextPutAll: aClassName. + isClassSide ifTrue: [ stream nextPutAll: ' class' ]. + stream + nextPutAll: '>>'; + nextPutAll: aSelector ] ] { #category : 'private - schema' }