The Trunk: System-mt.851.mcz

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

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

Name: System-mt.851
Author: mt
Time: 31 July 2016, 10:00:28.58249 am
UUID: ce5a9701-16c6-a14a-a457-0e4b46aeb2e7
Ancestors: System-mt.850

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

Adds the core theming mechanism

=============== Diff against System-mt.850 ===============

Item was added:
+ ----- Method: ClassDescription>>applyThemeToInstances (in category '*System-Support') -----
+ applyThemeToInstances
+ "User interface themes. Manage how to update existing instances. Classes can override this to use a different update schema than iterating over all instances."
+
+ self allInstancesDo:
+ [ : eachInstance | eachInstance canApplyUserInterfaceTheme ifTrue: [ eachInstance applyUserInterfaceTheme ] ]!

Item was added:
+ ----- Method: ClassDescription>>canApplyThemeToInstances (in category '*System-Support') -----
+ canApplyThemeToInstances
+ "Override this to ignore your instances."
+
+ ^ true!

Item was added:
+ ----- Method: Object class>>themeProperties (in category '*System-Preferences') -----
+ themeProperties
+ "Return a list of triples that describe configurable properties in a theme."
+ ^ {}!

Item was added:
+ ----- Method: Object>>applyUserInterfaceTheme (in category '*System-Preferences') -----
+ applyUserInterfaceTheme
+ "A new UserInterfaceTheme has been asked to #apply itself onto the current desktop.  The receiver should do what is necessary to change its colors on the screen, update its fonts, form images, etc., if the current UserInterfaceTheme specifies overrides for those values.
+
+ Only subclasses which implement new #themeProperties on the class-side should implement this method.
+ Implementors of this method should not call 'super applyUserInterfaceTheme'.
+
+ The default implementation does nothing."!

Item was added:
+ ----- Method: Object>>canApplyUserInterfaceTheme (in category '*System-Preferences') -----
+ canApplyUserInterfaceTheme
+ "Use this hook to control whether you want to get notified if a new theme gets applied."
+
+ ^ true!

Item was added:
+ ----- Method: Object>>userInterfaceTheme (in category '*System-Preferences') -----
+ userInterfaceTheme
+ "Call this to conveniently access properties from the current user interface theme."
+
+ ^ UserInterfaceTheme current
+ pushScope: self;
+ yourself!

Item was added:
+ Object subclass: #UserInterfaceTheme
+ instanceVariableNames: 'scope properties name next'
+ classVariableNames: 'All Current Default'
+ poolDictionaries: ''
+ category: 'System-Support'!
+
+ !UserInterfaceTheme commentStamp: '<historical>' prior: 0!
+ A UserInterfaceTheme is a dictionary of preferred visual-properties; colors, borderStyles, borderWidths, fonts, forms, etc. used to color and style the IDE.
+
+ Accessing The Theme
+ To access the proper UserInterfaceTheme instance for an object, send it #userInterfaceTheme.  The default implementation on Object provides the one instance of that is in-use by the IDE at the current time.
+
+ Customizing The Theme
+ We can ask the userInterfaceTheme for the value of any visual-property, by name:
+
+ mySystemWindow userInterfaceTheme closeBoxImage
+
+ Initially, the above answers nil, which causes the legacy code to use whatever default it's always used.  To override various visual-properties of any kind of object, the #set: onAny: to: message can be used.  For example,
+
+ myUserInterfaceTheme
+ set: #closeBoxImage
+ for: SystemWindow
+ to: MenuIcons smallCancelIcon
+
+ Alternatively, values may be derived based on other values in the theme, as in:
+
+ myUserInterfaceTheme
+ set: #color
+ for: FillInTheBlankMorph
+ to: { MenuMorph->#color.  #twiceDarker }
+
+ Now, the accessing expression, above, will answer will answer MenuIcons' smallCancelIcon instead of nil.  SystemWindow's code can be changed to use the expression above to access elements of the theme.
+
+ Upgrading Legacy Code
+ Following the introduction of this class, various client code all around the system must be modified to access it.  This variety of legacy code uses a variety of methods to specify their visual properties:
+
+ 1) a hard-coded values.
+ 2) a values derived from some other value.
+ 3) providing local storage for a settable value which can be nil.
+ 4) providing local storage for a settable value which is expected to always have a particular valid value (never nil).
+
+ The requirement, for each case, is to let the value be overridden.  
+
+ The solution for each of the above should be handled respectively to the above list, as follows:
+
+ 1) Check the userInterfaceTheme, if that property returns nil, use the legacy hard-coded value.  (see example: SystemWindow>>#createCloseBox).
+ 2) Nothing to do -- simply perform the same derivation on the result of (1).
+ 3) Check the local storage, if present, use it.  If nil, then check the userInterfaceTheme, if it has this property present, use it, else return nil.
+ 4) Check the userInterfaceTheme, if the property is not nil, use it, otherwise use the local value.
+
+ Tool Support
+ If a new access to #userInterfaceTheme is added to the code, be sure to add the property and its description to the #themeSettings for that class.  See implementors of #themeSettings for examples.!

