Adding scrolling capabilities to Spec list presenter

src/Morphic-Widgets-FastTable/FTScrollingChanged.class.st

@@ -0,0 +1,37 @@
+Class {
+	#name : #FTScrollingChanged,
+	#superclass : #FTAnnouncement,
+	#instVars : [
+		'newScrollingIndex',
+		'oldScrollingIndex'
+	],
+	#category : #'Morphic-Widgets-FastTable-Announcement'
+}
+
+{ #category : #'instance creation' }
+FTScrollingChanged class >> from: oldIndex to: newIndex [
+	^ self new
+		oldScrollingIndex: oldIndex;
+		newScrollingIndex: newIndex;
+		yourself
+]
+
+{ #category : #accessing }
+FTScrollingChanged >> newScrollingIndex [
+	^ newScrollingIndex
+]
+
+{ #category : #accessing }
+FTScrollingChanged >> newScrollingIndex: anObject [
+	newScrollingIndex := anObject
+]
+
+{ #category : #accessing }
+FTScrollingChanged >> oldScrollingIndex [
+	^ oldScrollingIndex
+]
+
+{ #category : #accessing }
+FTScrollingChanged >> oldScrollingIndex: anObject [
+	oldScrollingIndex := anObject
+]

src/Morphic-Widgets-FastTable/FTTableContainerMorph.class.st

@@ -116,12 +116,14 @@ FTTableContainerMorph >> calculateStartIndexWhenShowing: visibleRows [
 	"Answer the first row to show when showing visibleRows rows. 
 	 This works in case we are exceeding the available rows to show"
 
-	| currentIndex startIndex |
+	| currentIndex startIndex oldIndex |
 	currentIndex := self table showIndex.
 	currentIndex + visibleRows - 1 > self table numberOfRows ifTrue: [ 
 		currentIndex := self table numberOfRows - visibleRows + 2].
 	startIndex := currentIndex max: 1.
+	oldIndex := self table showIndex.
 	self table basicMoveShowIndexTo: startIndex.
+	self table announceScrollChangedFrom: oldIndex to: self table showIndex.
 	^startIndex
 
 ]
@@ -244,6 +246,14 @@ FTTableContainerMorph >> exposedRows [
 	^ exposedRows
 ]
 
+{ #category : #accessing }
+FTTableContainerMorph >> firstVisibleRowIndex [
+
+	^ self exposedRows
+		ifNotEmpty: [ :rows | rows keys first ]
+		ifEmpty: [ 0 ]
+]
+
 { #category : #accessing }
 FTTableContainerMorph >> headerRow [
 
@@ -281,6 +291,14 @@ FTTableContainerMorph >> isRowIndexVisible: rowIndex [
 	^ self exposedRows includesKey: rowIndex
 ]
 
+{ #category : #accessing }
+FTTableContainerMorph >> lastVisibleRowIndex [
+
+	^ self exposedRows
+		ifNotEmpty: [ :rows | rows keys last ]
+		ifEmpty: [ 0 ]
+]
+
 { #category : #private }
 FTTableContainerMorph >> needsRefreshExposedRows [
 	^ needsRefreshExposedRows

src/Morphic-Widgets-FastTable/FTTableMorph.class.st

@@ -127,6 +127,17 @@ FTTableMorph >> allowsDeselection: aBoolean [
 	allowsDeselection := aBoolean
 ]
 
+{ #category : #private }
+FTTableMorph >> announceScrollChangedFrom: oldIndex to: newIndex [
+	"If the index did not change, do nothing"
+	oldIndex = newIndex ifTrue: [ ^ self ].
+	self
+		doAnnounce:
+			((FTScrollingChanged from: oldIndex to: newIndex)
+				fastTable: self;
+				yourself)
+]
+
 { #category : #updating }
 FTTableMorph >> autoScrollHeightLimit [
 
@@ -146,8 +157,8 @@ FTTableMorph >> basicHighlightRowIndexes: anArray [
 
 { #category : #private }
 FTTableMorph >> basicMoveShowIndexTo: aNumber [
-	showIndex := aNumber.
 
+	showIndex := aNumber
 ]
 
 { #category : #private }
@@ -349,6 +360,12 @@ FTTableMorph >> extent: aPoint [
 	self resizeAllSubviews
 ]
 
+{ #category : #accessing }
+FTTableMorph >> firstVisibleRowIndex [
+
+	^ self container firstVisibleRowIndex
+]
+
 { #category : #'event handling' }
 FTTableMorph >> handleMouseMove: anEvent [
 	"Reimplemented because we really want #mouseMove when a morph is dragged around"
@@ -694,6 +711,12 @@ FTTableMorph >> keyboardFocusChange: aBoolean [
 	self focusChanged
 ]
 
+{ #category : #accessing }
+FTTableMorph >> lastVisibleRowIndex [
+
+	^ self container lastVisibleRowIndex
+]
+
 { #category : #layout }
 FTTableMorph >> minHeight [ 
 	"Ceiling is required because there is strange behavior when this method return float.
@@ -795,11 +818,14 @@ FTTableMorph >> moveShowIndexTo: arg [
 	 showing pointer should do it directly. 
 	 Use me just in case you need to force a refresh after settign the index"
 
-	| index |
+	| index oldIndex |
 	index := self selectionModeStrategy rowIndexFrom: arg.
+	oldIndex := showIndex.
 	self basicMoveShowIndexTo: index.
 	self verticalScrollBar value: (self rowIndexToVerticalScrollBarValue: index).
-	self refresh
+	self refresh.
+
+	self announceScrollChangedFrom: oldIndex to: index.
 ]
 
 { #category : #accessing }
@@ -951,6 +977,15 @@ FTTableMorph >> scrollBarThickness [
 	^ self theme scrollbarThickness
 ]
 
+{ #category : #private }
+FTTableMorph >> scrollToIndex: anIndex [
+	(self container isRowIndexFullyVisible: anIndex) ifTrue: [ ^ self ].
+
+	anIndex <= self showIndex
+		ifTrue: [ self moveShowIndexTo: anIndex ]
+		ifFalse: [ self moveShowIndexTo: (self selectionModeStrategy indexForRow: anIndex - self container calculateMinVisibleRows + 1) ]
+]
+
 { #category : #'accessing colors' }
 FTTableMorph >> secondarySelectionColor [ 
 	^ secondarySelectionColor ifNil: [ self class defaultSecondarySelectionColor ]

src/Spec2-Adapters-Morphic/SpMorphicListAdapter.class.st

@@ -56,11 +56,18 @@ SpMorphicListAdapter >> buildWidget [
 	self presenter whenModelChangedDo: [ widget refresh ].
 	self presenter whenSelectionChangedDo: [ self refreshWidgetSelection ].
 	self presenter selection whenChangedDo: [ self refreshWidgetSelection ].
+
 	self refreshWidgetHeaderTitle.
 	self refreshWidgetSelection.
 	self presenter whenItemFilterBlockChangedDo: [ :block | self updateItemFilterBlockWith: block ].
 	self updateItemFilterBlockWith: self itemFilter.
-
+
+	self presenter verticalAlignment whenChangedDo: [ 
+		widget scrollToIndex: self presenter verticalAlignment desiredVisibleRow ].
+	self presenter whenDisplayDo: [ 
+		widget scrollToIndex: self presenter verticalAlignment desiredVisibleRow.
+		self scrollingChanged ].
+	widget onAnnouncement: FTScrollingChanged send: #scrollingChanged to: self.
 	widget bindKeyCombination: Character space toAction: [ self model clickOnSelectedItem ].
 
 	^ widget
@@ -166,6 +173,15 @@ SpMorphicListAdapter >> rightClicked [
 	self widget click: evt
 ]
 
+{ #category : #scrolling }
+SpMorphicListAdapter >> scrollingChanged [
+
+	widget container updateAllRows.
+	self presenter verticalAlignment
+		firstVisibleRowIndex: widget firstVisibleRowIndex;
+		lastVisibleRowIndex: widget lastVisibleRowIndex
+]
+
 { #category : #selecting }
 SpMorphicListAdapter >> selectIndex: anInteger [ 
 

src/Spec2-Adapters-Morphic/SpMorphicTableAdapter.class.st

@@ -28,6 +28,13 @@ SpMorphicTableAdapter >> addModelTo: tableMorph [
 
 	tableMorph setBalloonText: self help.
 
+	self presenter verticalAlignment whenChangedDo: [ 
+		widget scrollToIndex: self presenter verticalAlignment desiredVisibleRow ].
+	self presenter whenDisplayDo: [ 
+		widget scrollToIndex: self presenter verticalAlignment desiredVisibleRow.
+		self scrollingChanged ].
+	widget onAnnouncement: FTScrollingChanged send: #scrollingChanged to: self.
+
 	tableMorph
 		onAnnouncement: FTSelectionChanged
 			send: #selectionChanged:
@@ -151,6 +158,15 @@ SpMorphicTableAdapter >> rightClicked [
 	self widget click: evt
 ]
 
+{ #category : #factory }
+SpMorphicTableAdapter >> scrollingChanged [
+
+	widget container updateAllRows.
+	self presenter verticalAlignment
+		firstVisibleRowIndex: widget firstVisibleRowIndex;
+		lastVisibleRowIndex: widget lastVisibleRowIndex
+]
+
 { #category : #selection }
 SpMorphicTableAdapter >> selectIndex: anInteger [ 
 

src/Spec2-Backend-Tests/SpAbstractAdapterTestCase.class.st

@@ -89,18 +89,21 @@ SpAbstractAdapterTestCase >> openInstance [
 
 ]
 
-{ #category : #private }
+{ #category : #running }
 SpAbstractAdapterTestCase >> performTest [
-
-	specInitializationStrategy beforeTest: self.
-	super performTest.
+
+	backendForTest runTest: [
+		presenter := self classToTest new.
+		self initializeTestedInstance.
+		super performTest]
 ]
 
 { #category : #running }
-SpAbstractAdapterTestCase >> prepareToRunAgain [
-
-	backendForTest runTest: [ super prepareToRunAgain ]
+SpAbstractAdapterTestCase >> prepareToRunAgain [ 	
 
+	"Redefined because setup is cancelled in this class"
+	self tearDown.
+	super setUp.
 ]
 
 { #category : #accessing }
@@ -110,14 +113,9 @@ SpAbstractAdapterTestCase >> presenter [
 
 { #category : #running }
 SpAbstractAdapterTestCase >> runCase [
-
 	self resources do: [:each | each availableFor: self].
-	[	super setUp.
-		backendForTest runTest: [
-			presenter := self classToTest new.
-			self initializeTestedInstance.
-			self performTest].
-	] ensure: [
+	[super setUp.
+	self performTest] ensure: [
 		self tearDown.
 		self cleanUpInstanceVariables]
 ]

src/Spec2-Backend-Tests/SpAbstractListCommonPropertiestTest.class.st

@@ -36,6 +36,14 @@ SpAbstractListCommonPropertiestTest >> testDoubleClickActivatesRowInDoubleClickA
 	self assert: activated
 ]
 
+{ #category : #'tests-scrolling' }
+SpAbstractListCommonPropertiestTest >> testFirstVisibleRowIsInitiallyFirstRow [
+
+	presenter items: (1 to: 500).
+	self openInstance.
+	self assert: presenter verticalAlignment firstVisibleRowIndex equals: 1.
+]
+
 { #category : #tests }
 SpAbstractListCommonPropertiestTest >> testRightClickShowsMenu [
 	| menu |
@@ -46,6 +54,32 @@ SpAbstractListCommonPropertiestTest >> testRightClickShowsMenu [
 	self assert: menu shown
 ]
 
+{ #category : #'tests-scrolling' }
+SpAbstractListCommonPropertiestTest >> testScrollDownToPosteriorIndexScrollsBottomToIndex [
+
+	presenter items: (1 to: 500).
+	presenter verticalAlignment desiredVisibleRow: 100.
+
+	"Force opening the spec instance here.
+	We want to test that once open we can change the state"
+	self openInstance.
+
+	"Some backends will show entirely row 100 and a part of the next row, so row 101 is also a valid answer"
+	self assert: (presenter verticalAlignment lastVisibleRowIndex between: 100 and: 101).
+]
+
+{ #category : #'tests-scrolling' }
+SpAbstractListCommonPropertiestTest >> testScrollUpToPreviousIndexScrollsTopToIndex [
+
+	presenter items: (1 to: 500).
+	presenter verticalAlignment desiredVisibleRow: 100.
+	self openInstance.
+
+	presenter verticalAlignment desiredVisibleRow: 50.
+
+	self assert: presenter verticalAlignment firstVisibleRowIndex equals: 50.
+]
+
 { #category : #running }
 SpAbstractListCommonPropertiestTest >> testSingleClickActivatesRowInSingleClickActivationMode [
 

src/Spec2-Core/SpAbstractListPresenter.class.st

@@ -9,7 +9,8 @@ Class {
 		'#activateOnSingleClick',
 		'#model',
 		'#contextMenu => SpObservableSlot',
-		'#itemFilter => SpObservableSlot'
+		'#itemFilter => SpObservableSlot',
+		'#verticalAlignment'
 	],
 	#category : #'Spec2-Core-Widgets-Table'
 }
@@ -118,6 +119,7 @@ SpAbstractListPresenter >> initialize [
 	super initialize.
 
 	activationBlock := [ ].
+	verticalAlignment := SpVerticalAlignment new.
 
 	self withScrollBars.
 	self model: 	self newEmptyModel.
@@ -321,6 +323,12 @@ SpAbstractListPresenter >> unselectItem: anInteger [
 	self selection unselectItem: anInteger
 ]
 
+{ #category : #api }
+SpAbstractListPresenter >> verticalAlignment [
+
+	^ verticalAlignment
+]
+
 { #category : #'api-events' }
 SpAbstractListPresenter >> whenActivatedDo: aBlockClosure [