Merge pull request #1619 from tinchodias/FixSlider

Fix slider
pharo-spec · Oct 13, 2024 · fed1607 · fed1607
2 parents 133dd8e + 5134345
commit fed1607
Show file tree

Hide file tree

Showing 5 changed files with 230 additions and 143 deletions.
diff --git 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
@@ -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
@@ -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