Item was added:
+ ----- Method: UserInterfaceTheme class>>allThemeProperties (in category 'tools') -----
+ allThemeProperties
+ "Answer an Array of 3-element Array's.  Each inner Array are the information needed to present a Theme editor tool; the property name, category, and description.
+
+ self allThemeProperties"
+
+ ^ Array streamContents:
+ [ : stream | self allThemePropertiesDo: [ : cls : prop | stream nextPut: {cls}, prop ]]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>allThemePropertiesDo: (in category 'tools') -----
+ allThemePropertiesDo: block
+ "Iterate over all classes that provide theme properties."
+
+ Smalltalk allClassesDo: [:eachClass |
+ (eachClass respondsTo: #themeProperties) ifTrue: [
+ eachClass themeProperties do: [:eachProperty |
+ block cull: eachClass cull: eachProperty]]].!

Item was added:
+ ----- Method: UserInterfaceTheme class>>allThemes (in category 'accessing') -----
+ allThemes
+ ^ All ifNil: [All := IdentitySet new]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>categories (in category 'tools') -----
+ categories
+ "self categories"
+
+ ^ Set new in: [:result |
+ self allThemePropertiesDo: [:cls :prop | result add: prop second].
+ result]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>clientClasses (in category 'private') -----
+ clientClasses
+
+ ^ Set new in: [:result |
+ self allThemePropertiesDo: [:cls :prop | result add: cls].
+ result]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>clientClassesToReapply (in category 'private') -----
+ clientClassesToReapply
+ "All client classes plus their unique subclasses."
+
+ ^ Set new in: [:result | self clientClasses do: [:cc | cc withAllSubclassesDo: [:sc |
+ result add: sc]]. result]
+ !

Item was added:
+ ----- Method: UserInterfaceTheme class>>current (in category 'accessing') -----
+ current
+
+ ^ Current ifNil: [Current := Default]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>current: (in category 'accessing') -----
+ current: aUserInterfaceTheme
+ "Replace the current system theme with aUserInterfaceTheme."
+ Current := aUserInterfaceTheme
+ "Notify?"!

Item was added:
+ ----- Method: UserInterfaceTheme class>>default (in category 'accessing') -----
+ default
+ ^ Default ifNil: [Default := self new name: 'Autogenerated Default'; yourself]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>default: (in category 'accessing') -----
+ default: aUserInterfaceTheme
+ Default := aUserInterfaceTheme.!

Item was added:
+ ----- Method: UserInterfaceTheme class>>initialize (in category 'initialize-release') -----
+ initialize
+
+ self reset.!

Item was added:
+ ----- Method: UserInterfaceTheme class>>named: (in category 'initialize-release') -----
+ named: aString
+ ^ self allThemes
+ detect: [:ea | ea name = aString]
+ ifNone: [self new name: aString; register]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>propertiesForCategory: (in category 'tools') -----
+ propertiesForCategory: categoryName
+ ^ self allThemeProperties select: [ : each | each third = categoryName ]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>propertiesForClass: (in category 'tools') -----
+ propertiesForClass: aClass
+ ^ self allThemeProperties select: [ : each | each first = aClass ]!

