From d28f84107541127a9beac1e7cd5a7ae8717a6a4d Mon Sep 17 00:00:00 2001 From: fouziray Date: Sun, 29 Jun 2025 11:44:12 +0200 Subject: [PATCH 1/2] Moving drTest to NewTools Repo --- src/DrTests/AbstractDrTestsPresenter.class.st | 204 ++++++++ src/DrTests/ClassDescription.extension.st | 10 + src/DrTests/CompiledMethod.extension.st | 18 + src/DrTests/DTAbstractTreeNode.class.st | 55 +++ .../DTBrowseSelectedItemCommand.class.st | 29 ++ src/DrTests/DTCommand.class.st | 21 + .../DTCoveragePluginPresenter.class.st | 162 +++++++ src/DrTests/DTDefaultPluginPresenter.class.st | 448 ++++++++++++++++++ .../DTFilterableListPresenter.class.st | 249 ++++++++++ .../DTFilterableTreePresenter.class.st | 256 ++++++++++ .../DTInspectSelectedItemCommand.class.st | 22 + src/DrTests/DTLeafResultCommand.class.st | 21 + src/DrTests/DTLeavesCollector.class.st | 43 ++ src/DrTests/DTMiddleListCommand.class.st | 22 + src/DrTests/DTNullPluginPresenter.class.st | 17 + src/DrTests/DTPackagesBrowseCommand.class.st | 22 + src/DrTests/DTPackagesCommand.class.st | 16 + src/DrTests/DTPackagesInspectCommand.class.st | 22 + .../DTPackagesSelectAllCommand.class.st | 22 + .../DTPackagesSelectNoneCommand.class.st | 22 + src/DrTests/DTPluginConfiguration.class.st | 81 ++++ src/DrTests/DTPluginResult.class.st | 38 ++ src/DrTests/DTReRunConfiguration.class.st | 50 ++ src/DrTests/DTResultBrowseCommand.class.st | 26 + src/DrTests/DTResultCommand.class.st | 21 + src/DrTests/DTResultTreeView.class.st | 49 ++ src/DrTests/DTResultsTreeVisitor.class.st | 25 + src/DrTests/DTStatusUpdate.class.st | 33 ++ src/DrTests/DTStyleContributor.class.st | 38 ++ src/DrTests/DTTreeLeafNode.class.st | 68 +++ src/DrTests/DTTreeNode.class.st | 167 +++++++ src/DrTests/DTUpdateResults.class.st | 26 + src/DrTests/DrTests.class.st | 321 +++++++++++++ src/DrTests/DrTestsPlugin.class.st | 194 ++++++++ src/DrTests/MiniDrTests.class.st | 113 +++++ src/DrTests/TestCase.extension.st | 18 + src/DrTests/package.st | 1 + 37 files changed, 2950 insertions(+) create mode 100644 src/DrTests/AbstractDrTestsPresenter.class.st create mode 100644 src/DrTests/ClassDescription.extension.st create mode 100644 src/DrTests/CompiledMethod.extension.st create mode 100644 src/DrTests/DTAbstractTreeNode.class.st create mode 100644 src/DrTests/DTBrowseSelectedItemCommand.class.st create mode 100644 src/DrTests/DTCommand.class.st create mode 100644 src/DrTests/DTCoveragePluginPresenter.class.st create mode 100644 src/DrTests/DTDefaultPluginPresenter.class.st create mode 100644 src/DrTests/DTFilterableListPresenter.class.st create mode 100644 src/DrTests/DTFilterableTreePresenter.class.st create mode 100644 src/DrTests/DTInspectSelectedItemCommand.class.st create mode 100644 src/DrTests/DTLeafResultCommand.class.st create mode 100644 src/DrTests/DTLeavesCollector.class.st create mode 100644 src/DrTests/DTMiddleListCommand.class.st create mode 100644 src/DrTests/DTNullPluginPresenter.class.st create mode 100644 src/DrTests/DTPackagesBrowseCommand.class.st create mode 100644 src/DrTests/DTPackagesCommand.class.st create mode 100644 src/DrTests/DTPackagesInspectCommand.class.st create mode 100644 src/DrTests/DTPackagesSelectAllCommand.class.st create mode 100644 src/DrTests/DTPackagesSelectNoneCommand.class.st create mode 100644 src/DrTests/DTPluginConfiguration.class.st create mode 100644 src/DrTests/DTPluginResult.class.st create mode 100644 src/DrTests/DTReRunConfiguration.class.st create mode 100644 src/DrTests/DTResultBrowseCommand.class.st create mode 100644 src/DrTests/DTResultCommand.class.st create mode 100644 src/DrTests/DTResultTreeView.class.st create mode 100644 src/DrTests/DTResultsTreeVisitor.class.st create mode 100644 src/DrTests/DTStatusUpdate.class.st create mode 100644 src/DrTests/DTStyleContributor.class.st create mode 100644 src/DrTests/DTTreeLeafNode.class.st create mode 100644 src/DrTests/DTTreeNode.class.st create mode 100644 src/DrTests/DTUpdateResults.class.st create mode 100644 src/DrTests/DrTests.class.st create mode 100644 src/DrTests/DrTestsPlugin.class.st create mode 100644 src/DrTests/MiniDrTests.class.st create mode 100644 src/DrTests/TestCase.extension.st create mode 100644 src/DrTests/package.st diff --git a/src/DrTests/AbstractDrTestsPresenter.class.st b/src/DrTests/AbstractDrTestsPresenter.class.st new file mode 100644 index 00000000..f440face --- /dev/null +++ b/src/DrTests/AbstractDrTestsPresenter.class.st @@ -0,0 +1,204 @@ +" +Abstract superclass for UI's of Dr Test +" +Class { + #name : 'AbstractDrTestsPresenter', + #superclass : 'StPresenter', + #instVars : [ + 'pluginResult', + 'testsConfiguration', + 'currentPlugin', + 'switchButton' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'testing' } +AbstractDrTestsPresenter class >> isAbstract [ + + ^ self name = #AbstractDrTestsPresenter +] + +{ #category : 'icons' } +AbstractDrTestsPresenter class >> taskbarIconName [ + "Answer the icon for the receiver in a task bar." + + ^ #testRunner +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> currentPlugin [ + + ^ currentPlugin +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> currentPlugin: anObject [ + "If a plugin was set before, unsubscribe first." + + currentPlugin ifNotNil: [ currentPlugin unconfigureUI: self ]. + currentPlugin := anObject. + + currentPlugin announcer + when: DTStatusUpdate + send: #handlePluginStatusUpdate: + to: self. + + currentPlugin announcer + when: DTUpdateResults + send: #handlePluginResultUpdate: + to: self. + + titleHolder := self windowTitle. +] + +{ #category : 'events' } +AbstractDrTestsPresenter >> handlePluginResultUpdate: resultsAnnouncement [ + + self updateWithPluginResult: resultsAnnouncement results +] + +{ #category : 'announcement handling' } +AbstractDrTestsPresenter >> handlePluginStatusUpdate: aDTStatusUpdate [ + + self updateStatus: aDTStatusUpdate message +] + +{ #category : 'initialization' } +AbstractDrTestsPresenter >> initializeButtons [ + + switchButton := self newButton. + switchButton + action: [ self switchUI ]; + icon: (self iconNamed: #smallRemoteOpen) +] + +{ #category : 'initialization' } +AbstractDrTestsPresenter >> initializePresenters [ + + self initializeButtons +] + +{ #category : 'api - locking' } +AbstractDrTestsPresenter >> lock [ + "Lock the UI, once this method is called, the user is not able to click on buttons or lists anymore." + + self locked: false +] + +{ #category : 'api - locking' } +AbstractDrTestsPresenter >> locked: aBoolean [ + "Lock or unlock widgets returned by #subwidgetsToLock depending on aBoolean." + + self subwidgetsToLock + do: [ :subwidget | subwidget enabled: aBoolean ] +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> pluginResult [ + + ^ pluginResult +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> pluginResult: anObject [ + + pluginResult := anObject +] + +{ #category : 'running' } +AbstractDrTestsPresenter >> runPlugin [ + + self runPluginFor: self testsConfiguration +] + +{ #category : 'running' } +AbstractDrTestsPresenter >> runPluginFor: aTestsConfiguration [ + + [ self + lock; + updateStatus: 'Tests started.'; + updateWithResults: (self currentPlugin runForConfiguration: aTestsConfiguration); + updateStatus: 'Tests finished.' ] ensure: [ self unlock ] +] + +{ #category : 'api - locking' } +AbstractDrTestsPresenter >> subwidgetsToLock [ + + ^ { self startButton } +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> switchButton [ + + ^ switchButton +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> switchButton: anObject [ + + switchButton := anObject +] + +{ #category : 'api - subwidgets configuration' } +AbstractDrTestsPresenter >> switchButtonAction: aBlock [ + + self switchButton action: aBlock +] + +{ #category : 'actions' } +AbstractDrTestsPresenter >> switchUI [ + + self withWindowDo: [ :window | window close ] +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> testsConfiguration [ + + ^ testsConfiguration +] + +{ #category : 'accessing' } +AbstractDrTestsPresenter >> testsConfiguration: anObject [ + + testsConfiguration := anObject +] + +{ #category : 'api - locking' } +AbstractDrTestsPresenter >> unlock [ + "Unlock the UI, once this method is called, the user is able to click on buttons or lists and to launch analysis." + + self locked: true +] + +{ #category : 'updating' } +AbstractDrTestsPresenter >> updateStatus: aString [ + "Does nothing on purpose." +] + +{ #category : 'updating' } +AbstractDrTestsPresenter >> updateUI [ + + self withWindowDo: [ :window | window title: self title ] +] + +{ #category : 'updating' } +AbstractDrTestsPresenter >> updateWithPluginResult: aPluginResult [ + + aPluginResult ifNil: [ ^ self ]. + self updateWithResults: aPluginResult +] + +{ #category : 'updating' } +AbstractDrTestsPresenter >> updateWithResults: results [ + + self subclassResponsibility +] + +{ #category : 'TOREMOVE' } +AbstractDrTestsPresenter >> windowIcon [ + + ^ self application iconNamed: #testRunner +] diff --git a/src/DrTests/ClassDescription.extension.st b/src/DrTests/ClassDescription.extension.st new file mode 100644 index 00000000..12d1c7e7 --- /dev/null +++ b/src/DrTests/ClassDescription.extension.st @@ -0,0 +1,10 @@ +Extension { #name : 'ClassDescription' } + +{ #category : '*DrTests' } +ClassDescription >> drTestsBrowse [ + "May be using double dispatch would be better + so that the application of DrTest can open tools + without relying on this global." + + (Smalltalk tools toolNamed: #browser) openOnClass: self +] diff --git a/src/DrTests/CompiledMethod.extension.st b/src/DrTests/CompiledMethod.extension.st new file mode 100644 index 00000000..9a3d43cb --- /dev/null +++ b/src/DrTests/CompiledMethod.extension.st @@ -0,0 +1,18 @@ +Extension { #name : 'CompiledMethod' } + +{ #category : '*DrTests' } +CompiledMethod >> asResultForDrTest [ + + ^ DTTestLeafNode content: self +] + +{ #category : '*DrTests' } +CompiledMethod >> drTestsBrowse [ + "May be using double dispatch would be better + so that the application of DrTest can open tools + without relying on this global." + + (Smalltalk tools toolNamed: #browser) + openOnClass: self methodClass + selector: self selector +] diff --git a/src/DrTests/DTAbstractTreeNode.class.st b/src/DrTests/DTAbstractTreeNode.class.st new file mode 100644 index 00000000..6a959c0a --- /dev/null +++ b/src/DrTests/DTAbstractTreeNode.class.st @@ -0,0 +1,55 @@ +" +I am the abstract superclass for all classes that are nodes or leafs used to show results. +" +Class { + #name : 'DTAbstractTreeNode', + #superclass : 'Object', + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'testing' } +DTAbstractTreeNode >> canBeBrowsed [ + ^ self subclassResponsibility +] + +{ #category : 'api' } +DTAbstractTreeNode >> displayColor [ + + ^ nil +] + +{ #category : 'actions' } +DTAbstractTreeNode >> drTestsBrowse [ + "Actions to perform in order to browse the result. + Does nothing by default." +] + +{ #category : 'menu' } +DTAbstractTreeNode >> drTestsBuildContextMenu: menu [ + "Builds the contextual menu to display in DrTests results tree when a node of the tree is right-clicked. + Does nothing by default." +] + +{ #category : 'accessing' } +DTAbstractTreeNode >> drTestsName [ + "Returns the name to display for this object in DrTestsUI." + ^ self subclassResponsibility +] + +{ #category : 'testing' } +DTAbstractTreeNode >> isLeaf [ + ^ false +] + +{ #category : 'testing' } +DTAbstractTreeNode >> shouldStartExpanded [ + + ^ false +] + +{ #category : 'accessing' } +DTAbstractTreeNode >> subResults [ + ^ #() +] diff --git a/src/DrTests/DTBrowseSelectedItemCommand.class.st b/src/DrTests/DTBrowseSelectedItemCommand.class.st new file mode 100644 index 00000000..afef90b3 --- /dev/null +++ b/src/DrTests/DTBrowseSelectedItemCommand.class.st @@ -0,0 +1,29 @@ +" +I browse the item selected in middle list of DrTests. +" +Class { + #name : 'DTBrowseSelectedItemCommand', + #superclass : 'DTMiddleListCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'defaults' } +DTBrowseSelectedItemCommand class >> defaultName [ + "Return the default name of the command" + + ^ 'Browse' +] + +{ #category : 'testing' } +DTBrowseSelectedItemCommand >> canBeExecuted [ + + ^ self selectedItems size = 1 +] + +{ #category : 'executing' } +DTBrowseSelectedItemCommand >> execute [ + + self context browseSelectedItem +] diff --git a/src/DrTests/DTCommand.class.st b/src/DrTests/DTCommand.class.st new file mode 100644 index 00000000..e779c8d9 --- /dev/null +++ b/src/DrTests/DTCommand.class.st @@ -0,0 +1,21 @@ +" +I am an abstract command concerning DrTests. +" +Class { + #name : 'DTCommand', + #superclass : 'CmCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTCommand class >> isAbstract [ + + ^self name = #DTCommand +] + +{ #category : 'accessing' } +DTCommand >> plugin [ + ^ self context plugin +] diff --git a/src/DrTests/DTCoveragePluginPresenter.class.st b/src/DrTests/DTCoveragePluginPresenter.class.st new file mode 100644 index 00000000..7c355bd0 --- /dev/null +++ b/src/DrTests/DTCoveragePluginPresenter.class.st @@ -0,0 +1,162 @@ +" +I am a specialized `DTDefaultPluginPresenter` for the DrTests coverage plugin. + +This subclass adds an extra panel to display the source code of the methods and highlight the covered lines of code. The highlighting has 3 colors where: +- green indicates fully covered lines. +- yellow indicates partially covered lines. +- red indicates uncovered lines. + +To achieve this, this subclass has 4 new attributes: sourceCodePanel, coveredNodes, uncoveredNodes, and yellowNodes. The sourceCodePanel is the panel that displays the highlighted source code below the list of method nodes. It also has 4 new methods: +1) `DTCoveragePluginPresenter>>#updateSourceCodePanel:` updates the panel when the user clicks on a method in the result list. It colors in the order they are presented above, starting from green as a base color. +2) `DTCoveragePluginPresenter>>#defineColorCoverage:` updates the coveredNodes and uncoveredNodes attributes according to the selected method. +3) `DTCoveragePluginPresenter>>#defineColorMessageNode:` updates the yellowNodes attribute according to the selected method. If an ASTMessageNode contains selectors with block arguments like `ifTrue:`, `ifFalse:`, `do:` and others, it decides whether they should be highlighted in yellow or green. +4) `DTCoveragePluginPresenter>>#addHighlightingOf:withColor:` applies the highlighting to the source code panel for each attribute (coveredNodes, uncoveredNodes, and yellowNodes). +" +Class { + #name : 'DTCoveragePluginPresenter', + #superclass : 'DTDefaultPluginPresenter', + #instVars : [ + 'sourceCodePanel', + 'coveredNodes', + 'uncoveredNodes', + 'yellowNodes' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'highlighting' } +DTCoveragePluginPresenter >> addHighlightingOf: nodesCollection withColor: aColor [ + + nodesCollection do: [ :node | + sourceCodePanel addTextSegmentDecoration: + (SpTextPresenterDecorator forHighlight + interval: + (node sourceInterval first to: node sourceInterval last + 1); + highlightColor: aColor) ] +] + +{ #category : 'initialization' } +DTCoveragePluginPresenter >> cleanAttributesForHighlighting [ + " Clean the attributes to store new value to display on Source Code panel " + + yellowNodes := OrderedCollection new. + uncoveredNodes := OrderedCollection new. + coveredNodes := OrderedCollection new +] + +{ #category : 'initialization' } +DTCoveragePluginPresenter >> connectPresenters [ + + super connectPresenters. + + self resultViewsDropList whenSelectedItemChangedDo: [ + :resultTreeViewOrNil | + resultTreeViewOrNil ifNotNil: [ + resultsList roots: + (resultTreeViewOrNil resultTreeFor: drTests pluginResult) + subResults ] ]. + + resultsList whenSelectionChangedDo: [ :selection | + (selection selectedItem isKindOf: DTTestLeafNode) ifTrue: [ + selection selectedItem ifNotNil: [ :item | + self updateSourceCodePanel: item content ] ] ] +] + +{ #category : 'layout' } +DTCoveragePluginPresenter >> defaultLayout [ + + ^ SpBoxLayout newTopToBottom + add: (SpPanedLayout newLeftToRight + add: (SpPanedLayout newLeftToRight + add: packagesList; + add: itemsList; + yourself); + add: (SpBoxLayout newTopToBottom + spacing: 5; + add: resultViewsDropList expand: false; + add: resultLabel expand: false; + add: resultsList; + add: sourceCodePanel; + yourself); + yourself); + add: startButton expand: false; + yourself +] + +{ #category : 'highlighting' } +DTCoveragePluginPresenter >> defineColorCoverage: aMethod [ + + aMethod ast nodesDo: [ :node | + node isSequence ifTrue: [ + node hasBeenExecuted + ifTrue: [ + (self hasSequenceNodeInside: node) ifFalse: [ + coveredNodes add: node ] ] + ifFalse: [ uncoveredNodes add: node ] ]. + + node isMessage ifTrue: [ self defineColorMessageNode: node ] ] +] + +{ #category : 'highlighting' } +DTCoveragePluginPresenter >> defineColorMessageNode: aMessageNode [ + "handle arguments of an ASTMessageNode" + + | blockNodes | + blockNodes := aMessageNode arguments select: [ :element | + element isBlock ]. + blockNodes ifNotEmpty: [ + (blockNodes allSatisfy: [ :arg | arg body hasBeenExecuted ]) + ifFalse: [ yellowNodes add: aMessageNode . ] ] +] + +{ #category : 'highlighting' } +DTCoveragePluginPresenter >> hasSequenceNodeInside: aSequenceNode [ + + ^ aSequenceNode statements anySatisfy: [ :statement | + statement allChildren anySatisfy: [ :node | node isSequence ] ] +] + +{ #category : 'initialization' } +DTCoveragePluginPresenter >> initializeResultsTreeAndLabel [ + + resultLabel := self newLabel label: 'Results:'. + resultsList := self newTree. + resultsList + display: [ :node | node drTestsName ]; + displayColor: [ :node | node displayColor ]; + children: [ :node | node subResults ]; + actions: self rootCommandsGroup / 'Results tools'. + + resultsList outputActivationPort transmitDo: [ + (DTResultBrowseCommand forSpecContext: self) execute ]. + sourceCodePanel := self instantiate: SpCodePresenter . +] + +{ #category : 'layout' } +DTCoveragePluginPresenter >> updateSourceCodePanel: compiledMethod [ + " The colors overlap and paint in descending order" + + self cleanAttributesForHighlighting. + self defineColorCoverage: compiledMethod. + sourceCodePanel beForMethod: compiledMethod. + sourceCodePanel text: compiledMethod sourceCode. + self + addHighlightingOf: coveredNodes + withColor: (Color r: 0.74 g: 0.98 b: 0.71). + self + addHighlightingOf: uncoveredNodes + withColor: (Color r: 0.98 g: 0.71 b: 0.71). + self + addHighlightingOf: yellowNodes + withColor: (Color r: 0.98 g: 0.95 b: 0.71). + + "Base color is green" + sourceCodePanel addTextSegmentDecoration: + (SpTextPresenterDecorator forHighlight + interval: (compiledMethod ast body sourceInterval first to: + compiledMethod ast body sourceInterval last + 1); + highlightColor: (Color r: 0.74 g: 0.98 b: 0.71)). + ^ sourceCodePanel yourself +] diff --git a/src/DrTests/DTDefaultPluginPresenter.class.st b/src/DrTests/DTDefaultPluginPresenter.class.st new file mode 100644 index 00000000..0166d608 --- /dev/null +++ b/src/DrTests/DTDefaultPluginPresenter.class.st @@ -0,0 +1,448 @@ +Class { + #name : 'DTDefaultPluginPresenter', + #superclass : 'SpPresenter', + #instVars : [ + 'packagesList', + 'resultsList', + 'itemsList', + 'resultViewsDropList', + 'resultLabel', + 'plugin', + 'drTests', + 'lastResults', + 'startButton' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'commands' } +DTDefaultPluginPresenter class >> buildCommandsGroupWith: presenterInstance forRoot: rootCommandGroup [ + + rootCommandGroup + register: (self buildContextualPackageGroupWith: presenterInstance); + register: (self buildItemsListGroupWith: presenterInstance); + register: (self buildResultGroupWith: presenterInstance) +] + +{ #category : 'private - commands' } +DTDefaultPluginPresenter class >> buildContextualPackageGroupWith: presenterInstance [ + + ^ (CmCommandGroup named: 'Package menu') asSpecGroup + register: (self buildPackageGroupWith: presenterInstance); + yourself +] + +{ #category : 'private - commands' } +DTDefaultPluginPresenter class >> buildItemsListGroupWith: presenterInstance [ + + ^ (CmCommandGroup named: 'List items menu') asSpecGroup + register: + (DTInspectSelectedItemCommand forSpecContext: presenterInstance) + beHiddenWhenCantBeRun; + register: + (DTBrowseSelectedItemCommand forSpec context: presenterInstance); + yourself +] + +{ #category : 'private - commands' } +DTDefaultPluginPresenter class >> buildPackageGroupWith: presenterInstance [ + + |group| + group := (CmCommandGroup named: 'Package tools') asSpecGroup. + group description: 'Commands related to packages list.'. + + DTPackagesCommand allSubclasses do: [:each | + group register: (each forSpec context: presenterInstance) ]. + + ^group + beDisplayedAsGroup; + yourself +] + +{ #category : 'private - commands' } +DTDefaultPluginPresenter class >> buildResultGroupWith: presenterInstance [ + + | commandGroup pluginCommands plugin | + commandGroup := (CmCommandGroup named: 'Results tools') asSpecGroup + description: 'Commands related to result.'; + register: + (DTResultBrowseCommand forSpecContext: + presenterInstance) beHiddenWhenCantBeRun; + yourself. + + plugin := presenterInstance plugin. + plugin ifNil: [ ^ commandGroup ]. + + pluginCommands := plugin buildContextualMenuGroupWith: + presenterInstance. + pluginCommands entries ifEmpty: [ ^ commandGroup ]. + ^ commandGroup + register: pluginCommands beDisplayedAsGroup; + yourself +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> browseSelectedItem [ + "Because of DTBrowseSelectedItem>>#canBeExecuted, we know there is a single item in the selection. + Thus, we take the first one and browse it. + " + + self selectedItems first drTestsBrowse +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> browseSelectedPackage [ + + self selectedPackage browse +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> browseSelectedResult [ + + self resultSelected drTestsBrowse +] + +{ #category : 'private' } +DTDefaultPluginPresenter >> buildLabelString: nameOfItems numberOfItemsSelected: aInt [ + + ^ String streamContents: [ :stream | + stream + << nameOfItems; + << ' ('; + << aInt asString; + << ' selected):' ] +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> connectPresenters [ + + super connectPresenters. + + self resultViewsDropList + whenSelectedItemChangedDo: [ :resultTreeViewOrNil | + resultTreeViewOrNil + ifNotNil: [ resultsList + roots: (resultTreeViewOrNil resultTreeFor: drTests pluginResult) subResults ] ] +] + +{ #category : 'layout' } +DTDefaultPluginPresenter >> defaultLayout [ + + ^ SpBoxLayout newTopToBottom + add: (SpPanedLayout newLeftToRight + add: (SpPanedLayout newLeftToRight + add: packagesList; + add: itemsList; + yourself); + add: (SpBoxLayout newTopToBottom + spacing: 5; + add: resultViewsDropList expand: false; + add: resultLabel expand: false; + add: resultsList; + yourself); + yourself); + add: startButton expand: false; + yourself +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> drTests [ + ^ drTests +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializeItemsListAndLabel [ + + itemsList := self newFilterableTreePresenter. + itemsList + displayIcon: [ :aClass | self iconNamed: aClass systemIconName ]; + displayColor: [ :aClass | + (self packagesSelected includes: aClass package) + ifTrue: [ self theme textColor ] + ifFalse: [ self theme classExtensionColor ] ]; + help: + 'Select the classes to analyze. Cmd+A or Ctrl+A to select all classes.'; + displayBlock: [ :item | item name ]; + whenSelectionChangedDo: [ + self whenItemsSelectionChanged: self selectedItems ]; + beMultipleSelection; + actions: (self rootCommandsGroup / 'List items menu') beRoot. + + packagesList whenSelectionChangedDo: [ + self whenPackagesSelectionChanged: self packagesSelected ] +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializePackagesListAndLabel [ + + packagesList := self newFilterableListPresenter. + packagesList + help: 'Select the packages to analyze. Cmd+A or Ctrl+A to select all packages.'; + sortingBlock: #name ascending; + displayBlock: [ :package | package name ]; + beMultipleSelection; + actions: self rootCommandsGroup / 'Package menu' +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializePresenters [ + + super initializePresenters. + + self + initializePackagesListAndLabel; + initializeItemsListAndLabel; + initializeResultsTreeAndLabel; + initializeResultViewsDropList. + + startButton := self newButton. + startButton action: [ drTests runPlugin ] +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializeResultViewsDropList [ + + resultViewsDropList := self newDropList. + self resultViewsDropList + help: 'Select the different views for results'; + display: [ :resultTreeView | resultTreeView name ] +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> initializeResultsTreeAndLabel [ + + resultLabel := self newLabel label: 'Results:'. + resultsList := self newTree. + resultsList + display: [ :node | node drTestsName ]; + displayColor: [ :node | node displayColor ]; + children: [ :node | node subResults ]; + actions: self rootCommandsGroup / 'Results tools'. + + resultsList outputActivationPort + transmitDo: [ + (DTResultBrowseCommand forSpecContext: self) execute ] +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> inspectSelectedItem [ + + self selectedItems first inspect +] + +{ #category : 'actions' } +DTDefaultPluginPresenter >> inspectSelectedPackage [ + + self selectedPackage inspect +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> itemsList [ + ^ itemsList +] + +{ #category : 'widgets' } +DTDefaultPluginPresenter >> newFilterableListPresenter [ + + ^ self instantiate: DTFilterableListPresenter +] + +{ #category : 'widgets' } +DTDefaultPluginPresenter >> newFilterableTreePresenter [ + + ^ self instantiate: DTFilterableTreePresenter +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> packagesList [ + ^ packagesList +] + +{ #category : 'private' } +DTDefaultPluginPresenter >> packagesSelected [ + + ^ self packagesList ifNil: [ #( ) ] ifNotNil: #selectedItems +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> plugin [ + ^ plugin +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> resultSelected [ + + ^ self resultsList selectedItem +] + +{ #category : 'api' } +DTDefaultPluginPresenter >> resultTree: aResultGroup [ + + | roots | + aResultGroup ifNil: [ ^ self ]. + roots := aResultGroup subResults. + resultsList roots: roots. + roots withIndexDo: [ :each :index | + each shouldStartExpanded ifTrue: [ + "here there was a each name crTrace. + It does not look like the good way to provide feedback in the transcript" + resultsList expandPath: { index } ] ] +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> resultViewsDropList [ + ^ resultViewsDropList +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> resultsList [ + ^ resultsList +] + +{ #category : 'api' } +DTDefaultPluginPresenter >> selectAllInPackageList [ + + packagesList selectAll +] + +{ #category : 'api' } +DTDefaultPluginPresenter >> selectNoneInPackageList [ + + packagesList unselectAll +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> selectedItems [ + + ^ itemsList selectedItems +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> selectedPackage [ + + ^ packagesList selectedItem +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> setModelBeforeInitialization: aPair [ + + plugin := aPair first. + drTests := aPair second +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> startButton [ + ^ startButton +] + +{ #category : 'accessing' } +DTDefaultPluginPresenter >> subwidgetsToLock [ + + ^ { packagesList. itemsList. resultsList. startButton} +] + +{ #category : 'private - updating' } +DTDefaultPluginPresenter >> updateItemsListLabel [ + + itemsList label: (self + buildLabelString: plugin secondListLabel + numberOfItemsSelected: self selectedItems size) +] + +{ #category : 'private - updating' } +DTDefaultPluginPresenter >> updatePackagesList [ + + packagesList unselectAll. + itemsList beEmpty. + packagesList items: plugin packagesAvailableForAnalysis. + packagesList label: plugin firstListLabel. + itemsList label: plugin secondListLabel. + plugin setSelectionModeOfPackageList: packagesList. + plugin setSelectionModeOfItemsList: itemsList +] + +{ #category : 'private - updating' } +DTDefaultPluginPresenter >> updatePackagesListLabel [ + + self packagesList label: (self + buildLabelString: plugin firstListLabel + numberOfItemsSelected: self packagesSelected size) +] + +{ #category : 'initialization' } +DTDefaultPluginPresenter >> updatePresenter [ + + super updatePresenter. + + self updatePackagesList. + self updateResultViewsDropList. + + startButton label: plugin startButtonLabel. + startButton help: plugin startButtonHelp +] + +{ #category : 'updating' } +DTDefaultPluginPresenter >> updateResultLabel [ + + resultLabel styles copy + do: [ :each | resultLabel removeStyle: each ]. + resultLabel + label: 'Results:'; + addStyle: lastResults backgroundColorStyle +] + +{ #category : 'updating' } +DTDefaultPluginPresenter >> updateResultViewsDropList [ + | newPragmas | + + newPragmas := plugin resultTreeViews. + (resultViewsDropList listItems = newPragmas + and: [ newPragmas isNotEmpty ]) + ifTrue: [ + "Trigger action attached to selection change." + resultViewsDropList selectedIndex: resultViewsDropList selectedIndex. + ^ self ]. + + self resultViewsDropList selectedItem + ifNotNil: [ self resultViewsDropList resetSelection ]. + self resultViewsDropList items: newPragmas. + newPragmas isNotEmpty + ifTrue: [ self resultViewsDropList selectIndex: 1 ] +] + +{ #category : 'updating' } +DTDefaultPluginPresenter >> updateWithResults: someResults [ + + lastResults := someResults. + + self updateResultViewsDropList. + self updateResultLabel. + self resultTree: lastResults buildTreeForUI. + resultsList actions: self rootCommandsGroup / 'Results tools' +] + +{ #category : 'private' } +DTDefaultPluginPresenter >> whenItemsSelectionChanged: itemsSelected [ + + self updateItemsListLabel. + drTests updateSwitchButton: itemsSelected +] + +{ #category : 'private' } +DTDefaultPluginPresenter >> whenPackagesSelectionChanged: packagesSelected [ + + itemsList + roots: ((plugin itemsToBeAnalysedFor: packagesSelected) sorted: + #name ascending); + children: [ :aClass | + aClass subclasses + & (packagesSelected flatCollect: [ :package | package classes ]) + sorted: #name ascending ]; + expandAll. + itemsList roots: itemsList items. + + itemsList selectAll. + self updatePackagesListLabel +] diff --git a/src/DrTests/DTFilterableListPresenter.class.st b/src/DrTests/DTFilterableListPresenter.class.st new file mode 100644 index 00000000..2b17bc4e --- /dev/null +++ b/src/DrTests/DTFilterableListPresenter.class.st @@ -0,0 +1,249 @@ +" +I am a list presenter that can be filtered. + +I also have a label. +" +Class { + #name : 'DTFilterableListPresenter', + #superclass : 'SpPresenter', + #instVars : [ + 'listPresenter', + 'filterTextInput', + 'initialItems', + 'labelPresenter' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'api - actions' } +DTFilterableListPresenter >> actions [ + + ^ self listPresenter actions +] + +{ #category : 'api - actions' } +DTFilterableListPresenter >> actions: aCommandGroup [ + + self listPresenter actions: aCommandGroup +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> allItems [ + + ^ initialItems +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> beEmpty [ + + self items: #() +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> beMultipleSelection [ + + ^ self listPresenter beMultipleSelection +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> beSingleSelection [ + + ^ self listPresenter beSingleSelection +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> contextMenu: aBlock [ + + ^ self listPresenter contextMenu: aBlock +] + +{ #category : 'layout' } +DTFilterableListPresenter >> defaultLayout [ + + ^ SpBoxLayout newTopToBottom + spacing: 5; + add: labelPresenter expand: false; + add: listPresenter; + add: filterTextInput expand: false; + yourself +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> displayBlock: aBlock [ + + ^ self listPresenter display: aBlock +] + +{ #category : 'api' } +DTFilterableListPresenter >> displayColor: aBlock [ + + self listPresenter displayColor: aBlock +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> displayIcon: aFullBlockClosure [ + + self listPresenter displayIcon: aFullBlockClosure +] + +{ #category : 'private - actions' } +DTFilterableListPresenter >> ensureActions [ + + ^ self listPresenter ensureActions +] + +{ #category : 'private' } +DTFilterableListPresenter >> filterList [ + "Filters the list according to the filterTextInput." + + self unselectAll. + self filterStrings + ifEmpty: [ + self listPresenter + items: initialItems. + ^ self ]. + self listPresenter + items: + (initialItems + select: [ :each | + self filterStrings + anySatisfy: [ :any | any match: (self listPresenter display value: each) ] ]) +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> filterStrings [ + + ^ (self filterTextInput text splitOn: $|) + reject: #isEmpty + thenCollect: [ :pattern | '*' , pattern , '*' ] +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> filterTextInput [ + + ^ filterTextInput +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> help [ + + ^ labelPresenter help +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> help: aString [ + + labelPresenter help: aString +] + +{ #category : 'initialization' } +DTFilterableListPresenter >> initialize [ + + super initialize. + initialItems := #() +] + +{ #category : 'initialization' } +DTFilterableListPresenter >> initializePresenters [ + + labelPresenter := self newLabel. + listPresenter := self newList. + filterTextInput := self newTextInput + placeholder: 'Filter...'; + whenTextChangedDo: [ self filterList ]; + yourself +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> items [ + + ^ self visibleItems +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> items: items [ + + initialItems := items. + self listPresenter items: items +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> label [ + + ^ labelPresenter label +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> label: aString [ + + labelPresenter label: aString +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> labelPresenter [ + + ^ labelPresenter +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> listPresenter [ + + ^ listPresenter +] + +{ #category : 'actions' } +DTFilterableListPresenter >> resetFilter [ + + self filterTextInput text: ''. + self listPresenter items: initialItems +] + +{ #category : 'actions' } +DTFilterableListPresenter >> selectAll [ + + ^ self listPresenter selectAll +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> selectItems: aBlock [ + + ^ self listPresenter selectItems: aBlock +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> selectedItem [ + + ^ listPresenter selectedItem +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> selectedItems [ + + ^ self listPresenter selectedItems +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> sortingBlock: aBlock [ + + ^ self listPresenter sortingBlock: aBlock +] + +{ #category : 'actions' } +DTFilterableListPresenter >> unselectAll [ + + ^ self listPresenter unselectAll +] + +{ #category : 'accessing' } +DTFilterableListPresenter >> visibleItems [ + + ^ self listPresenter items +] + +{ #category : 'events' } +DTFilterableListPresenter >> whenSelectionChangedDo: aBlock [ + + ^ self listPresenter whenSelectionChangedDo: aBlock +] diff --git a/src/DrTests/DTFilterableTreePresenter.class.st b/src/DrTests/DTFilterableTreePresenter.class.st new file mode 100644 index 00000000..c48d9672 --- /dev/null +++ b/src/DrTests/DTFilterableTreePresenter.class.st @@ -0,0 +1,256 @@ +" +I am a list presenter that can be filtered. + +I also have a label. +" +Class { + #name : 'DTFilterableTreePresenter', + #superclass : 'SpPresenter', + #instVars : [ + 'treePresenter', + 'filterTextInput', + 'initialItems', + 'labelPresenter' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'api - actions' } +DTFilterableTreePresenter >> actions [ + + ^ self treePresenter actions +] + +{ #category : 'api - actions' } +DTFilterableTreePresenter >> actions: aCommandGroup [ + + self treePresenter actions: aCommandGroup +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> allItems [ + + ^ initialItems +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> beEmpty [ + + self roots: #() +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> beMultipleSelection [ + + ^ self treePresenter beMultipleSelection +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> beSingleSelection [ + + ^ self treePresenter beSingleSelection +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> children [ + + ^ self treePresenter children +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> children: aBlock [ + + self treePresenter children: aBlock +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> contextMenu: aBlock [ + + ^ self treePresenter contextMenu: aBlock +] + +{ #category : 'layout' } +DTFilterableTreePresenter >> defaultLayout [ + + ^ SpBoxLayout newTopToBottom + spacing: 5; + add: labelPresenter expand: false; + add: treePresenter; + add: filterTextInput expand: false; + yourself +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> displayBlock: aBlock [ + + ^ self treePresenter display: aBlock +] + +{ #category : 'api' } +DTFilterableTreePresenter >> displayColor: aBlock [ + + self treePresenter displayColor: aBlock +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> displayIcon: aFullBlockClosure [ + + self treePresenter displayIcon: aFullBlockClosure +] + +{ #category : 'private - actions' } +DTFilterableTreePresenter >> ensureActions [ + + ^ self treePresenter ensureActions +] + +{ #category : 'expanding-collapsing' } +DTFilterableTreePresenter >> expandAll [ + + self treePresenter expandAll +] + +{ #category : 'private' } +DTFilterableTreePresenter >> filterList [ + "Filters the list according to the filterTextInput." + + self unselectAll. + self filterStrings ifEmpty: [ + self roots: initialItems. + ^ self ]. + self roots: (initialItems select: [ :each | + self filterStrings anySatisfy: [ :any | + any match: (self treePresenter display value: each) ] ]) +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> filterStrings [ + + ^ (self filterTextInput text splitOn: $|) + reject: #isEmpty + thenCollect: [ :pattern | '*' , pattern , '*' ] +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> filterTextInput [ + + ^ filterTextInput +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> help [ + + ^ labelPresenter help +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> help: aString [ + + labelPresenter help: aString +] + +{ #category : 'initialization' } +DTFilterableTreePresenter >> initialize [ + + super initialize. + initialItems := #() +] + +{ #category : 'initialization' } +DTFilterableTreePresenter >> initializePresenters [ + + labelPresenter := self newLabel. + treePresenter := self newTree. + filterTextInput := self newTextInput + placeholder: 'Filter...'; + whenTextChangedDo: [ self filterList ]; + yourself +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> items [ + + ^ self visibleItems +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> label [ + + ^ labelPresenter label +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> label: aString [ + + labelPresenter label: aString +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> labelPresenter [ + + ^ labelPresenter +] + +{ #category : 'actions' } +DTFilterableTreePresenter >> resetFilter [ + + self filterTextInput text: ''. + self treePresenter roots: initialItems +] + +{ #category : 'api' } +DTFilterableTreePresenter >> roots: aBlock [ + + initialItems := aBlock. + self treePresenter roots: aBlock +] + +{ #category : 'actions' } +DTFilterableTreePresenter >> selectAll [ + + ^ self treePresenter selectAll +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> selectItems: aBlock [ + + ^ self treePresenter selectItems: aBlock +] + +{ #category : 'api - selection' } +DTFilterableTreePresenter >> selectPaths: aPathArray [ + + self treePresenter selectPaths: aPathArray +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> selectedItems [ + + ^ self treePresenter selectedItems +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> treePresenter [ + + ^ treePresenter +] + +{ #category : 'actions' } +DTFilterableTreePresenter >> unselectAll [ + + ^ self treePresenter unselectAll +] + +{ #category : 'accessing' } +DTFilterableTreePresenter >> visibleItems [ + + ^ self treePresenter roots +] + +{ #category : 'events' } +DTFilterableTreePresenter >> whenSelectionChangedDo: aBlock [ + + ^ self treePresenter whenSelectionChangedDo: aBlock +] diff --git a/src/DrTests/DTInspectSelectedItemCommand.class.st b/src/DrTests/DTInspectSelectedItemCommand.class.st new file mode 100644 index 00000000..6eaf53e3 --- /dev/null +++ b/src/DrTests/DTInspectSelectedItemCommand.class.st @@ -0,0 +1,22 @@ +" +I browse the selected result in the results list of DrTests. +" +Class { + #name : 'DTInspectSelectedItemCommand', + #superclass : 'DTMiddleListCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'default' } +DTInspectSelectedItemCommand class >> defaultName [ + + ^ 'Inspect' +] + +{ #category : 'executing' } +DTInspectSelectedItemCommand >> execute [ + + self context inspectSelectedItem +] diff --git a/src/DrTests/DTLeafResultCommand.class.st b/src/DrTests/DTLeafResultCommand.class.st new file mode 100644 index 00000000..9463bc28 --- /dev/null +++ b/src/DrTests/DTLeafResultCommand.class.st @@ -0,0 +1,21 @@ +" +I am an abstract command concerning DrTests' results tree but I can only be executed if a leaf is selected by user. +" +Class { + #name : 'DTLeafResultCommand', + #superclass : 'DTResultCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTLeafResultCommand class >> isAbstract [ + + ^ self name = #DTLeafResultCommand +] + +{ #category : 'hooks' } +DTLeafResultCommand >> canBeRun [ + ^ self resultSelected isLeaf +] diff --git a/src/DrTests/DTLeavesCollector.class.st b/src/DrTests/DTLeavesCollector.class.st new file mode 100644 index 00000000..22a8a280 --- /dev/null +++ b/src/DrTests/DTLeavesCollector.class.st @@ -0,0 +1,43 @@ +" +I am a visitor that collect the leaves of the DTTreeNode I visit. + +If there are multiple levels of DTTreeNode, no problem, I traverse them until I find the leaves. +" +Class { + #name : 'DTLeavesCollector', + #superclass : 'DTResultsTreeVisitor', + #instVars : [ + 'leaves' + ], + #category : 'DrTests-Visitors', + #package : 'DrTests', + #tag : 'Visitors' +} + +{ #category : 'instance creation' } +DTLeavesCollector class >> collectLeavesOf: aDTTreeNode [ + ^ self new + visit: aDTTreeNode; + leaves +] + +{ #category : 'initialization' } +DTLeavesCollector >> initialize [ + super initialize. + leaves := OrderedCollection new +] + +{ #category : 'accessing' } +DTLeavesCollector >> leaves [ + ^ leaves +] + +{ #category : 'accessing' } +DTLeavesCollector >> leaves: anObject [ + leaves := anObject +] + +{ #category : 'visiting' } +DTLeavesCollector >> visitDTTreeLeaf: aDTTreeLeaf [ + self leaves add: aDTTreeLeaf +] diff --git a/src/DrTests/DTMiddleListCommand.class.st b/src/DrTests/DTMiddleListCommand.class.st new file mode 100644 index 00000000..84d36a34 --- /dev/null +++ b/src/DrTests/DTMiddleListCommand.class.st @@ -0,0 +1,22 @@ +" +I am an abstract command concerning DrTests' middle list. +" +Class { + #name : 'DTMiddleListCommand', + #superclass : 'DTCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTMiddleListCommand class >> isAbstract [ + + ^ self name = #DTMiddleListCommand +] + +{ #category : 'accessing' } +DTMiddleListCommand >> selectedItems [ + + ^ self context selectedItems +] diff --git a/src/DrTests/DTNullPluginPresenter.class.st b/src/DrTests/DTNullPluginPresenter.class.st new file mode 100644 index 00000000..b45c216a --- /dev/null +++ b/src/DrTests/DTNullPluginPresenter.class.st @@ -0,0 +1,17 @@ +Class { + #name : 'DTNullPluginPresenter', + #superclass : 'SpPresenter', + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'layout' } +DTNullPluginPresenter >> defaultLayout [ + + ^ SpBoxLayout newHorizontal +] + +{ #category : 'updating' } +DTNullPluginPresenter >> updateUI [ +] diff --git a/src/DrTests/DTPackagesBrowseCommand.class.st b/src/DrTests/DTPackagesBrowseCommand.class.st new file mode 100644 index 00000000..54db0c5d --- /dev/null +++ b/src/DrTests/DTPackagesBrowseCommand.class.st @@ -0,0 +1,22 @@ +" +I browse the selected package in the package list of DrTests. +" +Class { + #name : 'DTPackagesBrowseCommand', + #superclass : 'DTPackagesCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'default' } +DTPackagesBrowseCommand class >> defaultName [ + + ^ 'Browse' +] + +{ #category : 'executing' } +DTPackagesBrowseCommand >> execute [ + + self context browseSelectedPackage +] diff --git a/src/DrTests/DTPackagesCommand.class.st b/src/DrTests/DTPackagesCommand.class.st new file mode 100644 index 00000000..a94761a8 --- /dev/null +++ b/src/DrTests/DTPackagesCommand.class.st @@ -0,0 +1,16 @@ +" +I am an abstract command concerning DrTests' package list. +" +Class { + #name : 'DTPackagesCommand', + #superclass : 'DTCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTPackagesCommand class >> isAbstract [ + + ^ self name = #DTPackagesCommand +] diff --git a/src/DrTests/DTPackagesInspectCommand.class.st b/src/DrTests/DTPackagesInspectCommand.class.st new file mode 100644 index 00000000..5d7bfb1d --- /dev/null +++ b/src/DrTests/DTPackagesInspectCommand.class.st @@ -0,0 +1,22 @@ +" +I inspect the selected package in the package list of DrTests. +" +Class { + #name : 'DTPackagesInspectCommand', + #superclass : 'DTPackagesCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'default' } +DTPackagesInspectCommand class >> defaultName [ + + ^ 'Inspect' +] + +{ #category : 'executing' } +DTPackagesInspectCommand >> execute [ + + self context inspectSelectedPackage +] diff --git a/src/DrTests/DTPackagesSelectAllCommand.class.st b/src/DrTests/DTPackagesSelectAllCommand.class.st new file mode 100644 index 00000000..de3b19e5 --- /dev/null +++ b/src/DrTests/DTPackagesSelectAllCommand.class.st @@ -0,0 +1,22 @@ +" +I select all packages in the package list of DrTests. +" +Class { + #name : 'DTPackagesSelectAllCommand', + #superclass : 'DTPackagesCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'defaults' } +DTPackagesSelectAllCommand class >> defaultName [ + + ^ 'Select all' +] + +{ #category : 'hooks' } +DTPackagesSelectAllCommand >> execute [ + + self context selectAllInPackageList +] diff --git a/src/DrTests/DTPackagesSelectNoneCommand.class.st b/src/DrTests/DTPackagesSelectNoneCommand.class.st new file mode 100644 index 00000000..516647af --- /dev/null +++ b/src/DrTests/DTPackagesSelectNoneCommand.class.st @@ -0,0 +1,22 @@ +" +I deselect all packages in the package list of DrTests. +" +Class { + #name : 'DTPackagesSelectNoneCommand', + #superclass : 'DTPackagesCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'defaults' } +DTPackagesSelectNoneCommand class >> defaultName [ + + ^ 'Select none' +] + +{ #category : 'executing' } +DTPackagesSelectNoneCommand >> execute [ + + self context selectNoneInPackageList +] diff --git a/src/DrTests/DTPluginConfiguration.class.st b/src/DrTests/DTPluginConfiguration.class.st new file mode 100644 index 00000000..4e0ebc6f --- /dev/null +++ b/src/DrTests/DTPluginConfiguration.class.st @@ -0,0 +1,81 @@ +" +I hold the information that would be used by a DrTestPlugin. +" +Class { + #name : 'DTPluginConfiguration', + #superclass : 'Object', + #instVars : [ + 'items', + 'packagesSelected', + 'testSuite' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'tests' } +DTPluginConfiguration class >> items: aCollectionOfClasses [ + ^ self new + items: aCollectionOfClasses; + yourself +] + +{ #category : 'tests' } +DTPluginConfiguration class >> items: aCollectionOfClasses packages: aCollectionOfPackages [ + ^ self new + items: aCollectionOfClasses; + packagesSelected: aCollectionOfPackages; + yourself +] + +{ #category : 'converting' } +DTPluginConfiguration >> asTestSuite [ + | suite | + suite := TestSuite new. + self items + reject: #isAbstract + thenDo: [ :s | suite addTest: s suite ]. + ^ suite +] + +{ #category : 'result handling' } +DTPluginConfiguration >> handleResults: aPluginResult for: aPlugin [ + ^ aPluginResult +] + +{ #category : 'accessing' } +DTPluginConfiguration >> items [ + ^ items +] + +{ #category : 'accessing' } +DTPluginConfiguration >> items: anObject [ + items := anObject +] + +{ #category : 'accessing' } +DTPluginConfiguration >> items: anObject packages: packages [ + items := anObject. + packagesSelected := packages +] + +{ #category : 'accessing' } +DTPluginConfiguration >> packagesSelected [ + ^ packagesSelected +] + +{ #category : 'accessing' } +DTPluginConfiguration >> packagesSelected: packages [ + packagesSelected := packages +] + +{ #category : 'accessing' } +DTPluginConfiguration >> testSuite [ + ^ testSuite +] + +{ #category : 'accessing' } +DTPluginConfiguration >> testSuite: anObject [ + testSuite := anObject +] diff --git a/src/DrTests/DTPluginResult.class.st b/src/DrTests/DTPluginResult.class.st new file mode 100644 index 00000000..b362f9e1 --- /dev/null +++ b/src/DrTests/DTPluginResult.class.st @@ -0,0 +1,38 @@ +" +I am the abstract superclass for all classes that are results of a plugin in DrTests. +" +Class { + #name : 'DTPluginResult', + #superclass : 'Object', + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'accessing' } +DTPluginResult >> backgroundColorStyle [ + + ^ 'testResult' +] + +{ #category : 'accessing' } +DTPluginResult >> buildTreeForUI [ + ^ self subclassResponsibility +] + +{ #category : 'accessing' } +DTPluginResult >> summarizeInfo [ + "Text showed in miniDrTests with info of the result " + + ^ self asString +] + +{ #category : 'accessing' } +DTPluginResult >> textColor [ + ^ TestResult defaultColorText +] + +{ #category : 'accessing' } +DTPluginResult >> theme [ + ^ Smalltalk ui theme +] diff --git a/src/DrTests/DTReRunConfiguration.class.st b/src/DrTests/DTReRunConfiguration.class.st new file mode 100644 index 00000000..fa98115a --- /dev/null +++ b/src/DrTests/DTReRunConfiguration.class.st @@ -0,0 +1,50 @@ +" +I am a configuration that re-run a part of the result of a previously-run configuration. +" +Class { + #name : 'DTReRunConfiguration', + #superclass : 'DTPluginConfiguration', + #instVars : [ + 'previousResult', + 'configurationToRun', + 'originalConfiguration' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'converting' } +DTReRunConfiguration >> asTestSuite [ + ^ self configurationToRun asTestSuite +] + +{ #category : 'accessing' } +DTReRunConfiguration >> configurationToRun [ + ^ configurationToRun +] + +{ #category : 'accessing' } +DTReRunConfiguration >> configurationToRun: anObject [ + configurationToRun := anObject +] + +{ #category : 'accessing' } +DTReRunConfiguration >> originalConfiguration [ + ^ originalConfiguration +] + +{ #category : 'accessing' } +DTReRunConfiguration >> originalConfiguration: anObject [ + originalConfiguration := anObject +] + +{ #category : 'accessing' } +DTReRunConfiguration >> previousResult [ + ^ previousResult +] + +{ #category : 'accessing' } +DTReRunConfiguration >> previousResult: anObject [ + previousResult := anObject +] diff --git a/src/DrTests/DTResultBrowseCommand.class.st b/src/DrTests/DTResultBrowseCommand.class.st new file mode 100644 index 00000000..378e1a55 --- /dev/null +++ b/src/DrTests/DTResultBrowseCommand.class.st @@ -0,0 +1,26 @@ +" +I browse the result selected by user of DrTests. +" +Class { + #name : 'DTResultBrowseCommand', + #superclass : 'DTLeafResultCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'defaults' } +DTResultBrowseCommand class >> defaultName [ + + ^ 'Browse' +] + +{ #category : 'testing' } +DTResultBrowseCommand >> canBeExecuted [ + ^ self resultSelected canBeBrowsed +] + +{ #category : 'hooks' } +DTResultBrowseCommand >> execute [ + self context browseSelectedResult +] diff --git a/src/DrTests/DTResultCommand.class.st b/src/DrTests/DTResultCommand.class.st new file mode 100644 index 00000000..aaba608e --- /dev/null +++ b/src/DrTests/DTResultCommand.class.st @@ -0,0 +1,21 @@ +" +I am an abstract command concerning DrTests' results tree. +" +Class { + #name : 'DTResultCommand', + #superclass : 'DTCommand', + #category : 'DrTests-Commands', + #package : 'DrTests', + #tag : 'Commands' +} + +{ #category : 'testing' } +DTResultCommand class >> isAbstract [ + + ^ self name = #DTResultCommand +] + +{ #category : 'hooks' } +DTResultCommand >> resultSelected [ + ^ self context resultSelected +] diff --git a/src/DrTests/DTResultTreeView.class.st b/src/DrTests/DTResultTreeView.class.st new file mode 100644 index 00000000..d41c6854 --- /dev/null +++ b/src/DrTests/DTResultTreeView.class.st @@ -0,0 +1,49 @@ +" +I model a tree view that can be created on a DTPluginResult. +" +Class { + #name : 'DTResultTreeView', + #superclass : 'Object', + #instVars : [ + 'name', + 'blockToExtractViewFromResult' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'instance creation' } +DTResultTreeView class >> name: aString blockToExtractViewFromResult: blockToExtractViewFromResult [ + ^ self new + name: aString; + blockToExtractViewFromResult: blockToExtractViewFromResult; + yourself +] + +{ #category : 'accessing' } +DTResultTreeView >> blockToExtractViewFromResult [ + ^ blockToExtractViewFromResult +] + +{ #category : 'accessing' } +DTResultTreeView >> blockToExtractViewFromResult: anObject [ + blockToExtractViewFromResult := anObject +] + +{ #category : 'accessing' } +DTResultTreeView >> name [ + ^ name +] + +{ #category : 'accessing' } +DTResultTreeView >> name: anObject [ + name := anObject +] + +{ #category : 'accessing' } +DTResultTreeView >> resultTreeFor: result [ + result ifNil: [ + ^ DTTreeNode empty ]. + ^ self blockToExtractViewFromResult value: result +] diff --git a/src/DrTests/DTResultsTreeVisitor.class.st b/src/DrTests/DTResultsTreeVisitor.class.st new file mode 100644 index 00000000..9e8bf4ea --- /dev/null +++ b/src/DrTests/DTResultsTreeVisitor.class.st @@ -0,0 +1,25 @@ +" +I am an abstract visitor for the results tree of DrTests. +" +Class { + #name : 'DTResultsTreeVisitor', + #superclass : 'Object', + #category : 'DrTests-Visitors', + #package : 'DrTests', + #tag : 'Visitors' +} + +{ #category : 'visiting' } +DTResultsTreeVisitor >> visit: anObject [ + ^ anObject acceptVisitor: self +] + +{ #category : 'visiting' } +DTResultsTreeVisitor >> visitDTTreeLeaf: aDTTreeLeaf [ + ^ self subclassResponsibility +] + +{ #category : 'visiting' } +DTResultsTreeVisitor >> visitDTTreeNode: aDTTreeNode [ + ^ aDTTreeNode subResults collect: [ :subResult | self visit: subResult ] +] diff --git a/src/DrTests/DTStatusUpdate.class.st b/src/DrTests/DTStatusUpdate.class.st new file mode 100644 index 00000000..a956f332 --- /dev/null +++ b/src/DrTests/DTStatusUpdate.class.st @@ -0,0 +1,33 @@ +" +I am an announcement to force the UI to refresh the status bar. +This is useful when the results are handled in a asynchronous way +" +Class { + #name : 'DTStatusUpdate', + #superclass : 'Announcement', + #instVars : [ + 'message' + ], + #category : 'DrTests-Announcements', + #package : 'DrTests', + #tag : 'Announcements' +} + +{ #category : 'instance creation' } +DTStatusUpdate class >> message: aString [ + + ^ self new + message: aString; + yourself +] + +{ #category : 'accessing' } +DTStatusUpdate >> message [ + + ^ message +] + +{ #category : 'accessing' } +DTStatusUpdate >> message: anObject [ + message := anObject +] diff --git a/src/DrTests/DTStyleContributor.class.st b/src/DrTests/DTStyleContributor.class.st new file mode 100644 index 00000000..1accbefa --- /dev/null +++ b/src/DrTests/DTStyleContributor.class.st @@ -0,0 +1,38 @@ +Class { + #name : 'DTStyleContributor', + #superclass : 'StPharoStyleContributor', + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'styles' } +DTStyleContributor >> styleSheetContribution [ + + ^ SpStyle newApplication + addClass: 'testError' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: TestResult defaultColorBackGroundForErrorTest ] ]; + "addClass: 'testExpectedFailure' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: Color transparent ] ];" + addClass: 'testFail' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: TestResult defaultColorBackGroundForFailureTest ] ]; + addClass: 'testPass' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: TestResult defaultColorBackGroundForPassingTest ] ]; + addClass: 'testSkipped' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: TestResult defaultColorBackGroundForPassingTest ] ]; + "addClass: 'testUnexpectedPass' with: [ :class | + class addPropertyDrawWith: [ :draw | + draw backgroundColor: Color gray ] ];" + yourself +] + +{ #category : 'styles' } +DTStyleContributor >> theme [ + + ^ Smalltalk ui theme +] diff --git a/src/DrTests/DTTreeLeafNode.class.st b/src/DrTests/DTTreeLeafNode.class.st new file mode 100644 index 00000000..c6b5e9b3 --- /dev/null +++ b/src/DrTests/DTTreeLeafNode.class.st @@ -0,0 +1,68 @@ +" +I am a leaf of a Result Tree. +I have te content and I know the way to browse myself. +" +Class { + #name : 'DTTreeLeafNode', + #superclass : 'DTAbstractTreeNode', + #instVars : [ + 'content' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'instance creation' } +DTTreeLeafNode class >> content: aRottenTest [ + ^ self new + content: aRottenTest; + yourself +] + +{ #category : 'visiting' } +DTTreeLeafNode >> acceptVisitor: aDTResultsTreeVisitor [ + ^ aDTResultsTreeVisitor visitDTTreeLeaf: self +] + +{ #category : 'testing' } +DTTreeLeafNode >> canBeBrowsed [ + + ^ true +] + +{ #category : 'accessing' } +DTTreeLeafNode >> content [ + ^ content +] + +{ #category : 'accessing' } +DTTreeLeafNode >> content: anObject [ + content := anObject +] + +{ #category : 'accessing' } +DTTreeLeafNode >> contentForReRun [ + ^ { self content } +] + +{ #category : 'actions' } +DTTreeLeafNode >> drTestsBrowse [ + self content drTestsBrowse +] + +{ #category : 'menu' } +DTTreeLeafNode >> drTestsBuildContextMenu: menu [ + self content drTestsBuildContextMenu: menu +] + +{ #category : 'accessing' } +DTTreeLeafNode >> drTestsName [ + ^ self content drTestsName +] + +{ #category : 'testing' } +DTTreeLeafNode >> isLeaf [ + + ^ true +] diff --git a/src/DrTests/DTTreeNode.class.st b/src/DrTests/DTTreeNode.class.st new file mode 100644 index 00000000..d7561e50 --- /dev/null +++ b/src/DrTests/DTTreeNode.class.st @@ -0,0 +1,167 @@ +" +I am a node from a tree used to show results in DrTestUI. + +" +Class { + #name : 'DTTreeNode', + #superclass : 'DTAbstractTreeNode', + #instVars : [ + 'name', + 'subResults', + 'contextMenuBlock', + 'subResultsAggregator', + 'browseBlock', + 'shouldStartExpanded', + 'displayColor' + ], + #category : 'DrTests-Model', + #package : 'DrTests', + #tag : 'Model' +} + +{ #category : 'instance creation' } +DTTreeNode class >> empty [ + ^ self new + subResults: #(); + yourself +] + +{ #category : 'visiting' } +DTTreeNode >> acceptVisitor: aDTResultsTreeVisitor [ + ^ aDTResultsTreeVisitor visitDTTreeNode: self +] + +{ #category : 'accessing' } +DTTreeNode >> browseBlock [ + ^ browseBlock +] + +{ #category : 'accessing' } +DTTreeNode >> browseBlock: anObject [ + browseBlock := anObject +] + +{ #category : 'testing' } +DTTreeNode >> canBeBrowsed [ + + ^ self browseBlock isNotNil +] + +{ #category : 'accessing' } +DTTreeNode >> contentForReRun [ + ^ (DTLeavesCollector collectLeavesOf: self) flatCollect: #contentForReRun +] + +{ #category : 'accessing' } +DTTreeNode >> contextMenuBlock [ + ^ contextMenuBlock +] + +{ #category : 'accessing' } +DTTreeNode >> contextMenuBlock: anObject [ + contextMenuBlock := anObject +] + +{ #category : 'accessing' } +DTTreeNode >> displayColor [ + + ^ displayColor value +] + +{ #category : 'accessing' } +DTTreeNode >> displayColor: aValuableOrColor [ + + displayColor := aValuableOrColor +] + +{ #category : 'accessing' } +DTTreeNode >> displayColorIfNotEmpty: aColor [ + + self displayColor: [ + self subResults + ifNotEmpty: [ aColor ] + ifEmpty: [ nil ] ] +] + +{ #category : 'actions' } +DTTreeNode >> drTestsBrowse [ + "Browse the tree node according to what is specified by my #browseBlock. + If my #browseBlock is nil, does nothing." + self canBeBrowsed + ifFalse: [ ^ self ]. + + self browseBlock cull: self +] + +{ #category : 'menu' } +DTTreeNode >> drTestsBuildContextMenu: menu [ + self contextMenuBlock value: menu +] + +{ #category : 'accessing' } +DTTreeNode >> drTestsName [ + + ^ String streamContents: [ :s | + s + << self name; + << ' ('; + << (self subResultsAggregator value: self subResults) asString; + << ')' ] +] + +{ #category : 'initialization' } +DTTreeNode >> initialize [ + + super initialize. + self contextMenuBlock: [ :menu | ]. "Does nothing by default." + self subResultsAggregator: [ :subRes | (DTLeavesCollector collectLeavesOf: self) size ]. + shouldStartExpanded := false +] + +{ #category : 'accessing' } +DTTreeNode >> name [ + ^ name +] + +{ #category : 'accessing' } +DTTreeNode >> name: anObject [ + name := anObject +] + +{ #category : 'testing' } +DTTreeNode >> shouldStartExpanded [ + + ^ shouldStartExpanded +] + +{ #category : 'accessing' } +DTTreeNode >> startContracted [ + + shouldStartExpanded := false +] + +{ #category : 'accessing' } +DTTreeNode >> startExpanded [ + + shouldStartExpanded := true +] + +{ #category : 'accessing' } +DTTreeNode >> subResults [ + ^ subResults +] + +{ #category : 'accessing' } +DTTreeNode >> subResults: anObject [ + subResults := anObject +] + +{ #category : 'accessing' } +DTTreeNode >> subResultsAggregator [ + ^ subResultsAggregator +] + +{ #category : 'accessing' } +DTTreeNode >> subResultsAggregator: anObject [ + subResultsAggregator := anObject +] diff --git a/src/DrTests/DTUpdateResults.class.st b/src/DrTests/DTUpdateResults.class.st new file mode 100644 index 00000000..7185d9ee --- /dev/null +++ b/src/DrTests/DTUpdateResults.class.st @@ -0,0 +1,26 @@ +" +I am an announcement to force the UI to refresh the results. +This is useful when the results are handled in a asynchronous way +" +Class { + #name : 'DTUpdateResults', + #superclass : 'Announcement', + #instVars : [ + 'results' + ], + #category : 'DrTests-Announcements', + #package : 'DrTests', + #tag : 'Announcements' +} + +{ #category : 'accessing' } +DTUpdateResults >> results [ + + ^ results +] + +{ #category : 'accessing' } +DTUpdateResults >> results: anObject [ + + results := anObject +] diff --git a/src/DrTests/DrTests.class.st b/src/DrTests/DrTests.class.st new file mode 100644 index 00000000..a13213aa --- /dev/null +++ b/src/DrTests/DrTests.class.st @@ -0,0 +1,321 @@ +" +I provide the ability to: +* select a plugin to create/run tests +* select sets of items to analyze +* obtain a detailed log of the results + +UI Description +___________ + +The droplist contains all the plugins available to start the analysis. + +My left-most pane lists all of the categories that contain items (could subclasses of TestCase, executable comments, etc.); Once items are selected, the items that can be analyzed appear in the pane to right. +The right-most pane shows the results in different groups, depends the plugin's analysis. + +Run and browse buttons behaviour are defined by the current plugin selected. + + +" +Class { + #name : 'DrTests', + #superclass : 'AbstractDrTestsPresenter', + #instVars : [ + 'pluginsDropList', + 'statusLabel', + 'plugins', + 'pluginPresenter' + ], + #category : 'DrTests-Spec', + #package : 'DrTests', + #tag : 'Spec' +} + +{ #category : 'tools registry' } +DrTests class >> beDefaultTestRunner [ +