Add half of a coder

src/Carp/CarpCoderBehaviorNameApplyPreviewId.class.st

@@ -0,0 +1,10 @@
+Class {
+	#name : #CarpCoderBehaviorNameApplyPreviewId,
+	#superclass : #GtCoderElementId,
+	#category : #'Carp-Coder'
+}
+
+{ #category : #accessing }
+CarpCoderBehaviorNameApplyPreviewId >> asSymbol [
+	^ #'carp-coder--module-name-editor'
+]

src/Carp/CarpExpression.class.st

@@ -1,9 +1,22 @@
 Class {
 	#name : #CarpExpression,
 	#superclass : #Object,
+	#instVars : [
+		'documentation'
+	],
 	#category : #'Carp-IDE'
 }
 
+{ #category : #accessing }
+CarpExpression >> documentation [
+	^ documentation ifNil: ['']
+]
+
+{ #category : #accessing }
+CarpExpression >> documentation: aString [
+	documentation := aString
+]
+
 { #category : #converting }
 CarpExpression >> toCarp [
 	^ self subclassResponsibility

src/Carp/CarpModule.class.st

@@ -24,6 +24,94 @@ CarpModule >> addUse: aString [
 	uses add: aString
 ]
 
+{ #category : #accessing }
+CarpModule >> carpCoderCommentsFor: aView [
+
+	<gtModuleView>
+	^ aView explicit
+		  title: 'Documentation';
+		  tooltip: 'Module Documentation';
+		  priority: 30;
+		  disableAsync;
+		  stencil: [ 
+			  | snippet snippetViewModel |
+			  snippet := LeTextSnippet string: self documentation.
+			  snippetViewModel := snippet asSnippetViewModel.
+			  snippetViewModel coderViewModel addShortcut:
+					  (BrEditorShortcut lineEnding combination:
+							   (LeSnippetElement keyboardShortcut: #NewLine)).
+			  snippetViewModel coderViewModel addShortcut:
+					  (BlShortcutWithAction new
+						   combination: BlKeyCombination primaryS;
+						   action: [ :anEvent | 
+							   self documentation: anEvent currentTarget text asString ]).
+			  ((snippetViewModel snippetView needsEmbellishments: false)
+				   asElement snippetViewModel: snippetViewModel) vMatchParent ];
+		  actionButtonIcon: BrGlamorousVectorIcons accept
+		  tooltip: 'Save documentation'
+		  action: [ :aToggle :aTab | 
+			  self documentation:
+				  aTab viewContentElement children first text asString ];
+		  actionUpdateButtonTooltip: 'Update documentation'
+]
+
+{ #category : #accessing }
+CarpModule >> carpCoderStreamingMethodsFor: aView context: aPhlowContext [
+	<gtModuleView>
+	| aMethodsCoder aMethodsCoderViewModel aNewMethodCoderHolder |
+	
+	aMethodsCoder := GtStreamingCodersModel new.
+	aMethodsCoderViewModel := GtStreamingCodersViewModel new streamingCodersModel: aMethodsCoder.
+		
+	aNewMethodCoderHolder := ValueHolder new.
+
+	^ aView explicit
+		priority: 9;
+		title: 'Methods';
+		disableAsync;
+		actionDropdownButtonDo: [ :aDrodownAction | 
+			aDrodownAction dropdown 
+				icon: BrGlamorousVectorIcons add;
+				tooltip: 'Add new expression';
+				content: [ :aButton |
+					| aNewMethodCoder aNewMethodCoderViewModel aHandler |
+
+					aNewMethodCoderHolder contents
+						ifNotNil: [ :aContents |
+							aNewMethodCoderViewModel := aContents ]
+						ifNil: [
+					
+						aNewMethodCoder := GtCarpCoderModel new.
+
+						aNewMethodCoderViewModel := aNewMethodCoder asCoderViewModel.
+						aNewMethodCoderViewModel
+							withoutHeader;
+							expanded: true;
+							focused: true;
+							moveCursorAtEnd.
+						
+						aNewMethodCoderHolder contents: aNewMethodCoderViewModel.
+
+						aHandler := GtPharoNewMethodCodeSavedHandler new
+							methodsCoderViewModel: aMethodsCoderViewModel;
+							element: aButton;
+							methodCoderHolder: aNewMethodCoderHolder.
+						
+						aNewMethodCoderViewModel weak
+							when: GtMethodCoderSaved
+							send: #onAnnouncement:
+							to: aHandler ].
+
+						(GtExpandedOnlyCoderElement new coderViewModel: aNewMethodCoderViewModel)
+							hExact: 300;
+							vFitContent;
+							background: Color white;
+							padding: (BlInsets all: 5);
+							addAptitude: BrGlamorousFocusableShadowAptitude new ];
+				name: #'button--add-new-expression'];
+		stencil: [ CarpStreamingMethodsCoderElement new streamingCodersViewModel: aMethodsCoderViewModel ]
+]
+
 { #category : #initialization }
 CarpModule >> initialize [
 	uses := Set new.
@@ -44,12 +132,14 @@ CarpModule >> name: aString [
 CarpModule >> toCarp [
 
 	^ String streamContents: [ :aStream | 
-		  aStream << '(defmodule ' << self name << ' '
+		  aStream << '(doc ' << self name << ' "' << self documentation
-		  << (uses ifEmpty: [ '' ] ifNotEmpty: [ 
+		  << '")' << Character lf.
-				   Character lf , Character tab , '(use-all '
+		  aStream << '(defmodule ' << self name << ' ' << (uses
-				   , (' ' join: uses) , ')' ]).
+			   ifEmpty: [ '' ]
+			   ifNotEmpty: [ 
+			   Character lf , Character tab , '(use-all ' , (' ' join: uses)
+			   , ')' ]).
 		  expressions do: [ :expression | 
-			  aStream << Character lf << Character tab
+			  aStream << Character lf << Character tab << expression toCarp ].
-			  << expression toCarp ].
 		  aStream << ')' ]
 ]

src/Carp/CarpModuleCoder.class.st

@@ -0,0 +1,30 @@
+Class {
+	#name : #CarpModuleCoder,
+	#superclass : #GtCoderModel,
+	#traits : 'TGtCoderTrait',
+	#classTraits : 'TGtCoderTrait classTrait',
+	#instVars : [
+		'module'
+	],
+	#category : #'Carp-Coder'
+}
+
+{ #category : #'instance creation' }
+CarpModuleCoder class >> forModule: aCarpModule [
+	^ self new module: aCarpModule
+]
+
+{ #category : #accessing }
+CarpModuleCoder >> asCoderViewModel [
+	^ CarpModuleCoderViewModel new coder: self
+]
+
+{ #category : #'instance creation' }
+CarpModuleCoder >> module [
+	^ module
+]
+
+{ #category : #'instance creation' }
+CarpModuleCoder >> module: aCarpModule [ 
+	module := aCarpModule
+]

src/Carp/CarpModuleCoderElement.class.st

@@ -0,0 +1,153 @@
+Class {
+	#name : #CarpModuleCoderElement,
+	#superclass : #BlElement,
+	#traits : 'TBrLayoutResizable',
+	#classTraits : 'TBrLayoutResizable classTrait',
+	#instVars : [
+		'carpCoderViewModel',
+		'container',
+		'contentPane',
+		'contentTabs'
+	],
+	#category : #'Carp-Coder'
+}
+
+{ #category : #accessing }
+CarpModuleCoderElement >> buildContentPane [
+
+	contentPane := BlElement new.
+	contentPane layout: BlLinearLayout vertical.
+	contentPane constraintsDo: [ :c | 
+		c horizontal matchParent.
+		c vertical matchParent ].
+	contentPane padding: (BlInsets top: 5 left: 6 bottom: 5 right: 6).
+	contentPane addChild: self buildModuleLabel.
+	contentPane addChild: self buildDefinitionElement.
+	contentPane addChild: self buildContentTabs.
+
+	^ contentPane
+]
+
+{ #category : #accessing }
+CarpModuleCoderElement >> buildContentTabs [
+	<return: #BrTabGroup>
+
+	contentTabs := GtPhlowCompositeView new
+		views: self classViewItems;
+		asElementDo: [ :aBrTabGroup | aBrTabGroup ].
+
+	^ contentTabs
+]
+
+{ #category : #accessing }
+CarpModuleCoderElement >> buildDefinitionElement [
+	^ BrExpander new
+]
+
+{ #category : #accessing }
+CarpModuleCoderElement >> buildModuleLabel [
+	| classCoder aModuleNameEditor aContainer aPreviewButton removeClassButton |
+
+	aContainer := BrHorizontalPane new
+		hMatchParent;
+		alignCenterLeft;
+		vFitContent.
+	
+	aModuleNameEditor := BrEditableLabel new
+		aptitude: (BrGlamorousEditableLabelAptitude new
+			defaultBackground: Color transparent;
+			glamorousCodeFont;
+			bold;
+			fontSize: 18);
+		inputFilter: BrTextEditorClassNameInputFilter new;
+		text: self module name;
+		margin: (BlInsets all: 0);
+		id: GtBehaviorCoderBehaviorNameId;
+		whenKey: BlKeyCombination primaryG
+			labelDo: [ :aShortcutEvent | self phlow spawnObject: self module ];
+		whenKey: BlKeyCombination primaryR
+			labelDo: [ :aShortcutEvent | aShortcutEvent currentTarget switchToEditor ];
+		whenKey: BlKeyCombination primaryC
+			labelDo: [ :aShortcutEvent | Clipboard clipboardText: self module name asString ].
+
+	aPreviewButton := BrButton new
+		id: CarpCoderBehaviorNameApplyPreviewId;
+		margin: (BlInsets left: 5);
+		addAptitude: BrGlamorousButtonWithIconAptitude;
+		icon: BrGlamorousVectorIcons accept;
+		action: [self module name: aModuleNameEditor text].
+
+	aModuleNameEditor editor
+		when: BrTextEditorModifiedEvent 
+		do: [ :anEvent |
+			anEvent text asString trimBoth asSymbol = self module name
+				ifTrue: [ aContainer removeChild: aPreviewButton ]
+				ifFalse: [
+					"show preview button when name is modified"
+					(aContainer hasChild: aPreviewButton)
+						ifFalse: [ aContainer addChild: aPreviewButton after: aModuleNameEditor ] ] ].
+
+	aContainer addChild: aModuleNameEditor.
+
+	^ aContainer
+]
+
+{ #category : #accessing }
+CarpModuleCoderElement >> classViewItems [
+	| classCoder collector context |
+	
+	classCoder := carpCoderViewModel coder.
+	
+	collector := GtPhlowViewsCollector new
+		fromObject: classCoder module;
+		from: classCoder module class;
+		to: Behavior;
+		pragmaName: #gtModuleView.
+
+	context := GtPhlowContext new.
+	context optionAt: #carpCoder put: carpCoderViewModel.
+
+	collector context: context.
+
+	^ collector collect
+]
+
+{ #category : #accessing }
+CarpModuleCoderElement >> coderViewModel: aCarpCoderViewModel [
+	
+	carpCoderViewModel ifNotNil: [ :aPreviousCoderViewModel | aPreviousCoderViewModel unsubscribe: self ].
+	
+	carpCoderViewModel := aCarpCoderViewModel.
+	"carpCoderViewModel coder weak
+		when: GtCoderPackageUpdatedAnnouncement
+			send: #actOnPackageUpdated:
+			to: self;
+		when: GtClassCoderMethodNavigationAnnouncement
+			send: #actOnSelectMethod:
+			to: self;
+		when: GtClassCoderMethodProtocolNavigationAnnouncement
+			send: #actOnMethodProtocol:
+			to: self."
+
+	container ifNotNil: #removeFromParent.
+	container := self buildContentPane.
+	self addChildFirst: container
+]
+
+{ #category : #accessing }
+CarpModuleCoderElement >> initialize [
+	super initialize.
+
+	self
+		layout: BlLinearLayout vertical;
+		constraintsDo: [ :c | 
+			c horizontal matchParent.
+			c vertical matchParent ].
+		
+	self when: BlClickEvent do: [ self requestFocus ]
+]
+
+{ #category : #accessing }
+CarpModuleCoderElement >> module [
+	^ carpCoderViewModel coder module
+]

src/Carp/CarpModuleCoderViewModel.class.st

@@ -0,0 +1,10 @@
+Class {
+	#name : #CarpModuleCoderViewModel,
+	#superclass : #GtSingleCoderViewModel,
+	#category : #'Carp-Coder'
+}
+
+{ #category : #accessing }
+CarpModuleCoderViewModel >> elementClass [
+	^ CarpModuleCoderElement
+]

src/Carp/CarpStreamingMethodsCoderElement.class.st

@@ -0,0 +1,31 @@
+Class {
+	#name : #CarpStreamingMethodsCoderElement,
+	#superclass : #BlElement,
+	#traits : 'TBrLayoutResizable + TGtWithStreamingCodersViewModel',
+	#classTraits : 'TBrLayoutResizable classTrait + TGtWithStreamingCodersViewModel classTrait',
+	#instVars : [
+		'listItemsProvider',
+		'list'
+	],
+	#category : #'Carp-Coder'
+}
+
+{ #category : #accessing }
+CarpStreamingMethodsCoderElement >> initialize [
+	super initialize.
+	
+	self matchParent.
+	
+	listItemsProvider := BrListStreamItemsProvider new stream: AsyncEmptyStream new.
+
+	list := BrSimpleList new
+		itemType: [ :anItemTypeFactory :anItemObject | anItemObject elementClass ];
+		itemStencil: [ :anElementClass | anElementClass new id: GtSourceCoderId ];
+		itemDataBinder: [ :aCoderElement :aCoderViewModel |
+			BlFrameTelemetry
+				time: [ 'Set {1} as a view model of {2}' format: { aCoderViewModel class name . aCoderElement class name } ]
+				during: [ aCoderElement textualCoderViewModel: aCoderViewModel ] ];
+		itemsProvider: listItemsProvider.
+	
+	self addChild: list
+]