Item was added:
+ ----- Method: UserInterfaceTheme class>>reset (in category 'initialize-release') -----
+ reset
+ self default apply.!

Item was added:
+ ----- Method: UserInterfaceTheme>>apply (in category 'actions') -----
+ apply
+ "Apply this theme to all affected objects. Let classes decide on how to iterate and call their instances."
+
+ UserInterfaceTheme current: self.
+
+ self class clientClassesToReapply in: [:cc |
+ cc do: [:eachClass | eachClass applyUserInterfaceTheme].
+ cc
+ select: [:eachClass | eachClass canApplyThemeToInstances]
+ thenDo: [:eachClass | eachClass applyThemeToInstances]].
+
+ Project current restoreDisplay.!

Item was added:
+ ----- Method: UserInterfaceTheme>>applyTo: (in category 'actions') -----
+ applyTo: someObjects
+ "Apply this theme to the given objects. Useful if you have to re-theme a specific set of objects. Restore the current theme after that."
+
+ UserInterfaceTheme current in: [:priorTheme |
+ [
+ UserInterfaceTheme current: self.
+
+ someObjects
+ select: [:ea | ea canApplyUserInterfaceTheme]
+ thenDo: [:ea | ea applyUserInterfaceTheme].
+
+ Project current restoreDisplay.
+ ] ensure: [UserInterfaceTheme current: priorTheme]].!

Item was added:
+ ----- Method: UserInterfaceTheme>>atomicUpdate: (in category 'private') -----
+ atomicUpdate: aBlock
+ "Like our Preferences >> #atomicUpdatePreference"
+ [
+ | original copy returnValue |
+ original := properties.
+ copy := properties copy.
+ returnValue := aBlock value: copy.
+ original == properties ifTrue: [
+ properties := copy.
+ ^ returnValue]
+ ] repeat!

Item was added:
+ ----- Method: UserInterfaceTheme>>clear: (in category 'building') -----
+ clear: propertySymbol
+
+ ^ self
+ set: propertySymbol
+ to: nil!

Item was added:
+ ----- Method: UserInterfaceTheme>>clear:for: (in category 'building') -----
+ clear: propertySymbol for: aClass
+ "No longer override the default visual property specified by propertySymbol for any kinds of aClass.  Use the default."
+ ^ self
+ set: propertySymbol
+ for: aClass
+ to: nil!

Item was added:
+ ----- Method: UserInterfaceTheme>>derive:for:from: (in category 'building') -----
+ derive: propertySymbol for: aClassOrSymbol from: anotherClassOrSymbol
+
+ ^ self
+ derive: propertySymbol
+ for: aClassOrSymbol
+ from: anotherClassOrSymbol
+ at: propertySymbol
+ !

Item was added:
+ ----- Method: UserInterfaceTheme>>derive:for:from:at: (in category 'building') -----
+ derive: propertySymbol for: aClassOrSymbol from: anotherClassOrSymbol at: anotherPropertySymbol
+ "Derive this property from another property."
+
+ self
+ set: propertySymbol
+ for: aClassOrSymbol
+ to: (MessageSend
+ receiver: self
+ selector: #get:for:
+ arguments: {anotherPropertySymbol. anotherClassOrSymbol}).!

Item was added:
+ ----- Method: UserInterfaceTheme>>derive:for:from:at:do: (in category 'building') -----
+ derive: propertySymbol for: aClassOrSymbol from: anotherClassOrSymbol at: anotherPropertySymbol do: block
+
+ self
+ set: propertySymbol
+ for: aClassOrSymbol
+ to: (MessageSend
+ receiver: self
+ selector: #get:for:do:
+ arguments: {anotherPropertySymbol. anotherClassOrSymbol. block}).!

Item was added:
+ ----- Method: UserInterfaceTheme>>derive:for:from:do: (in category 'building') -----
+ derive: propertySymbol for: aClassOrSymbol from: anotherClassOrSymbol do: block
+
+ ^ self
+ derive: propertySymbol
+ for: aClassOrSymbol
+ from: anotherClassOrSymbol
+ at: propertySymbol
+ do: block!

