diff --git a/packages/Sandblocks-Core/SBExploriants.class.st b/packages/Sandblocks-Core/SBExploriants.class.st index 8a104d6d..a750a39c 100644 --- 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 index 02257312..14ab188d 100644 --- 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 [ @@ -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 index 13b24e61..40492db0 100644 --- 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 index f2dded4c..c2070443 100644 --- 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 index 689acca2..2dbda922 100644 --- 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: ')' ] diff --git a/packages/Sandblocks-Smalltalk/SBVariantProxy.class.st b/packages/Sandblocks-Smalltalk/SBVariantProxy.class.st new file mode 100644 index 00000000..7e05fce1 --- /dev/null +++ b/packages/Sandblocks-Smalltalk/SBVariantProxy.class.st @@ -0,0 +1,114 @@ +Class { + #name : #SBVariantProxy, + #superclass : #SBBlock, + #instVars : [ + 'original' + ], + #category : #'Sandblocks-Smalltalk' +} + +{ #category : #'as yet unclassified' } +SBVariantProxy class >> for: aVariant [ + + ^ self new for: aVariant +] + +{ #category : #callbacks } +SBVariantProxy >> artefactChanged: anArtefact [ + + anArtefact = self ifTrue: [ self updateOriginalWithOwnValues ]. + + (anArtefact = self containedMethod) + ifTrue: [ self updateSelfAfterMethodUpdate: anArtefact ] +] + +{ #category : #callbacks } +SBVariantProxy >> artefactSaved: anArtefact [ + + anArtefact = self containedMethod ifTrue: [self sandblockEditor markSaved: self] +] + +{ #category : #'ast helpers' } +SBVariantProxy >> binding: aString for: block class: aClass ifPresent: aBlock [ + + ^ self containedMethod binding: aString for: block class: aClass ifPresent: aBlock +] + +{ #category : #accessing } +SBVariantProxy >> containedMethod [ + + ^ original containingArtefact +] + +{ #category : #initialization } +SBVariantProxy >> for: aVariant [ + + self assert: aVariant containingArtefact notNil. + + original := aVariant. + self addMorphBack: original copyBlock. +] + +{ #category : #initialization } +SBVariantProxy >> initialize [ + + super initialize. + + self + hResizing: #shrinkWrap; + vResizing: #shrinkWrap; + changeTableLayout; + layoutInset: 4; + attachDecorator: SBForceMoveDecorator newConfigured +] + +{ #category : #testing } +SBVariantProxy >> isArtefact [ + + ^ true +] + +{ #category : #'artefact protocol' } +SBVariantProxy >> saveTryFixing: aFixBoolean quick: aQuickBoolean [ + + self sandblockEditor + save: self containedMethod + tryFixing: aFixBoolean + quick: aQuickBoolean. + ^ false +] + +{ #category : #'ast helpers' } +SBVariantProxy >> scopesDo: aBlock [ + + original scopesDo: aBlock +] + +{ #category : #callbacks } +SBVariantProxy >> updateOriginalWithOwnValues [ + + + | variantThatNeedsChanging | + original replaceBy: (original := self firstSubmorph copyBlock). + variantThatNeedsChanging := self containedMethod detectVariant: original. + variantThatNeedsChanging ifNil: [self delete. ^ self]. + variantThatNeedsChanging replaceValuesFrom: original copyBlock. + self sandblockEditor markChanged: self containedMethod +] + +{ #category : #callbacks } +SBVariantProxy >> updateSelfAfterMethodUpdate: newMethod [ + + | variantThatMaybeChanged | + variantThatMaybeChanged := newMethod detectVariant: original. + + "orignal variant has been deleted" + variantThatMaybeChanged ifNil: [self delete. ^ self]. + + (variantThatMaybeChanged sourceString ~= self firstSubmorph sourceString) + ifTrue: [ + original := variantThatMaybeChanged. + self firstSubmorph replaceBy: original copyBlock. + self sandblockEditor markChanged: self] + +]