Adds SBVariantProxy s in Exploriants and utilities in other classes f…

…or it to stay consistent with original
hpi-swa · Aug 24, 2023 · 2492f86 · 2492f86
1 parent 9ace940
commit 2492f86
Show file tree

Hide file tree

Showing 6 changed files with 227 additions and 18 deletions.
diff --git a/packages/Sandblocks-Core/SBExploriants.class.st b/packages/Sandblocks-Core/SBExploriants.class.st
@@ -25,11 +25,11 @@ SBExploriants >> initialize [
 
 	self
 		attachDecorator: SBMoveDecorator new;
-		attachDecorator: SBResizableDecorator new;
 		changeTableLayout;
 		listDirection: #topToBottom;
 		layoutInset: 8;
 		cellGap: 16;
+		cellInset: 10;
 		hResizing: #shrinkWrap;
 		vResizing: #shrinkWrap
 ]
@@ -45,7 +45,10 @@ SBExploriants >> visualize [
 
 	self allMethodsContainingVariants 
 		collect: #asSandblock
-		thenDo: [:aSBStMethod | self addMorphBack: aSBStMethod].
+		thenDo: [:aSBStMethod | 
+			self addMorphBack: aSBStMethod methodHeader copy.
+			aSBStMethod containedVariants do: [:aSBVariant | self addMorphBack: (SBVariantProxy for: aSBVariant)].
+			self addMorphBack: (LineMorph from: 0@0 to: 50@0 color: Color black width: 2)].
 
 
 

diff --git a/packages/Sandblocks-Smalltalk/SBStBasicMethod.class.st b/packages/Sandblocks-Smalltalk/SBStBasicMethod.class.st
@@ -20,6 +20,12 @@ SBStBasicMethod class >> selector: aSymbol arguments: aCollection class: aClass
 		body: aBlock asSandblock
 ]
 
