From d9f708bf56487513fd34d77f930c52d3b535e7b2 Mon Sep 17 00:00:00 2001 From: Martin Dias Date: Mon, 7 Oct 2024 19:07:12 -0300 Subject: [PATCH 1/3] Fixes in slider's Morphic adapter - Value: presenter and widget were not syncing correctly - Horizontal slider didn't work except when min=0 and max=1. - Vertical slider was wrong (not it becomes an ignored presenter property) - Value was supporting (unexpectedly) parsing from string, with special adhoc support for fractions - Label didn't update when change after opened --- .../SpMorphicSliderAdapter.class.st | 120 ++++++++---------- 1 file changed, 55 insertions(+), 65 deletions(-) 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) ] From cc0945885dc99c0acf512aaf39a58cde022d1a29 Mon Sep 17 00:00:00 2001 From: Martin Dias Date: Mon, 7 Oct 2024 19:12:34 -0300 Subject: [PATCH 2/3] Fixes on test case for slider's adapter - Rename SpSliderPresenterBackendTest -> SpSliderAdapterTest - Add tests (only 2 smoke tests before) --- .../SpBoxLayoutAdapterTest.class.st | 39 ---- .../SpSliderAdapterTest.class.st | 175 ++++++++++++++++++ .../SpSliderPresenterBackendTest.class.st | 32 ---- 3 files changed, 175 insertions(+), 71 deletions(-) create mode 100644 src/Spec2-Backend-Tests/SpSliderAdapterTest.class.st delete mode 100644 src/Spec2-Backend-Tests/SpSliderPresenterBackendTest.class.st 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. - -] From 5134345e903487857a111ba69c4899d59e695d53 Mon Sep 17 00:00:00 2001 From: Martin Dias Date: Tue, 8 Oct 2024 13:11:31 -0300 Subject: [PATCH 3/3] Delete color: override from slider presenter. - This kind of visual property needs to be defined through styles. - It does not work (self does not understand #widget), so there are no users --- src/Spec2-Core/SpSliderPresenter.class.st | 7 ------- src/Spec2-Core/SpStringTableColumn.class.st | 6 +++--- 2 files changed, 3 insertions(+), 10 deletions(-) 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 | diff --git a/src/Spec2-Core/SpStringTableColumn.class.st b/src/Spec2-Core/SpStringTableColumn.class.st index 730826b5..d68995f7 100644 --- a/src/Spec2-Core/SpStringTableColumn.class.st +++ b/src/Spec2-Core/SpStringTableColumn.class.st @@ -125,7 +125,7 @@ SpStringTableColumn >> onAcceptEdition: aBlock [ acceptAction := aBlock ] -{ #category : #api } +{ #category : 'api' } SpStringTableColumn >> onTextChanged: aBlock [ "Set the block to execute when cell edition is edited. `aBlock` receives two arguments: @@ -135,7 +135,7 @@ SpStringTableColumn >> onTextChanged: aBlock [ textChanged := aBlock ] -{ #category : #api } +{ #category : 'api' } SpStringTableColumn >> sortFunction [ ^ super sortFunction ifNil: [ self evaluation ascending ] @@ -156,7 +156,7 @@ SpStringTableColumn >> sortFunction: aBlockOrSortFunction [ self isSortable: aBlockOrSortFunction isNotNil ] -{ #category : #accessing } +{ #category : 'accessing' } SpStringTableColumn >> textChanged [ ^ textChanged