Extract message send blocks to examples

packages/Sandblocks-Babylonian/SBStGrammarHandler.extension.st

@@ -4,24 +4,30 @@ Extension { #name : #SBStGrammarHandler }
 SBStGrammarHandler >> addExample [
 	<action>
 
-	| method class example |
+	| method |
 	self block isExample ifTrue: [^ self block toggleRunning].
 
 	method := self block containingArtefact.
-	class := method methodClass.
-	example := self createExampleIn: method of: class.
+	self addExample: (self createExampleIn: method classed: method methodClass).
+]
+
+{ #category : #'*Sandblocks-Babylonian' }
+SBStGrammarHandler >> addExample: anExample [
+
+	| method |
+	method := self block containingArtefact.
 
 	self block sandblockEditor do: (SBInsertCommand new
 		container: method body;
 		index: 2;
-		morph: example).
+		morph: anExample).
 
-	example startRunning.
-	self block sandblockEditor select: example nameBlock.
+	anExample startRunning.
+	self block sandblockEditor select: anExample nameBlock.
 ]
 
 { #category : #'*Sandblocks-Babylonian' }
-SBStGrammarHandler >> createExampleIn: aMethod of: aClass [
+SBStGrammarHandler >> createExampleIn: aMethod classed: aClass [
 
 	^ SBExample new
 			self: (aMethod isClassSide 

packages/Sandblocks-Smalltalk/SBStMessageSend.class.st

@@ -36,6 +36,18 @@ SBStMessageSend >> arguments [
 	^ signature arguments
 ]
 
+{ #category : #converting }
+SBStMessageSend >> asExample [
+	<convert>
+
+	^ SBExample new 
+			self: self actualReceiver veryDeepCopy
+			args: (SBStArray new
+				type: #dynamic
+				contents: self arguments veryDeepCopy)
+			label: 'example'
+]
+
 { #category : #converting }
 SBStMessageSend >> asLanguageBox: converter [
 	<convert>
@@ -176,6 +188,21 @@ SBStMessageSend >> deleteCommandFor: aBlock [
 	^ signature deleteCommandFor: aBlock
 ]
 
+{ #category : #'action helpers' }
+SBStMessageSend >> determineReceiverClass [
+
+	| class method |
+	method := (Parser new parse: self receiver sourceString, ' class' 
+							class: UndefinedObject 
+							noPattern: true 
+							notifying: nil 
+							ifFail: nil) generate.
+	class := [Sandbox2 evaluate: [UndefinedObject executeMethod: method]] 
+		valueWithin: 5 seconds
+		onTimeout: [UIManager default chooseClassOrTrait label: 'Could not resolve. Select class to add example to.'].
+	^ class
+]
+
 { #category : #'as yet unclassified' }
 SBStMessageSend >> drawSubmorphsOn: aCanvas [
 
@@ -190,6 +217,27 @@ SBStMessageSend >> expression [
 	^ self arguments first
 ]
 
+{ #category : #actions }
+SBStMessageSend >> extractExample [
+	<action>
+
+	| class methodBlock |
+	self isMessageSend ifFalse: [^self].
+	class := self determineReceiverClass ifNil: [^ self].
+	methodBlock := self getOrCreateExistingMethodBlockFor: self selector classed: class.
+	methodBlock isInEditor ifFalse: [self sandblockEditor openMorphInView: methodBlock].
+	self sandblockEditor select: methodBlock.
+
+	"to avoid recursive calls and infinite loops when examples run on addition"
+	self removeSelfAndSaveArtefact.
+
+	self grammarHandler 
+		block: methodBlock;
+		addExample: self asExample.
+
+
+]
+
 { #category : #accessing }
 SBStMessageSend >> fixActions [
 
@@ -223,6 +271,16 @@ SBStMessageSend >> fixedNumberOfChildren [
 	^ false
 ]
 
+{ #category : #'action helpers' }
+SBStMessageSend >> getOrCreateExistingMethodBlockFor: aSelector classed: aClass [
+
+	| method |
+	method := aClass compiledMethodAt: aSelector asSymbol.
+	^ self sandblockEditor blockFor: method withInterfaces: #(#isMethod) 
+		ifOpen: [:existingMethodBlock | existingMethodBlock] 
+		ifClosed: [method asSandblock].
+]
+
 { #category : #'as yet unclassified' }
 SBStMessageSend >> guessedClass [
 
@@ -468,6 +526,15 @@ SBStMessageSend >> receiver: aBlock selector: aSymbol arguments: aCollection [
 	self receiver: aBlock
 ]
 
+{ #category : #'action helpers' }
+SBStMessageSend >> removeSelfAndSaveArtefact [
+
+	| artefact |
+	artefact := self containingArtefact.
+	self delete.
+	artefact save.
+]
+
 { #category : #'as yet unclassified' }
 SBStMessageSend >> selector [