The Trunk: Tests-mt.347.mcz

Marcel Taeumel uploaded a new version of Tests to project The Trunk:
http://source.squeak.org/trunk/Tests-mt.347.mcz

==================== Summary ====================

Name: Tests-mt.347
Author: mt
Time: 31 July 2016, 10:03:21.36749 am
UUID: 390a9533-4e83-fb43-bee0-c05731033988
Ancestors: Tests-pre.346

*** Widget Refactorings and UI Themes (Part 1 of 11) ***

Tests for the theming mechanism. And a benchmark.

=============== Diff against Tests-pre.346 ===============

Item was added:
+ TestCase subclass: #UserInterfaceThemeTest
+ instanceVariableNames: 'theme previous'
+ classVariableNames: ''
+ poolDictionaries: ''
+ category: 'Tests-System-Preferences'!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>setUp (in category 'running') -----
+ setUp
+
+ super setUp.
+ previous := UserInterfaceTheme current.
+ theme := UserInterfaceTheme new name: 'ui theme test'.!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>tearDown (in category 'running') -----
+ tearDown
+
+ previous
+ ifNil: [UserInterfaceTheme reset]
+ ifNotNil: [UserInterfaceTheme current == previous
+ ifFalse: [previous apply]].
+
+ super tearDown.!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test01ImplementationHooks (in category 'tests') -----
+ test01ImplementationHooks
+ "Any class which implements themeProperties must implement #applyUserInterfaceTheme on the instance side."
+
+ | problematicClasses |
+ problematicClasses := OrderedCollection new.
+ Smalltalk allClassesDo: [ : each | ((each theMetaClass includesSelector: #themeProperties) not
+ or: [each theNonMetaClass includesSelector: #applyUserInterfaceTheme])
+ ifFalse: [problematicClasses add: each]].
+ self assert: problematicClasses isEmpty description: ('UI Theme Violations: {1}' format: {(problematicClasses collect: [:ea | ea name]) joinSeparatedBy: ' '})!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test02SetProperty (in category 'tests') -----
+ test02SetProperty
+
+ | m |
+ m := UserInterfaceThemeTestObject new.
+
+ theme set: #testColor for: UserInterfaceThemeTestObject to: Color white.
+ self assert: m testColor isNil.
+
+ theme apply.
+ self assert: Color white equals: m testColor.
+ !

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test03RegisterAndName (in category 'tests') -----
+ test03RegisterAndName
+
+ self deny: (UserInterfaceTheme allThemes includes: theme).
+ theme register.
+ self assert: (UserInterfaceTheme allThemes includes: theme).
+ theme unregister.
+ self deny: (UserInterfaceTheme allThemes includes: theme).
+
+ theme name: 'test03'.
+ theme register.
+ self assert: theme == (UserInterfaceTheme named: 'test03').
+ theme unregister.
+
+ self assert: theme ~~ (UserInterfaceTheme named: 'testXX').
+ self assert:  (UserInterfaceTheme named: 'testXX') == (UserInterfaceTheme named: 'testXX').
+ (UserInterfaceTheme named: 'testXX') unregister.
+ self deny: (UserInterfaceTheme allThemes anySatisfy: [:ea | ea name = 'testXX']).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test04SuperClassLookup (in category 'tests') -----
+ test04SuperClassLookup
+
+ | m |
+ m := UserInterfaceThemeTestObject new.
+
+ theme set: #testColor for: Object to: Color white.
+ self assert: m testColor isNil.
+
+ theme apply.
+ self assert: Color white equals: m testColor.
+ !

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test05ClearProperty (in category 'tests') -----
+ test05ClearProperty
+
+ | m |
+ m := UserInterfaceThemeTestObject new.
+ theme set: #testColor for: UserInterfaceThemeTestObject to: Color white.
+ theme apply.
+
+ self assert: Color white equals: m testColor.
+ theme clear: #testColor for: UserInterfaceThemeTestObject.
+ self assert: Color white equals: m testColor.
+ theme apply.
+
+ self assert: m testColor isNil.
+ !

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test06SetAndClearUnkownProperty (in category 'tests') -----
+ test06SetAndClearUnkownProperty
+ "Unknown means not defined in #themeProperties und used in code such as #applyUserInterfaceTheme."
+
+ | m |
+ m := UserInterfaceThemeTestObject new.
+ theme set: #unknownProperty for: UserInterfaceThemeTestObject to: #blubb.
+ theme apply.
+
+ self assert:#blubb equals: m unknownProperty.
+ theme clear: #unknownProperty for: UserInterfaceThemeTestObject.
+ self assert:#blubb equals: m unknownProperty.
+ theme apply.
+
+ self assert: m unknownProperty isNil.
+ !

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test07Merge (in category 'tests') -----
+ test07Merge
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+ anotherTheme set: #someColor for: Morph to: Color red.
+ anotherTheme set: #thirdColor for: Morph to: Color blue.
+
+ theme set: #myColor for: Morph to: Color white.
+ theme set: #thirdColor for: Morph to: Color yellow.
+
+ self assert: (theme get: #someColor for: Morph) isNil.
+ self assert: (anotherTheme get: #myColor for: Morph) isNil.
+
+ theme merge: anotherTheme.
+
+ self assert: Color red equals: (theme get: #someColor for: Morph).
+ self assert: (anotherTheme get: #myColor for: Morph) isNil.
+
+ "No overwrite."
+ self assert: Color yellow equals: (theme get: #thirdColor for: Morph).
+ self assert: Color blue equals: (anotherTheme get: #thirdColor for: Morph).
+ !

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test08MergeAndOverwrite (in category 'tests') -----
+ test08MergeAndOverwrite
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+ anotherTheme set: #thirdColor for: Morph to: Color blue.
+ theme set: #thirdColor for: Morph to: Color yellow.
+
+ self assert: Color yellow equals: (theme get: #thirdColor for: Morph).
+ self assert: Color blue equals: (anotherTheme get: #thirdColor for: Morph).
+
+ theme merge: anotherTheme overwrite: true.
+
+ self assert: Color blue equals: (theme get: #thirdColor for: Morph).
+ self assert: Color blue equals: (anotherTheme get: #thirdColor for: Morph).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test09Link (in category 'tests') -----
+ test09Link
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+
+ anotherTheme set: #testColor for: Object to: Color white.
+ self assert: (theme get: #testColor for: Object) isNil.
+
+ theme link: anotherTheme.
+ self assert: theme next == anotherTheme.
+ self assert: Color white equals: (theme get: #testColor for: Object).
+ !

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test10Blocks (in category 'tests') -----
+ test10Blocks
+
+ theme set: #testColor for: Object to: [Color r: 1 g: 1 b: 1].
+ self assert: (theme get: #testColor for: Object) ~~ (theme get: #testColor for: Object).
+
+ !

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test11LinkAgain (in category 'tests') -----
+ test11LinkAgain
+
+ | anotherTheme yetAnotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+ yetAnotherTheme := UserInterfaceTheme new.
+
+ yetAnotherTheme set: #testColor for: Object to: Color white.
+ self assert: (theme get: #testColor for: Object) isNil.
+
+ theme link: anotherTheme.
+ anotherTheme link: yetAnotherTheme.
+
+ self assert: Color white equals: (theme get: #testColor for: Object).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test12RealDNU (in category 'tests') -----
+ test12RealDNU
+ "If we forgot to push a scope, it is a real DNU and not stack is empty."
+ self should: [theme perform: #undefinedMessage] raise: MessageNotUnderstood!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test13ClassName (in category 'tests') -----
+ test13ClassName
+
+ self assert: (theme get: #testColor for: #Object) isNil.
+
+ theme set: #testColor for: #Object to: Color white.
+ self assert: Color white equals: (theme get: #testColor for: #Object).
+
+ theme clear: #testColor for: #Object.
+ self assert: (theme get: #testColor for: #Object) isNil.
+
+ self shouldnt: [theme set: #testColor for: #SomeNonExistentClass to: Color white] raise: Error.
+ self assert: (theme get: #testColor for: nil) isNil.!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test14Perform (in category 'tests') -----
+ test14Perform
+
+ | m |
+ m := UserInterfaceThemeTestObject new.
+ theme apply.
+
+ self assert: m getTestColor isNil.
+ self assert: m getTestColorViaPerform isNil.
+
+ theme set: #testColor for: #UserInterfaceThemeTestObject to: Color white.
+
+ self assert: Color white equals: m getTestColor.
+ self assert: Color white equals: m getTestColorViaPerform.!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test15DerivedProperties (in category 'tests') -----
+ test15DerivedProperties
+
+ theme set: #fanciness for: Point to: 42.
+ theme derive: #fanciness for: Rectangle from: Point at: #fanciness.
+
+ self assert: 42 equals: (theme get: #fanciness for: Point).
+ self assert: 42 equals: (theme get: #fanciness for: Rectangle).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test16ArraysAsProperties (in category 'tests') -----
+ test16ArraysAsProperties
+ "Used, for example, by Shout styling. There might be many reasons for storing arrays as properties."
+
+ theme set: #complexSpec for: UserInterfaceThemeTestObject to: {#foo. 42. #(a b c)}.
+
+ self assert: {#foo. 42. #(a b c)} equals: (theme get: #complexSpec for: UserInterfaceThemeTestObject).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test17DerivedPropertiesWithBlock (in category 'tests') -----
+ test17DerivedPropertiesWithBlock
+
+ theme set: #fanciness for: Point to: 42.
+ theme derive: #fanciness for: Rectangle from: Point at: #fanciness do: [:f | f + 1].
+
+ self assert: 42 equals: (theme get: #fanciness for: Point).
+ self assert: 43 equals: (theme get: #fanciness for: Rectangle).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test18MergeWithDerivedProperties (in category 'tests') -----
+ test18MergeWithDerivedProperties
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+
+ theme set: #fanciness for: Point to: 42.
+ theme derive: #fanciness for: Rectangle from: Point at: #fanciness do: [:f | f + 1].
+
+ anotherTheme merge: theme.
+ theme set: #fanciness for: Point to: 21.
+
+ self assert: 22 equals: (theme get: #fanciness for: Rectangle).
+ self assert: 43 equals: (anotherTheme get: #fanciness for: Rectangle).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test19MergeWithCopy (in category 'tests') -----
+ test19MergeWithCopy
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+
+ theme set: #someColor for: Object to: Color red.
+ anotherTheme merge: theme.
+
+ self assert: (theme get: #someColor for: Object) ~~ (anotherTheme get: #someColor for: Object).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test20ClassSideApply (in category 'tests') -----
+ test20ClassSideApply
+
+ UserInterfaceThemeTestObject resetApplyCounter.
+ self assert: 0 equals: UserInterfaceThemeTestObject applyCounter.
+ theme apply.
+ self assert: 1 equals: UserInterfaceThemeTestObject applyCounter.
+ !

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test21BlocksNoDuplicateEvaluation (in category 'tests') -----
+ test21BlocksNoDuplicateEvaluation
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+ anotherTheme set: #modifier for: Object to: [ [:color | color darker] ].
+
+ theme link: anotherTheme.
+ self shouldnt: [theme get: #modifier for: Color] raise: Error.
+ self assert: Color yellow darker equals: ((theme get: #modifier for: Color) value: Color yellow).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test22SetAndClearConveniently (in category 'tests') -----
+ test22SetAndClearConveniently
+
+ self assert: (theme get: #foo22) isNil.
+ theme set: #foo22 to: 22.
+ self assert: 22 equals: (theme get: #foo22).
+ theme clear: #foo22.
+ self assert: (theme get: #foo22) isNil.!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test23LookUpReset (in category 'tests') -----
+ test23LookUpReset
+ "When nothing is found in the super-class hierarchy, try linked themes. However, start at with the original class again."
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+
+
+ theme set: #fanciness for: Object to: 42.
+ theme set: #fanciness for: Point to: 43.
+
+ anotherTheme link: theme.
+
+ self assert: 43 equals: (theme get: #fanciness for: Point).
+ self assert: 43 equals: (anotherTheme get: #fanciness for: Point).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test24GetSimplePropertiesViaLink (in category 'tests') -----
+ test24GetSimplePropertiesViaLink
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+
+ theme set: #fanciness to: 42.
+ anotherTheme link: theme.
+
+ self assert: 42 equals: (anotherTheme get: #fanciness).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test25DerivedPropertiesViaLink (in category 'tests') -----
+ test25DerivedPropertiesViaLink
+ "It is not (yet?) possible to reset the look-up for derived properties. You should merge themes if you need it."
+
+ | anotherTheme |
+ anotherTheme := UserInterfaceTheme new.
+
+ theme set: #fanciness for: Point to: 42.
+ theme derive: #fanciness for: Rectangle from: Point at: #fanciness do: [:f | f + 1].
+
+ anotherTheme set: #fanciness for: Point to: 21.
+ anotherTheme link: theme.
+
+ self assert: 43 equals: (theme get: #fanciness for: Rectangle).
+ "self assert: 22 equals: (anotherTheme get: #fanciness for: Rectangle)."
+ self assert: 43 equals: (anotherTheme get: #fanciness for: Rectangle).!

Item was added:
+ ----- Method: UserInterfaceThemeTest>>test26ApplyTo (in category 'tests') -----
+ test26ApplyTo
+
+ | m |
+ m := UserInterfaceThemeTestObject new.
+
+ theme set: #testColor for: UserInterfaceThemeTestObject to: Color white.
+ self assert: m testColor isNil.
+
+ theme applyTo: {m}.
+ self assert: Color white equals: m testColor.
+ !

Item was added:
+ Object subclass: #UserInterfaceThemeTestObject
+ instanceVariableNames: 'testColor unknownProperty'
+ classVariableNames: 'ApplyCounter'
+ poolDictionaries: ''
+ category: 'Tests-System-Preferences'!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject class>>applyCounter (in category 'as yet unclassified') -----
+ applyCounter
+ ^ ApplyCounter!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject class>>applyUserInterfaceTheme (in category 'as yet unclassified') -----
+ applyUserInterfaceTheme
+ ApplyCounter := (ApplyCounter ifNil: [0]) + 1.!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject class>>benchLookup (in category 'benchmark') -----
+ benchLookup
+ "
+ Microsoft Surface Pro 3, Windows 10 v1511, CogVM r201606301459, Squeak 5.1alpha #16138
+   '210,000 per second. 4.76 microseconds per run.' -- leaves enough room for quirky morphs that keep on drawing themselves based on direct theme lookup.
+
+ I think this setup is really heavy. Morphs should not look-up things that often. They can cache. Anyway:
+ - link through 3 themes
+ - look up superclasses up to ProtoObject (for each theme!!)
+
+ self benchLookup"
+
+ | c t1 t2 t3 m result |
+ c := UserInterfaceTheme current.
+ m := UserInterfaceThemeTestObject new.
+ t1 := UserInterfaceTheme new name: #benchmarkOne.
+ t2 := UserInterfaceTheme new name: #benchmarkTwo.
+ t3 := UserInterfaceTheme new name: #benchmarkThree.
+
+ t3 set: #testColor for: ProtoObject to: Color white.
+ t1 link: t2.
+ t2 link: t3.
+
+ t1 apply.
+
+ result := OrderedCollection new.
+
+ [
+ 3 timesRepeat: [result add: [m getTestColor] bench].
+ ] ensure: [c apply].
+
+ result explore.!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject class>>resetApplyCounter (in category 'as yet unclassified') -----
+ resetApplyCounter
+ ApplyCounter := 0.!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject class>>themeProperties (in category 'preferences') -----
+ themeProperties
+
+ ^ super themeProperties, {
+ {#testColor. 'test'. 'Some test property'}
+ }!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject>>applyUserInterfaceTheme (in category 'updating') -----
+ applyUserInterfaceTheme
+
+ self testColor: self userInterfaceTheme testColor.
+ self unknownProperty: self userInterfaceTheme unknownProperty.!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject>>canApplyUserInterfaceTheme (in category 'visual properties') -----
+ canApplyUserInterfaceTheme
+ ^ true!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject>>getTestColor (in category 'updating') -----
+ getTestColor
+
+ ^ self userInterfaceTheme testColor!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject>>getTestColorViaPerform (in category 'updating') -----
+ getTestColorViaPerform
+
+ ^ self userInterfaceTheme perform: #testColor!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject>>testColor (in category 'accessing') -----
+ testColor
+
+ ^ testColor!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject>>testColor: (in category 'accessing') -----
+ testColor: anObject
+
+ testColor := anObject!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject>>unknownProperty (in category 'accessing') -----
+ unknownProperty
+
+ ^ unknownProperty!

Item was added:
+ ----- Method: UserInterfaceThemeTestObject>>unknownProperty: (in category 'accessing') -----
+ unknownProperty: anObject
+
+ unknownProperty := anObject!