Item was added:
+ ----- Method: UserInterfaceTheme>>doesNotUnderstand: (in category 'lookup') -----
+ doesNotUnderstand: aMessage
+ "Answer whether I have, or inherit, a value for the visual-attribute specified by aMessage's #selector."
+
+ aMessage numArgs > 0 ifTrue: [^ super doesNotUnderstand: aMessage].
+ scope isEmpty ifTrue: [^ super doesNotUnderstand: aMessage].
+
+ ^ [self get: scope top class -> aMessage selector]
+ ensure: [scope pop]!

Item was added:
+ ----- Method: UserInterfaceTheme>>get: (in category 'private') -----
+ get: keyObject
+ "keyObject is intended to be an Association. We have two lookup strategies: 1) along the superclass chain, 2) via a linke theme. Evaluate the result because there can be message sends stored or blocks."
+
+ | k |
+ properties
+ at: keyObject
+ ifPresent: [:prop | ^ prop value].
+
+ keyObject isVariableBinding "simple key objects"
+ ifFalse: [^ self getViaLink: keyObject].
+
+ k := keyObject key.
+ (self getViaSuperclasses: keyObject)
+ ifNotNil: [:prop | ^ prop].
+
+ keyObject key: k. "restore"
+ ^ self getViaLink: keyObject!

Item was added:
+ ----- Method: UserInterfaceTheme>>get:for: (in category 'private') -----
+ get: propertySymbol for: scope
+ "For convenience. Does support access to non-class keys."
+
+ | aClass |
+ aClass := (scope isNil or: [scope isBehavior])
+ ifTrue: [scope]
+ ifFalse: [Smalltalk classNamed: scope].
+
+ aClass ifNotNil: [^ self get: aClass -> propertySymbol].
+
+ properties
+ at: scope -> propertySymbol
+ ifPresent: [:prop | ^ prop value].
+
+ ^ self getViaLink: scope -> propertySymbol!

Item was added:
+ ----- Method: UserInterfaceTheme>>get:for:do: (in category 'private') -----
+ get: propertySymbol for: scope do: block
+
+ ^ block cull: (self get: propertySymbol for: scope)!

Item was added:
+ ----- Method: UserInterfaceTheme>>getViaLink: (in category 'private') -----
+ getViaLink: keyObject
+ "keyObject is intended to be an Association"
+
+ ^ next ifNotNil: [next get: keyObject]!

Item was added:
+ ----- Method: UserInterfaceTheme>>getViaSuperclasses: (in category 'private') -----
+ getViaSuperclasses: keyObject
+ "keyObject is intended to be an Association"
+
+ "We know we're the only referencer of keyObject.  Update it rather than create new ones, for performance reasons."
+ keyObject key: keyObject key superclass.
+
+ keyObject key ifNil: [^ nil].
+
+ properties
+ at: keyObject
+ ifPresent: [:prop | ^ prop value].
+
+ ^ self getViaSuperclasses: keyObject!

Item was added:
+ ----- Method: UserInterfaceTheme>>initialize (in category 'initialization') -----
+ initialize
+ super initialize.
+ name := 'unnamed'.
+ properties := Dictionary new.
+ scope := Stack new!

Item was added:
+ ----- Method: UserInterfaceTheme>>link: (in category 'building') -----
+ link: aUserInterfaceTheme
+ "When accessing properties by name, if a property is not specified in the receiver, give aUserInterfaceTheme a chance to provide it."
+ next := aUserInterfaceTheme!

Item was added:
+ ----- Method: UserInterfaceTheme>>merge: (in category 'building') -----
+ merge: aUserInterfaceTheme
+ "Merge aUserInterfaceTheme into my properties.  Same as #link:, except merges all the properties of aUserInterfaceTheme into the  receiver"
+ self
+ merge: aUserInterfaceTheme
+ overwrite: false!

