Commits

Ryan Macnak committed 5ce338e

Test results presenter for should says <NameOfTestConfig> <Passed|Failed> and link back to the configuration class. For now, turn link into a label since it's not clear how to derive the configuration class from the model.

  • Participants
  • Parent commits dec13af

Comments (0)

Files changed (1)

-Newspeak3
+Newspeak3
+'Minitest'
+class MinitestUI usingPlatform: platform minitest: minitest ide: ide = NewspeakObject (
+"Hopscotch UI for unit testing using Minitest."|
+	private Gradient = platform brazil plumbing Gradient.
 
-'Minitest'
+	private Presenter = platform hopscotch core Presenter.
+	private Subject = platform hopscotch core Subject.
 
-
+	private AssortedMethodsPresenter = ide browsing AssortedMethodsPresenter.
+	private ExpandableMethodPresenter = ide browsing ExpandableMethodPresenter.
+	private MethodReference = platform blackMarket System MethodReference.
+	private MethodSubject = ide browsing MethodSubject.
+	private ProgrammingPresenter = ide tools ProgrammingPresenter.
 
-class MinitestUI usingPlatform: platform minitest: minitest ide: ide = NewspeakObject (
-"Hopscotch UI for unit testing using Minitest."
-|
-	private Gradient = platform brazil plumbing Gradient.
-
-	private Presenter = platform hopscotch core Presenter.
-	private Subject = platform hopscotch core Subject.
-
-	private AssortedMethodsPresenter = ide browsing AssortedMethodsPresenter.
-	private ExpandableMethodPresenter = ide browsing ExpandableMethodPresenter.
-	private MethodReference = platform blackMarket System MethodReference.
-	private MethodSubject = ide browsing MethodSubject.
-	private ProgrammingPresenter = ide tools ProgrammingPresenter.
-
-	private OrderedCollection = platform collections OrderedCollection.
-	private Dictionary = platform collections Dictionary.
-	
-	"ungood imports"
-	private Exception = platform blackMarket Exceptions Exception.
-	private Error = platform blackMarket Exceptions Error.
-	private Color = platform blackMarket Graphics Color.
-	
-	private TestCatalog = minitest TestCatalog.
-|
-)
-
-(
-
-
-
-class TestingOutcomePresenter onSubject: s <TestingOutcomeSubject> = ProgrammingPresenter onSubject: s ("Shows an outcome of running a suite of tests, as a page with separate sections for errors, failures and successes."
-|
-|
-)
-
-('as yet unclassified'
-
-definition ^ <Fragment> = (
-
-
-
-didAllTestsPass = (
-
-
-
-didNoTestsFail ^ <Boolean> = (
-
-
-
-errors ^ <Fragment> = (
-
-
-
-errorsSectionColor = (
-
-
-
-failureHeadingColor = (
-
-
-
-failures ^ <Fragment> = (
-
-
-
-failuresSectionColor = (
-
-
-
-headingBlock: fragment color: aColor  = (
-
-
-
-headingContentsDefinition ^ <Presenter>  = (
-
-
-
-headingDefinition ^ <Presenter>  = (
-
-
-
-respondToRunAgain = (
-
-
-
-runToDebugFailure: testCase = (
-
-
-
-runWithNoExceptionHandling: testCase = (
-
-
-
-section: label <String> with: testCases <Collection[TestCase]> status: aSymbol <Symbol> color: aColor <Color | Gradient> ^ <Fragment> = (
-
-
-
-section: label <String> withHidden: testCases <Collection[TestCase]> status: aSymbol <Symbol> color: aColor <Color | Gradient> ^ <Fragment> = (
-
-
-
-successHeadingColor = (
-
-
-
-successes ^ <Fragment> = (
-
-
-
-successesSectionColor = (
-
-
-
-)
-
-
-
-class TestResultPresenter onSubject: s = ProgrammingPresenter onSubject: s ("Shows a single TestResult as an expandable selector of the method defining the test. If the result is a failure, also shows the description of the failure. "
-|
-	showIndicatorBar = true.
-	methodPresenter
-|
-)
-
-('as yet unclassified'
-
-definition ^ <Fragment> = (
-
-
-
-exceptionFragment ^ <Fragment> = (
-
-
-
-failureFragment = (
-
-
-
-footnoteColor = (
-
-
-
-indicatorBar = (
-
-
-
-methodPresenterDefinition = (
-
-
-
-resultColumn ^ <Fragment> = (
-
-
-
-statusColor ^ <Color> = (
-
-
-
-)
-
-
-
-class TestingInProgressPresenter onSubject: subject = Presenter onSubject: subject (
-"Presents a Tester in the process of running tests."
-|
-	progressBar
-|
-)
-
-('as yet unclassified'
-
-definition = (
-
-
-
-forkTests = (
-
-
-
-isTransient = (
-
-
-
-noticeVisualCreation = (
-
-
-
-runTests = (
-
-
-
-tester = (
-
-
-
-)
-
-
-
-class TestingOutcomeSubject tester: tester <Tester> = Subject onModel: tester (
-|
-|
-)
-
-('as yet unclassified'
-
-createPresenter = (
-
-
-
-errors = (
-
-
-
-failures = (
-
-
-
-successes = (
-
-
-
-tester = (
-
-
-
-title = (
-
-
-
-) : (
-
-'as yet unclassified'
-
-onModel: m ^ <TestingOutcomeSubject> = (
-
-
-
-)
-
-
-
-class TestResultListSubject onModel: list = Subject onModel: list ("The subject of a list of test results, such as a list of successes or failures of a test run. The model is a list of TestResult instances."
-|
-|
-)
-
-('as yet unclassified'
-
-createPresenter = (
-
-
-
-isEmpty ^ <Boolean> = (
-
-
-
-)
-
-
-
-class TestingInProgressSubject tester: tester <Tester> = Subject onModel: tester (
-"Represents a Tester instance, in the process of running tests."
-|
-|
-)
-
-('as yet unclassified'
-
-createPresenter = (
-
-
-
-title = (
-
-
-
-) : (
-
-'as yet unclassified'
-
-onConfiguration: configClass <Class> platform: platform minitest: minitest = (
-
-
-
-onModel: m = (
-
-
-
-)
-
-
-
-class TestResultSubject onModel: m <TestResult> = Subject onModel: m ("The subject for presenting a single TestResult."
-|
-|
-)
-
-('as yet unclassified'
-
-= x <Object> ^ <Boolean> = (
-
-
-
-classDeclarationMirror = (
-
-
-
-className = (
-
-
-
-exception = (
-
-
-
-failureDescription ^<String> = (
-
-
-
-hasException ^<Boolean> = (
-
-
-
-hash = (
-
-
-
-isFailure = (
-
-
-
-mixinClass = (
-
-
-
-selector ^ <Symbol> = (
-
-
-
-testCase = (
-
-
-
-)
-
-
-
-class TestResultListPresenter onSubject: s = AssortedMethodsPresenter onSubject: s ("A presenter for a list of TestResults, such as a list of successes or failures of a test run."
-|
-|
-)
-
-('as yet unclassified'
-
-contentPresenters ^ <Collection[Presenter]> = (
-
-
-
-))
+	private OrderedCollection = platform collections OrderedCollection.
+	private Dictionary = platform collections Dictionary.
+	
+	"ungood imports"
+	private Exception = platform blackMarket Exceptions Exception.
+	private Error = platform blackMarket Exceptions Error.
+	private Color = platform blackMarket Graphics Color.
+	
+	private TestCatalog = minitest TestCatalog.
+|)
+(
+class TestResultListPresenter onSubject: s = AssortedMethodsPresenter onSubject: s ("A presenter for a list of TestResults, such as a list of successes or failures of a test run."|
+|)
+('as yet unclassified'
+contentPresenters ^ <Collection[Presenter]> = (
+	| sortedTestResults |
+	sortedTestResults:: subject model asSortedList:
+		[:a :b | a testCase selector < b testCase selector].
+	^sortedTestResults collect:
+		[:each <TestResult>  | 
+		(TestResultPresenter onSubject: (TestResultSubject onModel: each)) showIndicatorBar: false]
+))
+class TestResultListSubject onModel: list = Subject onModel: list ("The subject of a list of test results, such as a list of successes or failures of a test run. The model is a list of TestResult instances."|
+|)
+('as yet unclassified'
+createPresenter = (
+	^TestResultListPresenter onSubject: self
+)
+isEmpty ^ <Boolean> = (
+	^model isEmpty
+))
+class TestResultPresenter onSubject: s = ProgrammingPresenter onSubject: s ("Shows a single TestResult as an expandable selector of the method defining the test. If the result is a failure, also shows the description of the failure. "|
+	showIndicatorBar = true.
+	methodPresenter
+|)
+('as yet unclassified'
+definition ^ <Fragment> = (
+	^showIndicatorBar
+		ifTrue: [row: {indicatorBar. elastic:: resultColumn}]
+		ifFalse: [resultColumn]
+)
+exceptionFragment ^ <Fragment> = (
+	| link |
+	link::
+		(link: subject exception printString 
+		action: [sendUp runWithNoExceptionHandling: subject testCase])
+			color: footnoteColor.
+	^row: {
+		blank: 12.
+		elastic: link.
+		}
+)
+failureFragment = (
+	^row: {
+		blank: 12.
+		(link: subject failureDescription
+		action: [sendUp runToDebugFailure: subject testCase])
+			color: footnoteColor
+		}
+)
+footnoteColor = (
+	^Color gray: 0.7
+)
+indicatorBar = (
+	^(row: {blank: 5} ) color:  statusColor.
+)
+methodPresenterDefinition = (
+	^ExpandableMethodPresenter onSubject:
+		(MethodSubject
+			on: (MethodReference class: subject mixinClass definingClass selector: subject selector)) 	
+)
+resultColumn ^ <Fragment> = (
+	methodPresenter:: methodPresenterDefinition. 
+	^column:{
+		methodPresenter.
+		subject isFailure ifTrue: [failureFragment].
+		subject hasException ifTrue: [exceptionFragment].
+		"subject hasNoData ifTrue: [noDataFragment]"
+	}
+)
+statusColor ^ <Color> = (
+	"subject passed ifTrue: [^Color green].
+	subject failed ifTrue: [^Color red].
+	subject error ifTrue: [^Color black]."
+	^Color gray.
+))
+class TestResultSubject onModel: m <TestResult> = Subject onModel: m ("The subject for presenting a single TestResult."|
+|)
+('as yet unclassified'
+= x <Object> ^ <Boolean> = (
+	x class = class ifFalse: [^false].
+	^selector = x selector and: [className = x className]
+)
+classDeclarationMirror = (
+	^testCase environment classDeclarationMirror
+)
+className = (
+	^classDeclarationMirror fullyQualifiedName
+)
+exception = (
+"If the model is a test error, return the exception associated with the result. Otherwise return nil."
+	^model isError
+		ifTrue: [model exception]
+		ifFalse: [nil]
+)
+failureDescription ^<String> = (
+"If the model is a failure, return the description of the failure. Otherwise return an empty string."
+	^isFailure
+		ifTrue: [model description]
+		ifFalse: ['']
+)
+hasException ^<Boolean> = (
+"True if the test result has an exception associated with it, or in other words, the result is a test error."
+	^model isError
+)
+hash = (
+	^selector hash * 37 + className hash
+)
+isFailure = (
+	^model isFailure
+)
+mixinClass = (
+	^testCase environment mixinClass
+)
+selector ^ <Symbol> = (
+	^testCase selector
+)
+testCase = (
+	^model testCase
+))
+class TestingInProgressPresenter onSubject: subject = Presenter onSubject: subject (
+"Presents a Tester in the process of running tests."|
+	progressBar
+|)
+('as yet unclassified'
+definition = (
+	progressBar:: progress. 
+	^progressBar
+)
+forkTests = (
+	tester prepare.
+	fork:
+		[[runTests] ensure: [tester cleanUp]]
+	thenUpdateUI:
+		[enterSubject:: TestingOutcomeSubject tester: tester]
+)
+isTransient = (
+"Do not include this presenter into navigation history."
+	^true
+)
+noticeVisualCreation = (
+	super noticeVisualCreation.
+	forkTests.
+)
+runTests = (
+	[tester atEnd] whileFalse:
+		[tester step.
+		progressBar percentComplete: tester completedRatio * 100]
+)
+tester = (
+	^subject model
+))
+class TestingInProgressSubject tester: tester <Tester> = Subject onModel: tester (
+"Represents a Tester instance, in the process of running tests."|
+|)
+('as yet unclassified'
+createPresenter = (
+	^TestingInProgressPresenter onSubject: self
+)
+title = (
+	^'Running Tests'
+)) : ('as yet unclassified'
+onConfiguration: configClass <Class> platform: platform minitest: minitest = (
+	| config modules tester |
+	config:: configClass packageTestsUsing: platform.
+	modules:: config testModulesUsingPlatform: platform minitest: minitest.
+	tester:: minitest Tester testModules: modules.
+	^self tester: tester
+)
+onModel: m = (
+	^ tester: m.
+))
+class TestingOutcomePresenter onSubject: s <TestingOutcomeSubject> = ProgrammingPresenter onSubject: s ("Shows an outcome of running a suite of tests, as a page with separate sections for errors, failures and successes."|
+|)
+('as yet unclassified'
+definition ^ <Fragment> = (
+	^column:{
+	      headingDefinition.
+		blank: 2.
+		errors.
+		blank: 1.
+		failures.
+		blank: 1. 
+		successes. 
+	}
+)
+didAllTestsPass = (
+	^didNoTestsFail "not tracking incomplete for now, so no difference from didNoTestsFail"
+)
+didNoTestsFail ^ <Boolean> = (
+	^subject failures isEmpty and: [subject errors isEmpty]
+)
+errors ^ <Fragment> = (
+	^section: 'Errors'
+		with: subject errors
+		status: #error
+		color: errorsSectionColor
+)
+errorsSectionColor = (
+	^Gradient from: (Color h: 0 s: 0.15 v: 1) to: (Color h: 0 s: 0.15 v: 0.9)
+)
+failureHeadingColor = (
+	^Gradient from: (Color h: 0 s: 0.5 v: 0.8) to: (Color h: 0 s: 0.5 v: 0.6)
+)
+failures ^ <Fragment> = (
+	^section: 'Failures'
+		with: subject failures
+		status: #failure
+		color: failuresSectionColor
+)
+failuresSectionColor = (
+	^Gradient from: (Color h: 50 s: 0.3 v: 1) to: (Color h: 50 s: 0.3 v: 0.9)
+)
+headingBlock: fragment color: aColor  = (
+	^(padded: fragment with: {10. 5. 5. 5}) color: aColor
+)
+headingContentsDefinition ^ <Presenter>  = (
+	| statusMessage |
+	statusMessage::
+		didAllTestsPass
+			ifTrue: ['Passed']
+			ifFalse: 
+				[didNoTestsFail
+					ifTrue: ['Incomplete test results']
+					ifFalse: ['Failed ']].
+	^row: {
+		"(link: 'Tests' asText allBold
+			action: [browseClass: subject testedClass]) color: Color white."
+		(label: 'Tests' asText allBold) color: Color white.
+		smallBlank.
+		(label: statusMessage asText allBold) color: Color white.
+		filler.
+		button: 'Run Again' action: [respondToRunAgain].
+"		smallBlank.
+		button: 'Forget' action: [respondToForget]"
+		}.
+)
+headingDefinition ^ <Presenter>  = (
+	^headingBlock: headingContentsDefinition
+	color: (
+		didNoTestsFail 
+			ifFalse: [failureHeadingColor]
+			ifTrue:
+				[successHeadingColor])
+)
+respondToRunAgain = (
+	subject tester cleanUpResults.
+	enterSubject:: TestingInProgressSubject tester: subject tester
+)
+runToDebugFailure: testCase = (
+	subject tester runToDebugFailure: testCase
+)
+runWithNoExceptionHandling: testCase = (
+	subject tester runWithNoExceptionHandling: testCase
+)
+section: label <String> with: testCases <Collection[TestCase]> status: aSymbol <Symbol> color: aColor <Color | Gradient> ^ <Fragment> = (
+	| testedMethodsPresenter |
+	testedMethodsPresenter:: TestResultListPresenter onSubject: (TestResultListSubject onModel: testCases).
+	^column: {
+		headingBlock: (row: {
+			label: (label, ' (', testCases size printString, ')') asText allBold.
+			largeBlank.
+			(link: 'run all' action: [testedMethodsPresenter respondToRunAll]) tinyFont.
+			filler.
+			expandButtonWithAction: [testedMethodsPresenter expandAll].
+			blank: 3.
+			collapseButtonWithAction: [testedMethodsPresenter collapseAll].
+			}
+			)
+			color: aColor.
+		blank: 3.
+		testedMethodsPresenter.
+		}
+)
+section: label <String> withHidden: testCases <Collection[TestCase]> status: aSymbol <Symbol> color: aColor <Color | Gradient> ^ <Fragment> = (
+	| contentHolder testedMethodsPresenter |
+	testedMethodsPresenter:: TestResultListPresenter onSubject: (TestResultListSubject onModel: testCases).
+	contentHolder:: holder: 
+		(row: {
+			blank: 10.
+			testCases isEmpty ifFalse:
+				[(link: 'Show details...' 
+				action: [majorUpdate: [contentHolder content: testedMethodsPresenter]]) tinyFont]
+			}).
+	^column: {
+		headingBlock: (row: {
+			label: (label, ' (', testCases size printString, ')') asText allBold.
+			largeBlank.
+			(link: 'run all' action: 
+				[contentHolder content == testedMethodsPresenter
+					ifTrue: [testedMethodsPresenter respondToRunAll]
+					ifFalse: [respondToRunAll: testCases]
+				]) tinyFont.
+			filler.
+			expandButtonWithAction: 
+				[contentHolder content == testedMethodsPresenter
+					ifTrue: [testedMethodsPresenter expandAll]].
+			blank: 3.
+			collapseButtonWithAction: 
+				[contentHolder content == testedMethodsPresenter
+					ifTrue: [testedMethodsPresenter collapseAll]].
+			}
+			)
+			color: aColor.
+		blank: 3.
+		contentHolder.
+		}
+)
+successHeadingColor = (
+	^Gradient from: (Color h: 120 s: 0.5 v: 0.7) to: (Color h: 120 s: 0.5 v: 0.5)
+)
+successes ^ <Fragment> = (
+	^section: 'Successes'
+		withHidden: subject successes
+		status: #success
+		color: successesSectionColor
+)
+successesSectionColor = (
+	^Gradient from: (Color h: 90 s: 0.3 v: 1) to: (Color h: 90 s: 0.3 v: 0.9)
+))
+class TestingOutcomeSubject tester: tester <Tester> = Subject onModel: tester (|
+|)
+('as yet unclassified'
+createPresenter = (
+	^TestingOutcomePresenter onSubject: self
+)
+errors = (
+	^tester errors
+)
+failures = (
+	^tester failures
+)
+successes = (
+	^tester successes
+)
+tester = (
+	^model
+)
+title = (
+	^'Test Results'
+)) : ('as yet unclassified'
+onModel: m ^ <TestingOutcomeSubject> = (
+	^ tester: m
+)))