diff --git a/src/Spec2-Adapters-Morphic/SpMorphicSliderAdapter.class.st b/src/Spec2-Adapters-Morphic/SpMorphicSliderAdapter.class.st index 089d6587..8c370ba8 100644 --- a/src/Spec2-Adapters-Morphic/SpMorphicSliderAdapter.class.st +++ b/src/Spec2-Adapters-Morphic/SpMorphicSliderAdapter.class.st @@ -9,90 +9,80 @@ Class { #tag : 'Base' } -{ #category : 'widget API' } -SpMorphicSliderAdapter >> absoluteValue [ - - ^ self presenter absoluteValue -] - -{ #category : 'widget API' } -SpMorphicSliderAdapter >> absoluteValue: aFloat [ - - ^ self presenter absoluteValue: aFloat -] - { #category : 'factory' } SpMorphicSliderAdapter >> buildWidget [ - | preWidget | - preWidget := PluggableSliderMorph new - model: self; - getValueSelector: #value; - setValueSelector: #value:; - value: self absoluteValue; - getLabelSelector: #label; - max: self max; - min: self min; - quantum: self quantum; - setBalloonText: self help; - vResizing: #spaceFill; - hResizing: #spaceFill; - yourself. - self presenter isHorizontal ifFalse: [ - preWidget := TransformationMorph new asFlexOf: preWidget. - preWidget transform withAngle: 90 degreesToRadians negated ]. - - self presenter whenMinChangedDo: [ :newValue | - preWidget min: newValue ]. - self presenter whenMaxChangedDo: [ :newValue | - preWidget max: newValue ]. - self presenter whenQuantumChangedDo: [ :newValue | - preWidget quantum: newValue ]. - self presenter whenValueChangedDo: [ :newValue | - preWidget value: newValue ]. - - ^ preWidget + | aSliderMorph | + aSliderMorph := + (PluggableSliderMorph + on: self + getValue: #presenterValue + setValue: #presenterValue: + min: self presenter min + max: self presenter max + quantum: self presenter quantum) + getLabelSelector: #presenterLabel; + setBalloonText: self help; + vResizing: #spaceFill; + hResizing: #spaceFill; + yourself. + + self presenter whenMinChangedDo: [ :newValue | + aSliderMorph min: newValue ]. + self presenter whenMaxChangedDo: [ :newValue | + aSliderMorph max: newValue ]. + self presenter whenQuantumChangedDo: [ :newValue | + aSliderMorph quantum: newValue ]. + self presenter whenLabelChangedDo: [ :newLabel | + aSliderMorph label: newLabel ]. + self presenter whenAbsoluteValueChangedDo: [ :newValue | + aSliderMorph setValue: newValue ]. + + ^ aSliderMorph ] -{ #category : 'widget API' } -SpMorphicSliderAdapter >> label [ - +{ #category : 'accessing' } +SpMorphicSliderAdapter >> presenterLabel [ + ^ self presenter label ] -{ #category : 'widget API' } -SpMorphicSliderAdapter >> max [ +{ #category : 'accessing' } +SpMorphicSliderAdapter >> presenterValue [ - ^ self presenter max + ^ self presenter value ] -{ #category : 'widget API' } -SpMorphicSliderAdapter >> min [ +{ #category : 'accessing' } +SpMorphicSliderAdapter >> presenterValue: aValue [ - ^ self presenter min + self presenter value: aValue ] -{ #category : 'widget API' } -SpMorphicSliderAdapter >> quantum [ +{ #category : 'debug' } +SpMorphicSliderAdapter >> widgetAbsoluteValue [ - ^ self model quantum + ^ widget value asFloat ] -{ #category : 'widget API' } -SpMorphicSliderAdapter >> value [ - ^ self presenter value +{ #category : 'debug' } +SpMorphicSliderAdapter >> widgetLabel [ + + ^ widget label ] -{ #category : 'widget API' } -SpMorphicSliderAdapter >> value: aValue [ +{ #category : 'debug' } +SpMorphicSliderAdapter >> widgetValue [ + + ^ widget scaledValue +] - | value | - value := aValue isNumber - ifTrue: [ aValue ] - ifFalse: [ - (aValue includes: $/) - ifTrue: [ (NumberParser on: aValue) nextFraction ] - ifFalse: [ aValue asNumber ] ]. +{ #category : 'debug' } +SpMorphicSliderAdapter >> widgetValue: aNumber [ + "Emulate a change in the widget value, as if there was a scroll. + Note: We intentionally use #setValue: instead of #value: due to a bug in + the widget, that doesn't perform the setValue selector with the new value + when using #value:, and we need it." - ^ self presenter value: value asFloat + widget setValue: (self presenter valueToAbsoluteValue: aNumber) ] diff --git a/src/Spec2-Backend-Tests/SpBoxLayoutAdapterTest.class.st b/src/Spec2-Backend-Tests/SpBoxLayoutAdapterTest.class.st index f83fefe2..521bcfd6 100644 --- a/src/Spec2-Backend-Tests/SpBoxLayoutAdapterTest.class.st +++ b/src/Spec2-Backend-Tests/SpBoxLayoutAdapterTest.class.st @@ -89,42 +89,3 @@ SpBoxLayoutAdapterTest >> testReplaceElementAfterOpen [ replacement adapter widget. p2 adapter widget } ] - -{ #category : 'tests' } -SpBoxLayoutAdapterTest >> testReplaceElementAppliesStyle [ - | p1 toReplace p2 replacement | - - layout add: (p1 := SpLabelPresenter new). - layout add: (toReplace := SpLabelPresenter new). - layout add: (p2 := SpLabelPresenter new). - self openInstance. - - replacement := SpLabelPresenter new. - replacement addStyle: 'code'. "code assigns code fonts" - layout replace: toReplace with: replacement. - - self assert: self adapter children size equals: 3. - self - assert: replacement adapter widget font - equals: StandardFonts codeFont -] - -{ #category : 'tests' } -SpBoxLayoutAdapterTest >> testReplaceElementBeforeOpenAppliesStyle [ - | p1 toReplace p2 replacement | - - layout add: (p1 := SpLabelPresenter new). - layout add: (toReplace := SpLabelPresenter new). - layout add: (p2 := SpLabelPresenter new). - - replacement := SpLabelPresenter new. - replacement addStyle: 'code'. "code assigns code fonts" - layout replace: toReplace with: replacement. - - self openInstance. - - self assert: self adapter children size equals: 3. - self - assert: replacement adapter widget font - equals: StandardFonts codeFont -] diff --git a/src/Spec2-Backend-Tests/SpSliderAdapterTest.class.st b/src/Spec2-Backend-Tests/SpSliderAdapterTest.class.st new file mode 100644 index 00000000..a3ca0484 --- /dev/null +++ b/src/Spec2-Backend-Tests/SpSliderAdapterTest.class.st @@ -0,0 +1,175 @@ +Class { + #name : 'SpSliderAdapterTest', + #superclass : 'SpAbstractWidgetAdapterTest', + #category : 'Spec2-Backend-Tests-Base', + #package : 'Spec2-Backend-Tests', + #tag : 'Base' +} + +{ #category : 'accessing' } +SpSliderAdapterTest >> classToTest [ + ^ SpSliderPresenter +] + +{ #category : 'tests' } +SpSliderAdapterTest >> testChangeInLabelUpdatesWidget [ + + self + assert: self adapter widgetLabel + closeTo: ''. + + presenter label: 'test'. + + self + assert: self adapter widgetLabel + equals: 'test' +] + +{ #category : 'tests' } +SpSliderAdapterTest >> testChangeInMaxUpdatesWidget [ + + presenter value: 80. + + "Default max is 100" + self + assert: self adapter widgetAbsoluteValue + closeTo: 0.8. + self + assert: self adapter widgetValue + equals: 80. + + "Changing max updates the slider value" + presenter max: 1000. + self + assert: self adapter widgetAbsoluteValue + closeTo: 0.8. + self + assert: self adapter widgetValue + equals: 800 +] + +{ #category : 'tests' } +SpSliderAdapterTest >> testChangeInMinUpdatesWidget [ + + presenter value: 80. + + "Default min is 0" + self + assert: self adapter widgetAbsoluteValue + closeTo: 0.8. + self + assert: self adapter widgetValue + equals: 80. + + "Changing min updates the slider value" + presenter min: 50. + self + assert: self adapter widgetAbsoluteValue + closeTo: 0.8. + self + assert: self adapter widgetValue + equals: 90 +] + +{ #category : 'tests' } +SpSliderAdapterTest >> testChangeInQuantumUpdatesWidget [ + + presenter + min: -50; + max: 150. + + "By default, quantum is 1, which means round Floats to Integer" + presenter value: 49.1. + self assert: self adapter widgetValue closeTo: 49. + + presenter value: -49.1. + self assert: self adapter widgetValue closeTo: -49. + + "Quantum is disabled when nil is set" + presenter quantum: nil. + + presenter value: 49.1. + self assert: self adapter widgetValue closeTo: 49.1. + + presenter value: -49.1. + self assert: self adapter widgetValue closeTo: -49.1. + + "Set 50 as quantum" + presenter quantum: 10. + + "Current value is automatically rounded acording to the new quamtum" + self assert: self adapter widgetValue equals: -50. + + "It also works with new values" + presenter value: 49. + self assert: self adapter widgetValue equals: 50 +] + +{ #category : 'tests' } +SpSliderAdapterTest >> testChangeInValueUpdatesWidget [ + + presenter + min: -50; + max: 150. + + presenter value: 50. + self assert: self adapter widgetValue equals: 50. + + presenter value: -50. + self assert: self adapter widgetValue equals: -50 +] + +{ #category : 'tests' } +SpSliderAdapterTest >> testPresenterUpdatesWidget [ + + presenter + min: -50; + max: 150. + + presenter value: 50. + self assert: self adapter widgetValue equals: 50. + + presenter value: -50. + self assert: self adapter widgetValue equals: -50. + + "By default, quantum is 1, which means round Floats to Integer" + presenter value: 49.1. + self assert: self adapter widgetValue closeTo: 49. + + presenter value: -49.1. + self assert: self adapter widgetValue closeTo: -49. + + "Quantum is disabled when nil is set" + presenter quantum: nil. + + presenter value: 49.1. + self assert: self adapter widgetValue closeTo: 49.1. + + presenter value: -49.1. + self assert: self adapter widgetValue closeTo: -49.1. + + "Set 50 as quantum" + presenter quantum: 10. + + "Current value is automatically rounded acording to the new quamtum" + self assert: self adapter widgetValue equals: -50. + + "It also works with new values" + presenter value: 49. + self assert: self adapter widgetValue equals: 50 +] + +{ #category : 'tests' } +SpSliderAdapterTest >> testWidgetUpdatesPresenter [ + + presenter + min: -50; + max: 150; + quantum: 10. + + "Emulate a change on the widget" + self adapter widgetValue: 54. + + self assert: presenter value equals: 50. + self assert: presenter absoluteValue equals: 0.5 +] diff --git a/src/Spec2-Backend-Tests/SpSliderPresenterBackendTest.class.st b/src/Spec2-Backend-Tests/SpSliderPresenterBackendTest.class.st deleted file mode 100644 index e6cefd05..00000000 --- a/src/Spec2-Backend-Tests/SpSliderPresenterBackendTest.class.st +++ /dev/null @@ -1,32 +0,0 @@ -Class { - #name : 'SpSliderPresenterBackendTest', - #superclass : 'SpAbstractWidgetAdapterTest', - #category : 'Spec2-Backend-Tests-Base', - #package : 'Spec2-Backend-Tests', - #tag : 'Base' -} - -{ #category : 'accessing' } -SpSliderPresenterBackendTest >> classToTest [ - ^ SpSliderPresenter -] - -{ #category : 'initialization' } -SpSliderPresenterBackendTest >> initializeTestedInstance [ - presenter - min: 1; - max: 100; - quantum: 1; - value: 20 -] - -{ #category : 'tests' } -SpSliderPresenterBackendTest >> testSmokeHorizontalTest [ - self presenter beHorizontal. -] - -{ #category : 'tests' } -SpSliderPresenterBackendTest >> testSmokeVerticalTest [ - self presenter beVertical. - -] diff --git a/src/Spec2-Core/SpSliderPresenter.class.st b/src/Spec2-Core/SpSliderPresenter.class.st index 65e022ca..3044caf6 100644 --- a/src/Spec2-Core/SpSliderPresenter.class.st +++ b/src/Spec2-Core/SpSliderPresenter.class.st @@ -73,13 +73,6 @@ SpSliderPresenter >> beVertical [ isHorizontal := false ] -{ #category : 'api' } -SpSliderPresenter >> color: aColor [ - - "Hack because during the interpretation, the state is slightly inconistent" - self widget ifNotNil: [:w | w == self ifFalse: [ super color: aColor ]] -] - { #category : 'initialization' } SpSliderPresenter >> initialize [ | isChanging |