Item was added:
+ ----- Method: UserInterfaceTheme>>merge:overwrite: (in category 'building') -----
+ merge: aUserInterfaceTheme overwrite: aBoolean
+ "Merge aUserInterfaceTheme into my properties. Only overwrite properties if it sais so."
+
+ self
+ validateCanMerge: aUserInterfaceTheme ;
+ preMerge: aUserInterfaceTheme.
+
+ self atomicUpdate: [:props |
+ aUserInterfaceTheme properties keysAndValuesDo: [:key :value |
+ (aBoolean or: [(props includesKey: key) not])
+ ifTrue: [ | mergedValue |
+ mergedValue := value copy.
+ "Update receiver when deriving properties."
+ mergedValue isMessageSend ifTrue: [mergedValue receiver: self].
+ props at: key put: mergedValue.
+ ]]].!

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

Item was added:
+ ----- Method: UserInterfaceTheme>>name: (in category 'accessing') -----
+ name: aString
+ name := aString!

Item was added:
+ ----- Method: UserInterfaceTheme>>next (in category 'accessing') -----
+ next
+ "The next theme to look for properties when I don't contain a particular property."
+ ^ next!

Item was added:
+ ----- Method: UserInterfaceTheme>>postCopy (in category 'copying') -----
+ postCopy
+ "Keep same name and linked next."
+ super postCopy.
+ properties := properties copy.
+ scope := nil!

Item was added:
+ ----- Method: UserInterfaceTheme>>preMerge: (in category 'private') -----
+ preMerge: aUserInterfaceTheme
+ name := name , ' + ' , aUserInterfaceTheme name.
+ next ifNil: [ next := aUserInterfaceTheme next ]!

Item was added:
+ ----- Method: UserInterfaceTheme>>printOn: (in category 'printing') -----
+ printOn: aStream
+ super printOn: aStream.
+ aStream space; print: name!

Item was added:
+ ----- Method: UserInterfaceTheme>>properties (in category 'private') -----
+ properties
+ ^ properties!

Item was added:
+ ----- Method: UserInterfaceTheme>>pushScope: (in category 'private') -----
+ pushScope: anObject
+ scope push: anObject!

Item was added:
+ ----- Method: UserInterfaceTheme>>register (in category 'initialization') -----
+ register
+ self class allThemes add: self.!

Item was added:
+ ----- Method: UserInterfaceTheme>>set:for:to: (in category 'building') -----
+ set: propertySymbol for: aClassOrSymbol to: valueObject
+ "Where aClass asks its userInterfaceTheme for propertySymbol, provide valueObject."
+
+ | aClass |
+ aClass := aClassOrSymbol isBehavior ifTrue: [aClassOrSymbol] ifFalse: [Smalltalk classNamed: aClassOrSymbol].
+ aClass ifNil: [^ self].
+ ^ self atomicUpdate:
+ [ : props | | key |
+ key := aClass -> propertySymbol.
+ valueObject
+ ifNil:
+ [ props
+ removeKey: key
+ ifAbsent: [ "already cleared, don't error" ] ]
+ ifNotNil:
+ [ props
+ at: key
+ put: valueObject ] ]!

Item was added:
+ ----- Method: UserInterfaceTheme>>set:to: (in category 'building') -----
+ set: propertySymbol to: valueObject
+ "For convenience."
+
+ ^ self atomicUpdate:
+ [ : props |
+ valueObject
+ ifNil:
+ [ props
+ removeKey: propertySymbol
+ ifAbsent: [ "already cleared, don't error" ] ]
+ ifNotNil:
+ [ props
+ at: propertySymbol
+ put: valueObject ] ]!

Item was added:
+ ----- Method: UserInterfaceTheme>>unregister (in category 'initialization') -----
+ unregister
+ self class allThemes remove: self ifAbsent: [].!

Item was added:
+ ----- Method: UserInterfaceTheme>>unsetProperties (in category 'accessing') -----
+ unsetProperties
+ "Answer the property keys which are unset."!

Item was added:
+ ----- Method: UserInterfaceTheme>>validateCanMerge: (in category 'private') -----
+ validateCanMerge: aUserInterfaceTheme
+ (next notNil and:
+ [ aUserInterfaceTheme next notNil and: [ next ~= aUserInterfaceTheme next ] ]) ifTrue: [ self error: 'Links to different themes.  Cannot merge.' ]!