Skip to content

Commit

Permalink
Fixes: pharo-project#5213. Redoing all the changes logged in Epicea
Browse files Browse the repository at this point in the history
  • Loading branch information
@Ducasse
Ducasse committed Nov 24, 2019
1 parent f5aedf0 commit 1d64f96
Show file tree
Hide file tree
Showing 9 changed files with 53 additions and 45 deletions.
17 changes: 13 additions & 4 deletions src/DrTests-CommentsToTests/CommentTestCase.class.st
View file
Expand Up @@ -16,9 +16,12 @@ Class {
#category : #'DrTests-CommentsToTests'
}

{ #category : #'as yet unclassified' }
{ #category : #'instance creation' }
CommentTestCase class >> comment: stringComment class: aClass selector: aSymbol [

| result |
self flag: #todo.
"this method body should be moved on instance side."
result := [ Smalltalk compiler evaluate: stringComment ]
on: Exception
do: [ ^ self errorComment: stringComment class: aClass selector: aSymbol ].
Expand All @@ -34,8 +37,10 @@ CommentTestCase class >> comment: stringComment class: aClass selector: aSymbol
yourself ]
]

{ #category : #'as yet unclassified' }
{ #category : #'instance creation' }
CommentTestCase class >> errorComment: stringComment class: aClass selector: aSymbol [
self flag: #todo.
"this method body should be moved on instance side."
^ self new
expression: stringComment;
setTestSelector: #testError;
Expand All @@ -54,6 +59,8 @@ CommentTestCase class >> example [

{ #category : #accessing }
CommentTestCase class >> testSelectors [
self flag: #todo.
"missing comments. I have no ide what this method is doing."
^ super testSelectors \ {#testError . #testIt}
]

Expand Down Expand Up @@ -88,6 +95,8 @@ CommentTestCase >> currentValue: anObject [

{ #category : #accessing }
CommentTestCase >> drTestsBrowse [
self flag: #todo.
"this should be done via the presenter application and not using a global variable."
Smalltalk tools browser openOnClass: classExample selector: selectorExample
]

Expand Down Expand Up @@ -133,10 +142,10 @@ CommentTestCase >> selectorExample: anObject [

{ #category : #accessing }
CommentTestCase >> testError [
self error:'syntax error on the comment'
self error: 'syntax error on the comment'
]

{ #category : #accessing }
CommentTestCase >> testIt [
self assert: expectedValue equals: currentValue
self assert: expectedValue equals: currentValue
]
5 changes: 2 additions & 3 deletions src/DrTests-CommentsToTests/DTCommentTestConfiguration.class.st
View file
Expand Up @@ -13,14 +13,13 @@ DTCommentTestConfiguration >> asTestSuite [
suite := TestSuite new.
suite := TestSuite named: 'Test Generated From Comments'.
self items
reject: #isAbstract
reject: [ :each | each isAbstract ]
thenDo: [ :c |
c methods
do: [ :m |
(m methodClass compiledMethodAt: m selector) comments
do: [ :com |
(com includesSubstring: '>>>')
ifTrue: [ suite
addTest: (CommentTestCase comment: com class: c selector: m selector) ] ] ] ].
ifTrue: [ suite addTest: (CommentTestCase comment: com class: c selector: m selector) ] ] ] ].
^ suite
]
6 changes: 3 additions & 3 deletions src/DrTests-CommentsToTests/DTCommentToTest.class.st
View file
Expand Up @@ -60,13 +60,13 @@ DTCommentToTest >> pragmaForResultTrees [

{ #category : #api }
DTCommentToTest >> resultButtonHelp [
^ 'Browse the test selected in the results list.' translated
^ 'Browse the test selected in the result list.'
]

{ #category : #api }
DTCommentToTest >> runForConfiguration: aDTpluginConfiguration [
^ self pluginResultClass new
testsResult: (self runTestSuites: {aDTpluginConfiguration asTestSuite});
testResults: (self runTestSuites: {aDTpluginConfiguration asTestSuite});
yourself
]

Expand Down Expand Up @@ -101,7 +101,7 @@ DTCommentToTest >> secondListLabel [

{ #category : #api }
DTCommentToTest >> startButtonHelp [
^ 'Run tests selected.' translated
^ 'Run selected tests.'
]

{ #category : #api }
Expand Down
10 changes: 5 additions & 5 deletions src/DrTests-CommentsToTests/DTCommentToTestResult.class.st
View file
Expand Up @@ -21,27 +21,27 @@ DTCommentToTestResult >> buildTreeForUI [
subResults:
{(DTTreeNode new
name: 'Errors';
subResults: (self testsResult errors collect: #asResultForDrTest);
subResults: (self testResults errors collect: [:each | each asResultForDrTest ]);
yourself).
(DTTreeNode new
name: 'Failures';
subResults:
(self testsResult failures collect: #asResultForDrTest)
(self testResults failures collect: [:each | each asResultForDrTest] )
asOrderedCollection;
yourself).
(DTTreeNode new
name: 'Passed tests';
subResults: (self testsResult passed collect: #asResultForDrTest);
subResults: (self testResults passed collect: [:each | each asResultForDrTest] );
yourself)};
yourself
]

{ #category : #accessing }
DTCommentToTestResult >> testsResult [
DTCommentToTestResult >> testResults [
^ testsResult
]

{ #category : #accessing }
DTCommentToTestResult >> testsResult: anObject [
DTCommentToTestResult >> testResults: anObject [
testsResult := anObject
]
2 changes: 1 addition & 1 deletion src/DrTests-Tests/DrTestsTestRunnerTest.class.st
View file
Expand Up @@ -79,5 +79,5 @@ DrTestsTestRunnerTest >> testSelectedPackagesContainTestCases [
{ #category : #tests }
DrTestsTestRunnerTest >> testTestResultIsNotEmpty [
self
deny: (plugin runForConfiguration: conf) testsResult passed isEmpty
deny: (plugin runForConfiguration: conf) testResults passed isEmpty
]
2 changes: 1 addition & 1 deletion src/DrTests-TestsProfiling/DTTestsProfiling.class.st
View file
Expand Up @@ -48,7 +48,7 @@ DTTestsProfiling >> runForConfiguration: aDTpluginConfiguration [
aDTpluginConfiguration asTestSuite
acceptSUnitVisitor: profilerVisitor.
results := self pluginResultClass new
testsResult: profilerVisitor profilingData;
testResults: profilerVisitor profilingData;
yourself.
^ results
]
Expand Down
14 changes: 7 additions & 7 deletions src/DrTests-TestsProfiling/DTTestsProfilingResult.class.st
View file
Expand Up @@ -25,7 +25,7 @@ DTTestsProfilingResult >> buildTreeForUI [
{(self buildTreeNode
name: 'Errors';
subResults:
((self testsResult
((self testResults
select:
[ :testCaseToTimeTaken | testCaseToTimeTaken testResult errors isNotEmpty ])
collect: [ :testCaseToTimeTaken |
Expand All @@ -36,7 +36,7 @@ DTTestsProfilingResult >> buildTreeForUI [
(self buildTreeNode
name: 'Failures';
subResults:
((self testsResult
((self testResults
select:
[ :testCaseToTimeTaken | testCaseToTimeTaken testResult failures isNotEmpty ])
collect: [ :testCaseToTimeTaken |
Expand All @@ -47,7 +47,7 @@ DTTestsProfilingResult >> buildTreeForUI [
(self buildTreeNode
name: 'Skipped tests';
subResults:
((self testsResult
((self testResults
select:
[ :testCaseToTimeTaken | testCaseToTimeTaken testResult skipped isNotEmpty ])
collect: [ :testCaseToTimeTaken |
Expand All @@ -58,7 +58,7 @@ DTTestsProfilingResult >> buildTreeForUI [
(self buildTreeNode
name: 'Passed tests';
subResults:
((self testsResult
((self testResults
select:
[ :testProfilerResult | testProfilerResult testResult passed isNotEmpty ])
collect: [ :testCaseToTimeTaken |
Expand All @@ -73,7 +73,7 @@ DTTestsProfilingResult >> buildTreeForUI [
DTTestsProfilingResult >> buildTreeGroupedByClass [
<dTTestsProfilingResultTreeNamed: 'Grouped by class'>
^ self buildTreeNode
subResults: ((self testsResult groupedBy: [ :d | d testCase class ]) associations collect: [ :assoc |
subResults: ((self testResults groupedBy: [ :d | d testCase class ]) associations collect: [ :assoc |
self buildTreeNode
name: assoc key name;
subResults: (assoc value collect: [ :t | DTTreeLeaf content: t ]);
Expand All @@ -94,11 +94,11 @@ DTTestsProfilingResult >> buildTreeNode [
]

{ #category : #accessing }
DTTestsProfilingResult >> testsResult [
DTTestsProfilingResult >> testResults [
^ testsResult
]

{ #category : #accessing }
DTTestsProfilingResult >> testsResult: anObject [
DTTestsProfilingResult >> testResults: anObject [
testsResult := anObject
]
6 changes: 3 additions & 3 deletions src/DrTests-TestsRunner/DTTestsRunner.class.st
View file
Expand Up @@ -59,9 +59,9 @@ DTTestsRunner >> handleReRunResult: rerunnedResult forConfiguration: aDTRerunCon
| oldResult |
oldResult := self
removeTests: aDTRerunConfiguration configurationToRun items
from: aDTRerunConfiguration previousResult testsResult.
from: aDTRerunConfiguration previousResult testResults.
^ self pluginResultClass new
testsResult: (self joinTestResult: oldResult with: rerunnedResult testsResult);
testResults: (self joinTestResult: oldResult with: rerunnedResult testResults);
yourself
]

Expand Down Expand Up @@ -115,7 +115,7 @@ DTTestsRunner >> resultButtonHelp [
DTTestsRunner >> runForConfiguration: aDTpluginConfiguration [
| results |
results := self pluginResultClass new
testsResult: (self runTestSuites: { aDTpluginConfiguration asTestSuite });
testResults: (self runTestSuites: { aDTpluginConfiguration asTestSuite });
yourself.
^ aDTpluginConfiguration handleResults: results for: self
]
Expand Down
36 changes: 18 additions & 18 deletions src/DrTests-TestsRunner/DTTestsRunnerResult.class.st
View file
Expand Up @@ -54,17 +54,17 @@ DTTestsRunnerResult >> buildTreeForUI [
subResults:
{DTTreeNode new
name: DTTestResultType error pluralName;
subResults: (self buildLeavesFrom: self testsResult errors asOrderedCollection type: DTTestResultType error);
subResults: (self buildLeavesFrom: self testResults errors asOrderedCollection type: DTTestResultType error);
yourself.
DTTreeNode new
name: DTTestResultType fail pluralName;
subResults: (self buildLeavesFrom: self testsResult failures asOrderedCollection type: DTTestResultType fail).
subResults: (self buildLeavesFrom: self testResults failures asOrderedCollection type: DTTestResultType fail).
DTTreeNode new
name: DTTestResultType skipped pluralName;
subResults: (self buildLeavesFrom: self testsResult skipped asOrderedCollection type: DTTestResultType skipped).
subResults: (self buildLeavesFrom: self testResults skipped asOrderedCollection type: DTTestResultType skipped).
DTTreeNode new
name: DTTestResultType pass pluralName;
subResults: (self buildLeavesFrom: self testsResult passed asOrderedCollection type: DTTestResultType pass)
subResults: (self buildLeavesFrom: self testResults passed asOrderedCollection type: DTTestResultType pass)
};
yourself
]
Expand All @@ -74,10 +74,10 @@ DTTestsRunnerResult >> buildTreeForUIByClasses [
<dTTestRunnerResultTreeNamed: 'Grouped by type of result and classes'>

| errors failures skipped passed |
errors := self buildNodeGroupedByTypeAndClass: self testsResult errors type: DTTestResultType error.
failures := self buildNodeGroupedByTypeAndClass: self testsResult failures asOrderedCollection type: DTTestResultType fail.
skipped := self buildNodeGroupedByTypeAndClass: self testsResult skipped type: DTTestResultType skipped.
passed := self buildNodeGroupedByTypeAndClass: self testsResult passed type: DTTestResultType pass.
errors := self buildNodeGroupedByTypeAndClass: self testResults errors type: DTTestResultType error.
failures := self buildNodeGroupedByTypeAndClass: self testResults failures asOrderedCollection type: DTTestResultType fail.
skipped := self buildNodeGroupedByTypeAndClass: self testResults skipped type: DTTestResultType skipped.
passed := self buildNodeGroupedByTypeAndClass: self testResults passed type: DTTestResultType pass.
^ DTTreeNode new
subResults:
{errors.
Expand All @@ -92,10 +92,10 @@ DTTestsRunnerResult >> buildTreeForUIByClassesAndProtocol [
<dTTestRunnerResultTreeNamed: 'Grouped by type of result, classes, and protocol'>

| errors failures skipped passed |
errors := self buildNodeGroupedByTypeClassAndProtocol: self testsResult errors type: DTTestResultType error.
failures := self buildNodeGroupedByTypeClassAndProtocol: self testsResult failures asOrderedCollection type: DTTestResultType fail.
skipped := self buildNodeGroupedByTypeClassAndProtocol: self testsResult skipped type: DTTestResultType skipped.
passed := self buildNodeGroupedByTypeClassAndProtocol: self testsResult passed type: DTTestResultType pass.
errors := self buildNodeGroupedByTypeClassAndProtocol: self testResults errors type: DTTestResultType error.
failures := self buildNodeGroupedByTypeClassAndProtocol: self testResults failures asOrderedCollection type: DTTestResultType fail.
skipped := self buildNodeGroupedByTypeClassAndProtocol: self testResults skipped type: DTTestResultType skipped.
passed := self buildNodeGroupedByTypeClassAndProtocol: self testResults passed type: DTTestResultType pass.
^ DTTreeNode new
subResults:
{errors.
Expand All @@ -119,25 +119,25 @@ DTTestsRunnerResult >> summarizeInfo [
^ String
streamContents: [ :s |
s
print: self testsResult passed size;
print: self testResults passed size;
<< ' passed';
cr;
print: self testsResult failures size;
print: self testResults failures size;
<< ' failures';
cr;
print: self testsResult errors size;
print: self testResults errors size;
<< ' errors';
cr;
print: self testsResult skipped size;
print: self testResults skipped size;
<< ' skipped' ]
]

{ #category : #accessing }
DTTestsRunnerResult >> testsResult [
DTTestsRunnerResult >> testResults [
^ testsResult
]

{ #category : #accessing }
DTTestsRunnerResult >> testsResult: anObject [
DTTestsRunnerResult >> testResults: anObject [
testsResult := anObject
]

0 comments on commit 1d64f96

Please sign in to comment.