From 64a8353006a2571aaf1a8b1e9ef968c281ebc408 Mon Sep 17 00:00:00 2001 From: Veit Heller Date: Sun, 17 Apr 2022 20:49:42 +0200 Subject: [PATCH] Add half of a coder --- ...rpCoderBehaviorNameApplyPreviewId.class.st | 10 ++ src/Carp/CarpExpression.class.st | 13 ++ src/Carp/CarpModule.class.st | 102 +++++++++++- src/Carp/CarpModuleCoder.class.st | 30 ++++ src/Carp/CarpModuleCoderElement.class.st | 153 ++++++++++++++++++ src/Carp/CarpModuleCoderViewModel.class.st | 10 ++ .../CarpStreamingMethodsCoderElement.class.st | 31 ++++ 7 files changed, 343 insertions(+), 6 deletions(-) create mode 100644 src/Carp/CarpCoderBehaviorNameApplyPreviewId.class.st create mode 100644 src/Carp/CarpModuleCoder.class.st create mode 100644 src/Carp/CarpModuleCoderElement.class.st create mode 100644 src/Carp/CarpModuleCoderViewModel.class.st create mode 100644 src/Carp/CarpStreamingMethodsCoderElement.class.st diff --git a/src/Carp/CarpCoderBehaviorNameApplyPreviewId.class.st b/src/Carp/CarpCoderBehaviorNameApplyPreviewId.class.st new file mode 100644 index 0000000..ce09b15 --- /dev/null +++ b/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' +] diff --git a/src/Carp/CarpExpression.class.st b/src/Carp/CarpExpression.class.st index 9f4eb74..b891d62 100644 --- a/src/Carp/CarpExpression.class.st +++ b/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 diff --git a/src/Carp/CarpModule.class.st b/src/Carp/CarpModule.class.st index 6b010a5..fdfd5b9 100644 --- a/src/Carp/CarpModule.class.st +++ b/src/Carp/CarpModule.class.st @@ -24,6 +24,94 @@ CarpModule >> addUse: aString [ uses add: aString ] +{ #category : #accessing } +CarpModule >> carpCoderCommentsFor: aView [ + + + ^ 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 [ + + | 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 << ' ' - << (uses ifEmpty: [ '' ] ifNotEmpty: [ - Character lf , Character tab , '(use-all ' - , (' ' join: uses) , ')' ]). + aStream << '(doc ' << self name << ' "' << self documentation + << '")' << Character lf. + aStream << '(defmodule ' << self name << ' ' << (uses + ifEmpty: [ '' ] + ifNotEmpty: [ + Character lf , Character tab , '(use-all ' , (' ' join: uses) + , ')' ]). expressions do: [ :expression | - aStream << Character lf << Character tab - << expression toCarp ]. + aStream << Character lf << Character tab << expression toCarp ]. aStream << ')' ] ] diff --git a/src/Carp/CarpModuleCoder.class.st b/src/Carp/CarpModuleCoder.class.st new file mode 100644 index 0000000..d7c52ab --- /dev/null +++ b/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 +] diff --git a/src/Carp/CarpModuleCoderElement.class.st b/src/Carp/CarpModuleCoderElement.class.st new file mode 100644 index 0000000..baac0ff --- /dev/null +++ b/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 [ + + + 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 +] diff --git a/src/Carp/CarpModuleCoderViewModel.class.st b/src/Carp/CarpModuleCoderViewModel.class.st new file mode 100644 index 0000000..f918bc1 --- /dev/null +++ b/src/Carp/CarpModuleCoderViewModel.class.st @@ -0,0 +1,10 @@ +Class { + #name : #CarpModuleCoderViewModel, + #superclass : #GtSingleCoderViewModel, + #category : #'Carp-Coder' +} + +{ #category : #accessing } +CarpModuleCoderViewModel >> elementClass [ + ^ CarpModuleCoderElement +] diff --git a/src/Carp/CarpStreamingMethodsCoderElement.class.st b/src/Carp/CarpStreamingMethodsCoderElement.class.st new file mode 100644 index 0000000..caa131c --- /dev/null +++ b/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 +]