+{ #category : #comparing }
+SBStBasicMethod >> = anotherSBStBasicMethod [
+
+	^ anotherSBStBasicMethod class = self class and: [anotherSBStBasicMethod compiledMethod equivalentTo: self compiledMethod]
+]
+
 { #category : #accessing }
 SBStBasicMethod >> actualReceiver [
 
@@ -217,6 +223,12 @@ SBStBasicMethod >> compiledMethod [
 		ifAbsent: [self]
 ]
 
+{ #category : #accessing }
+SBStBasicMethod >> containedVariants [ 
+
+	^ self body containedVariants
+]
+
 { #category : #actions }
 SBStBasicMethod >> createTestMethod [
 	<action>
@@ -291,6 +303,12 @@ SBStBasicMethod >> deleteMethod [
 	^ self sandblockEditor do: (SBStDeleteMethodCommand new target: self)
 ]
 
+{ #category : #accessing }
+SBStBasicMethod >> detectVariant: aVariant [
+
+	^ self body detectVariant: aVariant
+]
+
 { #category : #'artefact protocol' }
 SBStBasicMethod >> ensureExpanded [
 

diff --git a/packages/Sandblocks-Smalltalk/SBStBlockBody.class.st b/packages/Sandblocks-Smalltalk/SBStBlockBody.class.st
@@ -113,18 +113,24 @@ SBStBlockBody >> blockBodyNestingDepth [
 	^ d
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #'insert/delete' }
 SBStBlockBody >> canDeleteChild: aBlock [
 
 	^ true
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #'layout properties - table' }
 SBStBlockBody >> cellGap [
 
 	^ self colorPolicy lineGap
 ]
 
+{ #category : #accessing }
+SBStBlockBody >> containedVariants [
+
+	^ self allBlocksSelect: #isVariant
+]
+
 { #category : #'ast helpers' }
 SBStBlockBody >> declarationsDo: aBlock [
 
@@ -152,6 +158,12 @@ SBStBlockBody >> declareTemporaryVariableCommand: aString [
 				yourself]
 ]
 
+{ #category : #accessing }
+SBStBlockBody >> detectVariant: aVariant [
+
+	^ (self allBlocksSelect: #isVariant) detect: [:oneOfMyVariants | oneOfMyVariants = aVariant]
+]
+
 { #category : #'as yet unclassified' }
 SBStBlockBody >> endPC [
 
@@ -176,13 +188,13 @@ SBStBlockBody >> fixedNumberOfChildren [
 	^ false
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #accessing }
 SBStBlockBody >> guessedClass [
 
 	^ BlockClosure
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #'initialize-release' }
 SBStBlockBody >> initialize [
 
 	super initialize.
@@ -201,7 +213,7 @@ SBStBlockBody >> initialize [
 			addMorphBack: temporaries)
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #'insert/delete' }
 SBStBlockBody >> insertCommandRequest: aMorph near: aBlock before: aBoolean [
 
 	(aBlock notNil and: [aBlock owner = bindings]) ifTrue: [
@@ -227,7 +239,7 @@ SBStBlockBody >> insertCommandRequest: aMorph near: aBlock before: aBoolean [
 		title: 'insert statement'
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #testing }
 SBStBlockBody >> isBlockBody [
 
 	^ true
@@ -251,7 +263,7 @@ SBStBlockBody >> isScope [
 	^ true
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #layout }
 SBStBlockBody >> layoutCommands [
 
 	| preamble preambleHasContent multiLine |
@@ -294,13 +306,13 @@ SBStBlockBody >> localNestingDepth [
 	^ 1
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #layout }
 SBStBlockBody >> minHeight [
 
 	^ self fontToUse height + self layoutInset asEdgeInsets y
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #'geometry - layout' }
 SBStBlockBody >> minimumHeight [
 
 	^ self fontToUse height + self layoutInset asEdgeInsets vertical
@@ -320,7 +332,7 @@ SBStBlockBody >> newEmptyChildNear: aBlock before: aBoolean [
 	^ super newEmptyChildNear: aBlock before: aBoolean
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #'object interface' }
 SBStBlockBody >> objectInterfaceNear: aBlock at: aSymbol [
 
 	({bindings. temporaries} includes: (aBlock ifNotNil: #owner)) ifTrue: [^ SBInterfaces stName].
@@ -395,7 +407,7 @@ SBStBlockBody >> statementsDo: aBlock [
 	^ self submorphs allButFirstDo: aBlock
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #'colors and color policies' }
 SBStBlockBody >> symbols [
 
 	^ self isMethodBody ifTrue: [#(nil nil)] ifFalse: [self colorPolicy symbolsForBlock: self]
@@ -413,7 +425,7 @@ SBStBlockBody >> temporaries: aCollection [
 	temporaries bindings: aCollection
 ]
 
-{ #category : #'as yet unclassified' }
+{ #category : #accessing }
 SBStBlockBody >> updatePCFrom: aBlock [
 
 	super updatePCFrom: aBlock.

diff --git a/packages/Sandblocks-Smalltalk/SBStMethod.class.st b/packages/Sandblocks-Smalltalk/SBStMethod.class.st
@@ -144,6 +144,12 @@ SBStMethod >> methodClass [
 	^ classPrefix selectedClass ifNil: [self outerArtefact ifNotNil: #relatedClass]
 ]
 
+{ #category : #accessing }
+SBStMethod >> methodHeader [
+
+	^ self firstSubmorph 
+]
+
 { #category : #'object interface' }
 SBStMethod >> objectInterfaceNear: aBlock at: aSymbol [
 

diff --git a/packages/Sandblocks-Smalltalk/SBVariant.class.st b/packages/Sandblocks-Smalltalk/SBVariant.class.st
@@ -3,7 +3,8 @@ Class {
 	#superclass : #SBStSubstitution,
 	#instVars : [
 		'name',
-		'widget'
+		'widget',
+		'id'
 	],
 	#category : #'Sandblocks-Smalltalk'
 }
@@ -38,7 +39,7 @@ SBVariant class >> matches: aBlock [
 { #category : #constants }
 SBVariant class >> matchingSelector [
 
-	^ #named:associations:activeIndex:
+	^ #named:associations:activeIndex:id:
 ]
 
 { #category : #'instance creation' }
@@ -52,7 +53,18 @@ SBVariant class >> named: aString alternatives: aCollectionOfNamedBlocks activeI
 ]
 
 { #category : #'instance creation' }
-SBVariant class >> named: aString associations: aCollectionOfAssociations activeIndex: aNumber [
+SBVariant class >> named: aString alternatives: aCollectionOfNamedBlocks activeIndex: aNumber id: uuid [
+
+	^ self new
+		named: aString
+		alternatives: aCollectionOfNamedBlocks
+		activeIndex: aNumber
+		id: uuid
+
+]
+
+{ #category : #'instance creation' }
+SBVariant class >> named: aString associations: aCollectionOfAssociations activeIndex: aNumber id: uuid [
 
 	^ aNumber > 0 ifTrue: [(aCollectionOfAssociations at: aNumber) value value] ifFalse: [nil]
 
@@ -71,6 +83,7 @@ SBVariant class >> newFor: aBlock [
 		named: aBlock arguments first contents
 		alternatives: (aBlock arguments second childSandblocks collect: [:anAssociation | SBNamedBlock block: (anAssociation arguments first) named: (anAssociation receiver contents)])
 		activeIndex: aBlock arguments third parsedContents
+		id: aBlock arguments fourth contents
 ]
 
 { #category : #shortcuts }
@@ -80,6 +93,12 @@ SBVariant class >> registerShortcuts: aProvider [
 
 ]
 
+{ #category : #comparing }
+SBVariant >> = otherVariant [
+
+	^ otherVariant class = self class and: [otherVariant id = self id]
+]
+
 { #category : #accessing }
 SBVariant >> active [
 
@@ -104,6 +123,18 @@ SBVariant >> alternatives [
 	^ self widget namedBlocks
 ]
 
+{ #category : #comparing }
+SBVariant >> alternativesEqual: otherAlternatives [
+
+	"Private"
+	"Does a cheap version of python's zip and then allSatisfy:"
+	| areSame |
+	areSame := true.
+	^ self alternatives size = otherAlternatives size and: [
+		(1 to: self alternatives size) do: [:index | 
+			areSame := areSame and: [(self alternatives at: index) = (otherAlternatives at: index)]]. 		areSame]
+]
+
 { #category : #accessing }
 SBVariant >> color [
 
@@ -116,6 +147,16 @@ SBVariant >> drawnColor [
 	^ Color white
 ]
 
+{ #category : #accessing }
+SBVariant >> id [
+	^ id
+]
+
+{ #category : #accessing }
+SBVariant >> id: anObject [
+	id := anObject
+]
+
 { #category : #initialization }
 SBVariant >> initialize [
 
@@ -128,7 +169,7 @@ SBVariant >> initialize [
 	self widget: (SBTabView
 		namedBlocks: {SBNamedBlock block: (SBStBlockBody emptyWithDeclarations: {'a'. 'c'}) named: 'Code'}
 		activeIndex: 1).
-
+	id := UUID new asString. 
 
 	self
 		layoutInset: 0;
@@ -164,6 +205,13 @@ SBVariant >> named: aString alternatives: aCollectionOfNamedBlocks activeIndex:
 	self widget namedBlocks: aCollectionOfNamedBlocks activeIndex: aNumber
 ]
 
+{ #category : #initialization }
+SBVariant >> named: aString alternatives: aCollectionOfNamedBlocks activeIndex: aNumber id: uuid [
+
+	self id: uuid.
+	self named: aString alternatives: aCollectionOfNamedBlocks activeIndex: aNumber
+]
+
 { #category : #accessing }
 SBVariant >> namedBlocks [ 
 
@@ -191,6 +239,12 @@ SBVariant >> replaceSelfWithChosen [
 									unwrapped: {self activeBlock lastSubmorph})
 ]
 
+{ #category : #initialization }
+SBVariant >> replaceValuesFrom: anotherVariant [
+
+	self named: anotherVariant name alternatives: anotherVariant alternatives activeIndex: anotherVariant activeIndex  
+]
+
 { #category : #ui }
 SBVariant >> updateResize [
 
@@ -231,5 +285,7 @@ SBVariant >> writeSourceOn: aStream [
 		separatedBy: [aStream nextPut: $.].
 	aStream nextPutAll: '} activeIndex: '.
 	self activeIndex storeOn: aStream.
+	aStream nextPutAll: ' id: '.
+	self id storeOn: aStream.
 	aStream nextPutAll: ')'
 ]