Merge pull request #653 from pillar-markup/dev

merge pharoeval extension

src/Microdown-RichTextComposer/MicDocumentHierarchyBuilder.class.st

@@ -0,0 +1,198 @@
+"
+Create a hierarchy tree to show in microdown documentation.
+This builder allows you to create the nice hierarchy you can see at `SpAbstractWidgetPresenter` class comment (in hierarchy section).
+
+## Example
+```Smalltalk
+SpDocumentHierarchyBuilder new
+	""The class where to start the hierarchy (a superclass of aClass)""
+	fromClass: aTopClass;
+	""The microdown builder"" 
+	builder: aBuilder;	
+	""A filter to make sure we include classes we want in hierarchy"" 
+	filter: [ :eachClass | eachClass package packageName beginsWith: 'Spec2-' ]; 
+	""Build the hierarchy for the class aClass""
+	buildFor: aClass
+```
+"
+Class {
+	#name : #MicDocumentHierarchyBuilder,
+	#superclass : #Object,
+	#instVars : [
+		'topClass',
+		'flattenTree',
+		'builder',
+		'filterBlock',
+		'class',
+		'fromClass'
+	],
+	#category : #'Microdown-RichTextComposer'
+}
+
+{ #category : #private }
+MicDocumentHierarchyBuilder >> addLevel: level from: aClass [
+	"'├ ─ ╰ │'"
+	| path |
+
+	path := (aClass allSuperclasses copyUpTo: self topClass) reversed.
+
+	builder monospace: '  '.
+
+	path do: [ :each |
+		builder monospace: ((self isPassingThrough: aClass topLevel: each)
+			ifTrue: [  '│ ' ]
+			ifFalse: [ '  ' ]) ].
+
+	level > 0 ifTrue: [ 
+		| list |
+		list := flattenTree at: aClass superclass ifAbsent: [ #() ].
+		list ifNotEmpty: [ 
+			builder monospace: ((list size = 1 or: [ list last = aClass ])
+				ifTrue: [ '╰─ ' ]
+				ifFalse: [ '├─ ' ]) ] ].
+
+	builder monospace: aClass name.
+	aClass = class 
+		ifTrue: [ builder monospace: ' (this is me)' ].
+	builder newLine.
+	(flattenTree at: aClass) do: [ :each |
+		self 
+			addLevel: level + 1 
+			from: each ]
+]
+
+{ #category : #private }
+MicDocumentHierarchyBuilder >> addLevel: level from: aClass to: stream [
+	"'├ ─ ╰ │'"
+	| path |
+
+	path := (aClass allSuperclasses copyUpTo: self topClass) reversed.
+
+	path do: [ :each |
+		stream << ((self isPassingThrough: aClass topLevel: each)
+			ifTrue: [  '│ ' ]
+			ifFalse: [ '  ' ]) ].
+
+	level > 0 ifTrue: [ 
+		| list |
+		list := flattenTree at: aClass superclass ifAbsent: [ #() ].
+		list ifNotEmpty: [ 
+			(list size = 1 or: [ list last = aClass ])
+				ifTrue: [ stream << '╰─ ' ]
+				ifFalse: [ stream << '├─ ' ] ] ].
+
+	stream << aClass name.
+	stream newLine.
+	(flattenTree at: aClass) do: [ :each |
+		self 
+			addLevel: level + 1 
+			from: each 
+			to: stream ]
+]
+
+{ #category : #private }
+MicDocumentHierarchyBuilder >> applyFilterTo: aCollection [
+
+	filterBlock ifNil: [ ^ aCollection ].
+	^ aCollection select: filterBlock
+]
+
+{ #category : #building }
+MicDocumentHierarchyBuilder >> buildFor: aClass [
+
+	self fillTreeOf: aClass.
+	self 
+		addLevel: 0
+		from: self fromClass
+]
+
+{ #category : #building }
+MicDocumentHierarchyBuilder >> buildStringFor: aClass [
+
+	self fillTreeOf: aClass.
+	^ String streamContents: [ :stream |
+		self 
+			addLevel: 0
+			from: SpAbstractPresenter 
+			to: (ZnNewLineWriterStream on: stream) ]
+]
+
+{ #category : #accessing }
+MicDocumentHierarchyBuilder >> builder: aBuilder [
+
+	builder := aBuilder
+]
+
+{ #category : #private }
+MicDocumentHierarchyBuilder >> fillTreeOf: aClass [
+
+	class := aClass.
+	flattenTree := OrderedDictionary new.
+	self fillTreeWithSuperclassesOf: aClass.
+	self fillTreeWithSubclassesOf: aClass.
+
+	^ flattenTree
+]
+
+{ #category : #private }
+MicDocumentHierarchyBuilder >> fillTreeWithSubclassesOf: aClass [
+
+	flattenTree at: aClass put: (self applyFilterTo: aClass subclasses).
+	aClass subclasses do: [ :each |
+		self fillTreeWithSubclassesOf: each ]
+]
+
+{ #category : #private }
+MicDocumentHierarchyBuilder >> fillTreeWithSuperclassesOf: aClass [
+	| superclasses |
+
+	superclasses := (aClass allSuperclasses copyUpTo: self topClass) reversed.
+	superclasses do: [ :each | 
+		flattenTree 
+			at: each 
+			put: { (superclasses 
+				after: each
+				ifAbsent: [ aClass ]) } ].
+
+]
+
+{ #category : #accessing }
+MicDocumentHierarchyBuilder >> filter: aBlock [
+
+	filterBlock := aBlock
+]
+
+{ #category : #accessing }
+MicDocumentHierarchyBuilder >> fromClass [
+
+	 ^  fromClass ifNil: [ SpAbstractPresenter ]
+]
+
+{ #category : #accessing }
+MicDocumentHierarchyBuilder >> fromClass: aClass [
+
+	fromClass := aClass
+]
+
+{ #category : #testing }
+MicDocumentHierarchyBuilder >> isPassingThrough: aClass topLevel: aTopClass [
+	| superclasses |
+
+	superclasses := flattenTree at: aTopClass superclass ifAbsent: [ #() ].
+	superclasses size <= 1 ifFalse: [ 
+		^ (superclasses indexOf: aTopClass) < superclasses size ].
+
+	^ false
+]
+
+{ #category : #accessing }
+MicDocumentHierarchyBuilder >> topClass [
+
+	^ topClass ifNil: [ self fromClass superclass ]
+]
+
+{ #category : #accessing }
+MicDocumentHierarchyBuilder >> topClass: aClass [
+
+	topClass := aClass
+]

src/Microdown-RichTextComposer/MicRichTextComposer.class.st

@@ -259,6 +259,32 @@ MicRichTextComposer >> codeStylerClass [
 	^ codeStylerClass
 ]
 
+{ #category : #private }
+MicRichTextComposer >> doVisitCode: aCodeBlock [
+
+	self 
+		doVisitCode: aCodeBlock 
+		code: aCodeBlock body
+]
+
+{ #category : #private }
+MicRichTextComposer >> doVisitCode: aCodeBlock code: aStringOrText [
+
+	canvas indentIn: [ 
+		canvas
+			<< ((self codeStylerClass stylerFor: aCodeBlock language)
+					style: aStringOrText );
+			newLine.
+		aCodeBlock hasCaption ifTrue: [ 
+			canvas 
+				includeAttribute: TextEmphasis bold 
+				in: [ 
+					canvas
+						<< aCodeBlock caption asText;
+					newLine ]]].
+	canvas << textStyler interBlockSpacing
+]
+
 { #category : #initialization }
 MicRichTextComposer >> initialize [
 	super initialize.
@@ -377,21 +403,9 @@ MicRichTextComposer >> visitCenter: aMicCenterBlock [
 
 { #category : #visiting }
 MicRichTextComposer >> visitCode: aCodeBlock [
+
 	canvas newLineIfNotAlready.
-	canvas indentIn: [ 
-		canvas
-			<< ((self codeStylerClass stylerFor: aCodeBlock language)
-					style: aCodeBlock body );
-			newLine.
-		aCodeBlock hasCaption ifTrue: [ 
-			canvas 
-				includeAttribute: TextEmphasis bold 
-				in: [ 
-					canvas
-						<< aCodeBlock caption asText;
-					newLine ]]].
-	canvas << textStyler interBlockSpacing
-
+	self doVisitCode: aCodeBlock
 ]
 
 { #category : #'visiting -  format' }
@@ -602,6 +616,41 @@ MicRichTextComposer >> visitParameters: anObject [
 	^ self
 ]
 
+{ #category : #'visiting - extensions' }
+MicRichTextComposer >> visitPharoEvaluator: aScriptBlock [
+	"I execute the body. I handle four types of results:
+	Text - inserted verbatim
+	Microdown tree - rendered to text then inserted verbatim
+	String - Parsed, then rendered, then inserted.
+	Other results - printString asText - then inserted verbatim"
+	| label script doitForm codeText oldCanvas |
+
+	script := aScriptBlock body.
+	label := aScriptBlock label ifNil: [ String value: 1 ].
+
+	oldCanvas := canvas.
+	canvas := MicRichTextCanvas new
+		textStyler: self textStyler;
+		yourself.
+	self doVisitCode: aScriptBlock.
+	codeText := canvas contents trim. 
+	canvas := oldCanvas.	
+
+	codeText addAttribute: (MicRichTextDoIt new 
+		actOnClickBlock: [ self class evaluate: script ];
+		yourself).
+
+	"this is a hack, because the align of the icon is attached to some top-left of the 
+	 letters that I do not understand, and I want it aligned with the actual text"	
+	doitForm := ((Form 
+		extent: 16@22 depth: Display depth) 
+		mergeWith:(self iconNamed: #smallDoIt) at: 0@8)
+		asText.
+
+	canvas << doitForm << codeText.
+	canvas newLineIfNotAlready
+]
+
 { #category : #visiting }
 MicRichTextComposer >> visitQuote: aQuote [
 	"I should have a fancier implementation, but for now this should work and be recognized as a quote"

src/Microdown-RichTextComposer/MicRichTextDoIt.class.st

@@ -0,0 +1,13 @@
+"
+An extension of TextDoIt attribute to be used to display executable code (in the evaluator).
+"
+Class {
+	#name : #MicRichTextDoIt,
+	#superclass : #TextDoIt,
+	#category : #'Microdown-RichTextComposer-Composer'
+}
+
+{ #category : #scanning }
+MicRichTextDoIt >> emphasizeScanner: scanner [
+	"Skip emphasis"
+]

src/Microdown-Tests/MicPharoEvaluatortBlockTest.class.st

@@ -0,0 +1,23 @@
+Class {
+	#name : #MicPharoEvaluatortBlockTest,
+	#superclass : #MicBlockTest,
+	#category : #'Microdown-Tests-Extensions'
+}
+
+{ #category : #tests }
+MicPharoEvaluatortBlockTest >> subjectClass [
+
+	^ MicPharoEvaluatorBlock
+]
+
+{ #category : #tests }
+MicPharoEvaluatortBlockTest >> testScriptBloc [
+
+	| doc |
+	doc := Microdown parse: 
+'```pharoeval
+1 < 3
+```'.
+	self assert: doc children first class equals: MicPharoEvaluatorBlock.
+	self assert: doc children first body equals: '1 < 3'
+]