diff --git a/packages/Sandblocks-Babylonian/SBStGrammarHandler.extension.st b/packages/Sandblocks-Babylonian/SBStGrammarHandler.extension.st index 45d6515a..4c1df86a 100644 --- a/packages/Sandblocks-Babylonian/SBStGrammarHandler.extension.st +++ b/packages/Sandblocks-Babylonian/SBStGrammarHandler.extension.st @@ -4,24 +4,30 @@ Extension { #name : #SBStGrammarHandler } SBStGrammarHandler >> addExample [ - | 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 diff --git a/packages/Sandblocks-Smalltalk/SBStMessageSend.class.st b/packages/Sandblocks-Smalltalk/SBStMessageSend.class.st index 7fb01188..7cf9b82b 100644 --- a/packages/Sandblocks-Smalltalk/SBStMessageSend.class.st +++ b/packages/Sandblocks-Smalltalk/SBStMessageSend.class.st @@ -36,6 +36,18 @@ SBStMessageSend >> arguments [ ^ signature arguments ] +{ #category : #converting } +SBStMessageSend >> asExample [ + + + ^ SBExample new + self: self actualReceiver veryDeepCopy + args: (SBStArray new + type: #dynamic + contents: self arguments veryDeepCopy) + label: 'example' +] + { #category : #converting } SBStMessageSend >> asLanguageBox: converter [ @@ -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 [ + + + | 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 [