From 9a0afa4f1921fa1516fec3fe27ef8e22b261d821 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Thu, 9 Jan 2025 17:43:06 +0100 Subject: [PATCH 1/7] Port Hernan's snapshot browser to Iceberg --- BaselineOfIceberg/BaselineOfIceberg.class.st | 4 + .../IceSBBrowseFullClassCommand.class.st | 25 + .../IceSBBrowseFullMethodCommand.class.st | 25 + .../IceSBBrowseHierarchyClassCommand.class.st | 25 + ...IceSBBrowseHierarchyMethodCommand.class.st | 27 + ...SBBrowseMethodImplementorsCommand.class.st | 25 + ...eSBBrowseMethodInheritanceCommand.class.st | 28 + .../IceSBBrowseMethodSendersCommand.class.st | 19 + .../IceSBBrowseMethodVersionsCommand.class.st | 27 + .../IceSBBrowserAbstractClassCommand.class.st | 12 + ...IceSBBrowserAbstractMethodCommand.class.st | 26 + .../IceSBCopySelectorCommand.class.st | 21 + .../IceSBFileOutMethodCommand.class.st | 19 + .../IceSBLoadCategoryCommand.class.st | 39 + .../IceSBLoadClassCommand.class.st | 37 + .../IceSBLoadMethodCommand.class.st | 25 + .../IceSBLoadProtocolCommand.class.st | 31 + .../IceSnapshotBrowser.class.st | 559 +++++++++++++ .../IceSnapshotBrowserCommand.class.st | 25 + .../MCSnapshotBrowser.class.st | 784 ++++++++++++++++++ .../MCVersion.extension.st | 7 + Iceberg-TipUI-SnapshotBrowser/package.st | 1 + .../IceSnapshotBrowserTest.class.st | 349 ++++++++ .../package.st | 1 + 24 files changed, 2141 insertions(+) create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullClassCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullMethodCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyClassCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyMethodCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodImplementorsCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodInheritanceCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodSendersCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodVersionsCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractClassCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractMethodCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBCopySelectorCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBFileOutMethodCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBLoadCategoryCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBLoadMethodCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSBLoadProtocolCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowserCommand.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/MCVersion.extension.st create mode 100644 Iceberg-TipUI-SnapshotBrowser/package.st create mode 100644 Iceberg-TipUi-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st create mode 100644 Iceberg-TipUi-SnapshotBrowser-Tests/package.st diff --git a/BaselineOfIceberg/BaselineOfIceberg.class.st b/BaselineOfIceberg/BaselineOfIceberg.class.st index 53f150158b..6b23321f36 100644 --- a/BaselineOfIceberg/BaselineOfIceberg.class.st +++ b/BaselineOfIceberg/BaselineOfIceberg.class.st @@ -28,11 +28,13 @@ BaselineOfIceberg >> baseline: spec [ package: 'Iceberg-Plugin-Migration' with: [ spec requires: #('Iceberg-Plugin') ]; package: 'Iceberg-Metacello-Integration' with: [ spec requires: #('Iceberg')]; package: 'Iceberg-TipUI' with: [ spec requires: #('Iceberg') ]; + package: 'Iceberg-TipUi-SnapshotBrowser'; package: 'Iceberg-Memory' with: [ spec requires: #('Iceberg') ]; "tests" package: 'Iceberg-Tests' with: [ spec requires: #('Iceberg' 'Iceberg-Memory') ]; package: 'Iceberg-Tests-MetacelloIntegration' with: [ spec requires: #('Iceberg-Tests') ]; package: 'Iceberg-UI-Tests' with: [ spec requires: #('Iceberg-TipUI' 'Iceberg-Tests')]; + package: 'Iceberg-TipUi-SnapshotBrowser-Tests' with: [ spec requires: #( 'Iceberg-TipUi-SnapshotBrowser' ) ]; package: 'Iceberg-Plugin-Migration-Tests' with: [ spec requires: #('Iceberg-Plugin-Migration' 'Iceberg-Tests') ]; "libgit" package: 'Iceberg-Libgit' with: [ spec requires: #('Iceberg' 'LibGit') ]; @@ -43,6 +45,7 @@ BaselineOfIceberg >> baseline: spec [ minimal 'Iceberg-Metacello-Integration' 'Iceberg-TipUI' + 'Iceberg-TipUi-SnapshotBrowser' 'Iceberg-Plugin' 'Iceberg-Plugin-Metacello' 'Iceberg-Plugin-GitHub' @@ -58,6 +61,7 @@ BaselineOfIceberg >> baseline: spec [ 'Iceberg-Tests-MetacelloIntegration' 'LibGit-Tests' 'Iceberg-UI-Tests' + 'Iceberg-TipUi-SnapshotBrowser-Tests' 'Iceberg-Plugin-Migration-Tests' ); group: 'development' with: #(default allTests) ]. diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullClassCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullClassCommand.class.st new file mode 100644 index 0000000000..33ebb7e362 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullClassCommand.class.st @@ -0,0 +1,25 @@ +Class { + #name : 'IceSBBrowseFullClassCommand', + #superclass : 'IceSBBrowserAbstractClassCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBBrowseFullClassCommand class >> defaultName [ + + ^ 'Browse full' +] + +{ #category : 'testing' } +IceSBBrowseFullClassCommand >> canBeExecuted [ + + ^ super canBeExecuted and: [ self selectedClassIsLoaded ] +] + +{ #category : 'executing' } +IceSBBrowseFullClassCommand >> execute [ + "Browse the selected class" + + (self class environment at: self selectedClass) browse +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullMethodCommand.class.st new file mode 100644 index 0000000000..b881ca5fdc --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullMethodCommand.class.st @@ -0,0 +1,25 @@ +Class { + #name : 'IceSBBrowseFullMethodCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBBrowseFullMethodCommand class >> defaultName [ + + ^ 'Browse full' +] + +{ #category : 'testing' } +IceSBBrowseFullMethodCommand >> canBeExecuted [ + + ^ super canBeExecuted and: [ self selectedClassIsLoaded ] +] + +{ #category : 'executing' } +IceSBBrowseFullMethodCommand >> execute [ + "Browse the selected method" + + self selectedMethod browse +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyClassCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyClassCommand.class.st new file mode 100644 index 0000000000..eb1a8fca05 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyClassCommand.class.st @@ -0,0 +1,25 @@ +Class { + #name : 'IceSBBrowseHierarchyClassCommand', + #superclass : 'IceSBBrowserAbstractClassCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBBrowseHierarchyClassCommand class >> defaultName [ + + ^ 'Browse hierarchy' +] + +{ #category : 'testing' } +IceSBBrowseHierarchyClassCommand >> canBeExecuted [ + + ^ super canBeExecuted and: [ self class environment hasClassNamed: self selectedClass ] +] + +{ #category : 'executing' } +IceSBBrowseHierarchyClassCommand >> execute [ + "Browse the selected class" + + (self class environment at: self selectedClass) browseHierarchy +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyMethodCommand.class.st new file mode 100644 index 0000000000..a5b432d821 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyMethodCommand.class.st @@ -0,0 +1,27 @@ +Class { + #name : 'IceSBBrowseHierarchyMethodCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBBrowseHierarchyMethodCommand class >> defaultName [ + + ^ 'Browse hierarchy...' +] + +{ #category : 'testing' } +IceSBBrowseHierarchyMethodCommand >> canBeExecuted [ + + ^ super canBeExecuted and: [ self selectedClassIsLoaded ] +] + +{ #category : 'executing' } +IceSBBrowseHierarchyMethodCommand >> execute [ + "Browse the selected method" + + self systemNavigation + browseHierarchy: context selectedClassOrMetaClass + selector: context selectedMessageName +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodImplementorsCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodImplementorsCommand.class.st new file mode 100644 index 0000000000..47d4fff32c --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodImplementorsCommand.class.st @@ -0,0 +1,25 @@ +Class { + #name : 'IceSBBrowseMethodImplementorsCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBBrowseMethodImplementorsCommand class >> defaultName [ + + ^ 'Browse inheritance' +] + +{ #category : 'testing' } +IceSBBrowseMethodImplementorsCommand >> canBeExecuted [ + + ^ super canBeExecuted and: [ self selectedClassIsLoaded ] +] + +{ #category : 'executing' } +IceSBBrowseMethodImplementorsCommand >> execute [ + "Browse implementors of the selected method" + + self systemNavigation browseAllImplementorsOf: (context selectedMessageName ifNil: [ ^nil ]) +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodInheritanceCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodInheritanceCommand.class.st new file mode 100644 index 0000000000..6b5d86313d --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodInheritanceCommand.class.st @@ -0,0 +1,28 @@ +Class { + #name : 'IceSBBrowseMethodInheritanceCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBBrowseMethodInheritanceCommand class >> defaultName [ + + ^ 'Browse implementors' +] + +{ #category : 'testing' } +IceSBBrowseMethodInheritanceCommand >> canBeExecuted [ + + ^ super canBeExecuted and: [ self selectedClassIsLoaded ] +] + +{ #category : 'executing' } +IceSBBrowseMethodInheritanceCommand >> execute [ + "Browse implementors of the selected method" + + self systemNavigation + methodHierarchyBrowserForClass: context selectedClassOrMetaClass + selector: context selectedMessageName + +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodSendersCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodSendersCommand.class.st new file mode 100644 index 0000000000..e5b1292d50 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodSendersCommand.class.st @@ -0,0 +1,19 @@ +Class { + #name : 'IceSBBrowseMethodSendersCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBBrowseMethodSendersCommand class >> defaultName [ + + ^ 'Browse senders' +] + +{ #category : 'executing' } +IceSBBrowseMethodSendersCommand >> execute [ + "Browse senders of the selected method" + + self selectedMethod browseSenders +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodVersionsCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodVersionsCommand.class.st new file mode 100644 index 0000000000..92c2c7f7e9 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodVersionsCommand.class.st @@ -0,0 +1,27 @@ +Class { + #name : 'IceSBBrowseMethodVersionsCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBBrowseMethodVersionsCommand class >> defaultName [ + + ^ 'Versions' +] + +{ #category : 'testing' } +IceSBBrowseMethodVersionsCommand >> canBeExecuted [ + + ^ super canBeExecuted and: [ self selectedClassIsLoaded ] +] + +{ #category : 'executing' } +IceSBBrowseMethodVersionsCommand >> execute [ + "Browse versions of the selected method" + + self tools versionBrowser + browseVersionsForClass: context selectedClassOrMetaClass + selector: context selectedMessageName +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractClassCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractClassCommand.class.st new file mode 100644 index 0000000000..08e8248440 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractClassCommand.class.st @@ -0,0 +1,12 @@ +Class { + #name : 'IceSBBrowserAbstractClassCommand', + #superclass : 'IceSnapshotBrowserCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'testing' } +IceSBBrowserAbstractClassCommand >> canBeExecuted [ + + ^ self selectedClass notNil +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractMethodCommand.class.st new file mode 100644 index 0000000000..ebaa469a64 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractMethodCommand.class.st @@ -0,0 +1,26 @@ +Class { + #name : 'IceSBBrowserAbstractMethodCommand', + #superclass : 'IceSnapshotBrowserCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'testing' } +IceSBBrowserAbstractMethodCommand >> canBeExecuted [ + + ^ self selectedMethod notNil +] + +{ #category : 'accessing - selection' } +IceSBBrowserAbstractMethodCommand >> selectedMethod [ + "Answer the actual selected " + + ^ self selectedMethodDefinition method +] + +{ #category : 'accessing - selection' } +IceSBBrowserAbstractMethodCommand >> selectedMethodDefinition [ + "Answer the currently selected " + + ^ context selectedMethod +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBCopySelectorCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBCopySelectorCommand.class.st new file mode 100644 index 0000000000..197922d6c7 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBCopySelectorCommand.class.st @@ -0,0 +1,21 @@ +Class { + #name : 'IceSBCopySelectorCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBCopySelectorCommand class >> defaultName [ + + ^ 'Copy selector' +] + +{ #category : 'executing' } +IceSBCopySelectorCommand >> execute [ + "Browse the selected method" + + Clipboard + clipboardText: self selectedMethod selector + informing: ('Selector {1} copied to clipboard' format: { self selectedMethod selector }) +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBFileOutMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBFileOutMethodCommand.class.st new file mode 100644 index 0000000000..7b2f2bb720 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBFileOutMethodCommand.class.st @@ -0,0 +1,19 @@ +Class { + #name : 'IceSBFileOutMethodCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBFileOutMethodCommand class >> defaultName [ + + ^ 'File out' +] + +{ #category : 'executing' } +IceSBFileOutMethodCommand >> execute [ + "File out the selected method" + + context fileOutMessage +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBLoadCategoryCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadCategoryCommand.class.st new file mode 100644 index 0000000000..35047f6f66 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadCategoryCommand.class.st @@ -0,0 +1,39 @@ +Class { + #name : 'IceSBLoadCategoryCommand', + #superclass : 'IceSnapshotBrowserCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBLoadCategoryCommand class >> defaultName [ + + ^ 'Load category...' +] + +{ #category : 'testing' } +IceSBLoadCategoryCommand >> canBeExecuted [ + + ^ self categorySelection notNil +] + +{ #category : 'executing' } +IceSBLoadCategoryCommand >> categorySelection [ + + ^ context categorySelection +] + +{ #category : 'executing' } +IceSBLoadCategoryCommand >> execute [ + "Load the entire selected category" + + self methodsForSelectedClassCategory + do: [ :m | m load ] + displayingProgress: 'Loading definitions...' +] + +{ #category : 'executing' } +IceSBLoadCategoryCommand >> methodsForSelectedClassCategory [ + + ^ context methodsForSelectedClassCategory +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st new file mode 100644 index 0000000000..5c57924399 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st @@ -0,0 +1,37 @@ +Class { + #name : 'IceSBLoadClassCommand', + #superclass : 'IceSBBrowserAbstractClassCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBLoadClassCommand class >> defaultName [ + + ^ 'Load class...' +] + +{ #category : 'executing' } +IceSBLoadClassCommand >> execute [ + "Load the selected class" + + self packageClasses + detect: [ :ea | ea className = self selectedClass ] + ifFound: [ :packageClass | + packageClass load. + self methodsForSelectedClass + do: [ :m | m load ] + displayingProgress: 'Loading definitions...' ] +] + +{ #category : 'executing' } +IceSBLoadClassCommand >> methodsForSelectedClass [ + + ^ context methodsForSelectedClass +] + +{ #category : 'executing' } +IceSBLoadClassCommand >> packageClasses [ + + ^ context packageClasses +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBLoadMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadMethodCommand.class.st new file mode 100644 index 0000000000..043d37986b --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadMethodCommand.class.st @@ -0,0 +1,25 @@ +Class { + #name : 'IceSBLoadMethodCommand', + #superclass : 'IceSBBrowserAbstractMethodCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBLoadMethodCommand class >> defaultName [ + + ^ 'Load method...' +] + +{ #category : 'testing' } +IceSBLoadMethodCommand >> canBeExecuted [ + + ^ super canBeExecuted and: [ self selectedMethodDefinition isLoadable ] +] + +{ #category : 'executing' } +IceSBLoadMethodCommand >> execute [ + "Load the selected method" + + self selectedMethod load +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBLoadProtocolCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadProtocolCommand.class.st new file mode 100644 index 0000000000..80ded04873 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadProtocolCommand.class.st @@ -0,0 +1,31 @@ +Class { + #name : 'IceSBLoadProtocolCommand', + #superclass : 'IceSnapshotBrowserCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'default' } +IceSBLoadProtocolCommand class >> defaultName [ + + ^ 'Load protocol...' +] + +{ #category : 'testing' } +IceSBLoadProtocolCommand >> canBeExecuted [ + + ^ self selectedProtocol notNil +] + +{ #category : 'executing' } +IceSBLoadProtocolCommand >> execute [ + "Load the selected protocol" + + self selectedProtocol load +] + +{ #category : 'accessing - selection' } +IceSBLoadProtocolCommand >> selectedProtocol [ + + ^ context protocolSelection +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st new file mode 100644 index 0000000000..0d456c7ec4 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st @@ -0,0 +1,559 @@ +Class { + #name : 'IceSnapshotBrowser', + #superclass : 'StPresenter', + #instVars : [ + 'srcCodePresenter', + 'classesPresenter', + 'protocolsPresenter', + 'methodsPresenter', + 'items', + 'classOrInstanceSelectorPresenter', + 'categoriesPresenter', + 'commentPresenter', + 'classDefinitionPresenter', + 'titleString' + ], + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'commands' } +IceSnapshotBrowser class >> buildCommandsGroupWith: presenterInstance forRoot: rootCommandGroup [ + + super + buildCommandsGroupWith: presenterInstance + forRoot: rootCommandGroup. + rootCommandGroup + "Package category commands" + register: ((CmCommandGroup named: 'MCCategorySelContextualMenu') asSpecGroup + register: ((IceSBLoadCategoryCommand + forSpecWithIconNamed: #smallLoadProject + shortcutKey: 'K' asShortcut) context: presenterInstance); + beDisplayedAsGroup; + yourself); + + "Class commands" + register: ((CmCommandGroup named: 'MCClassSelContextualMenu') asSpecGroup + register: ((IceSBLoadClassCommand + forSpecWithIconNamed: #smallLoadProject + shortcutKey: 'C' asShortcut) context: presenterInstance); + register: ((IceSBBrowseFullClassCommand + forSpecWithIconNamed: #browse + shortcutKey: 'B' asShortcut) context: presenterInstance); + register: ((IceSBBrowseHierarchyClassCommand + forSpecWithIconNamed: #smallHierarchyBrowser + shortcutKey: 'H' asShortcut) context: presenterInstance); + beDisplayedAsGroup; + yourself); + + "Protocol commands" + register: ((CmCommandGroup named: 'MCProtocolsSelContextualMenu') asSpecGroup + register: ((IceSBLoadProtocolCommand + forSpecWithIconNamed: #smallLoadProject + shortcutKey: 'P' asShortcut) context: presenterInstance); + beDisplayedAsGroup; + yourself); + + "Method commands" + register: ((CmCommandGroup named: 'MCMethodsSelContextualMenu') asSpecGroup + register: ((IceSBLoadMethodCommand + forSpecWithIconNamed: #smallLoadProject + shortcutKey: 'B' asShortcut) context: presenterInstance); + register: ((IceSBBrowseFullMethodCommand + forSpecWithIconNamed: #browse + shortcutKey: 'M' asShortcut) context: presenterInstance); + register: ((IceSBBrowseHierarchyMethodCommand + forSpecWithIconNamed: #smallHierarchyBrowser + shortcutKey: 'Y' asShortcut) context: presenterInstance); + register: ((IceSBBrowseMethodImplementorsCommand + forSpecWithIconNamed: #browseMethodImplementors + shortcutKey: 'T' asShortcut) context: presenterInstance); + register: ((IceSBBrowseMethodInheritanceCommand + forSpecWithIconNamed: #browseMethodInheritance + shortcutKey: 'E' asShortcut) context: presenterInstance); + register: ((IceSBBrowseMethodVersionsCommand + forSpecWithIconNamed: #versionControl + shortcutKey: 'V' asShortcut) context: presenterInstance); + register: ((IceSBFileOutMethodCommand + forSpecWithIconNamed: #save + shortcutKey: 'O' asShortcut) context: presenterInstance); + register: ((IceSBCopySelectorCommand + forSpecWithIconNamed: #smallCopy + shortcutKey: 'C' asShortcut) context: presenterInstance); + beDisplayedAsGroup; + yourself) +] + +{ #category : 'instance creation' } +IceSnapshotBrowser class >> forSnapshot: aMCSnapshot [ + + ^ self on: aMCSnapshot +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> allClassNames [ + ^ (items + select: [:ea | (ea isOrganizationDefinition | ea isScriptDefinition) not] + thenCollect: [:ea | ea className]) asSet. + +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> browserTitle [ + + ^ 'Snapshot Browser for: ' , titleString +] + +{ #category : 'listing' } +IceSnapshotBrowser >> categorySelection [ + + ^ categoriesPresenter selectedItem +] + +{ #category : 'text' } +IceSnapshotBrowser >> classCommentString [ + ^ items + detect: [ :ea | ea isClassDefinition and: [ ea className = self classSelection ] ] + ifFound: [ :classDefinition | classDefinition comment ] + ifNone: [ '' ] +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> classDefinitionString [ + + | defs | + defs := items select: [:ea | (ea isClassDefinition or: [ea isClassDefinitionExtension]) + and: [ea className = self classSelection]]. + + defs isEmpty ifTrue: [^ 'This class is defined elsewhere.']. + + ^ String streamContents: [:stream | + defs asArray sort + do: [:ea | ea printDefinitionOn: stream] + separatedBy: [stream nextPut: $.; cr] ]. +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> classSelection [ + + ^ classesPresenter selectedItem +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> classTarget: aClass [ + + ^ self isClassSide + ifTrue: [ aClass class ] + ifFalse: [ aClass ] +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> connectPresenters [ + + categoriesPresenter + transmitTo: classesPresenter + transform: [ : aCategory | + aCategory + ifNotNil: [ self visibleClasses ] + ifNil: [ Array empty ] ]. + + classesPresenter + transmitTo: protocolsPresenter + transform: [ : aClass | aClass + ifNotNil: [ self visibleProtocols ] + ifNil: [ Array empty ] ]. + + classesPresenter + transmitTo: classDefinitionPresenter + transform: [ : aClass | self classDefinitionString ] + postTransmission: [ : p | p unselectAll. ]. + + protocolsPresenter + transmitTo: methodsPresenter + transform: [ : aProtocolName | + aProtocolName + ifNotNil: [ self visibleMethods ] + ifNil: [ Array empty ] ]. + + methodsPresenter + transmitTo: srcCodePresenter + transform: [ :aMethod | + aMethod + ifNotNil: [ self updateSourceCode: aMethod ] + ifNil: [ '' ] ] + postTransmission: [ : p | p unselectAll. ] +] + +{ #category : 'layout' } +IceSnapshotBrowser >> defaultLayout [ + + ^ SpPanedLayout newTopToBottom + add: (SpBoxLayout newLeftToRight + spacing: self spacingBetweenPanes; + add: categoriesPresenter; + add: classesPresenter; + add: (SpBoxLayout newTopToBottom + add: protocolsPresenter; + add: classOrInstanceSelectorPresenter expand: false; + yourself); + add: methodsPresenter; + yourself); + add: (SpBoxLayout newLeftToRight + spacing: self spacingBetweenPanes; + add: (SpBoxLayout newTopToBottom + spacing: self spacingBetweenPanes; + add: classDefinitionPresenter; + add: commentPresenter; + yourself); + add: srcCodePresenter; + yourself); + yourself +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> extensionClassNames [ + ^ (self allClassNames difference: self packageClassNames) asSortedCollection +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> extensionsCategory [ + ^ '*Extensions' +] + +{ #category : 'file in/out' } +IceSnapshotBrowser >> fileOutMessage [ + "Put a description of the selected message on a file" + + | fileName | + self selectedMessageName ifNotNil: [ + Cursor write showWhile: [ + self selectedClassOrMetaClass fileOutMethod: self selectedMessageName ]. + ^ self ]. + items isEmpty ifTrue: [ ^ self ]. + fileName := MorphicUIManager new + request: 'File out on which file?' + initialAnswer: 'methods'. + Cursor write showWhile: [ + | internalStream | + internalStream := WriteStream on: (String new: 1000). + internalStream + header; + timeStamp. + items do: [ :patchOp | + patchOp definition isMethodDefinition ifTrue: [ + (patchOp definition actualClass isNotNil and: [ + patchOp definition actualClass includesSelector: + patchOp definition selector ]) + ifTrue: [ + patchOp definition actualClass + printMethodChunk: patchOp definition selector + on: internalStream ] + ifFalse: [ + internalStream nextChunkPut: + patchOp definition className , ' removeSelector: ' + , patchOp definition selector printString ] ]. + patchOp definition isClassDefinition ifTrue: [ + patchOp definition actualClass + ifNotNil: [ + internalStream nextChunkPut: + patchOp definition actualClass definition. + patchOp definition comment ifNotNil: [ + patchOp definition actualClass putCommentOnFile: internalStream ] ] + ifNil: [ + internalStream nextChunkPut: + patchOp definition className , ' removeFromSystem' ] ] ]. + CodeExporter + writeSourceCodeFrom: internalStream + baseName: fileName + isSt: true ] +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> hasExtensions [ + ^ self extensionClassNames notEmpty +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeCategoriesPresenter [ + + categoriesPresenter := self newFilteringList. + categoriesPresenter + items: self visibleCategories; + headerTitle: 'Categories'; + displayIcon: [ : aPackage | self iconNamed: aPackage systemIconName ]; + sortingBlock: [ :a :b | a < b ] ; + contextMenu: [ (self rootCommandsGroup / 'MCCategorySelContextualMenu') beRoot asMenuPresenter ]. + +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeClassDefinitionPresenter [ + + classDefinitionPresenter := self newCode + beNotEditable; + yourself. +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeClassesPresenter [ + + classesPresenter := self newFilteringList. + classesPresenter + items: self visibleClasses; + headerTitle: 'Classes'; + displayIcon: [ :aClass | self iconNamed: aClass systemIconName ]; + sortingBlock: [ :a :b | a < b ]; + contextMenu: [ (self rootCommandsGroup / 'MCClassSelContextualMenu') beRoot asMenuPresenter ] +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeCodePresenter [ + + srcCodePresenter := self newCode + beNotEditable; + withoutSyntaxHighlight; + withLineNumbers; + yourself. +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeCommentPresenter [ + + commentPresenter := self newText +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeMethodsPresenter [ + + methodsPresenter := self newFilteringList. + methodsPresenter + items: OrderedCollection new; + headerTitle: 'Methods'; + sortingBlock: [ :a :b | a < b ]; + contextMenu: [ (self rootCommandsGroup / 'MCMethodsSelContextualMenu') beRoot asMenuPresenter ] +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializePresenters [ + + self initializeCategoriesPresenter. + self initializeClassesPresenter. + self initializeProtocolsPresenter. + self initializeSideSelectorPresenter. + self initializeClassDefinitionPresenter. + self initializeMethodsPresenter. + self initializeCodePresenter. + self initializeCommentPresenter +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeProtocolsPresenter [ + + protocolsPresenter := self newFilteringList. + protocolsPresenter + headerTitle: 'Protocols'; + contextMenu: [ (self rootCommandsGroup / 'MCProtocolsSelContextualMenu') beRoot asMenuPresenter ] +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeSideSelectorPresenter [ + + classOrInstanceSelectorPresenter := self newCheckBox + label: 'Class'; + whenActivatedDo: [ + protocolsPresenter + headerTitle: 'Class protocols'; + items: self visibleProtocols. + classDefinitionPresenter + text: self metaclassDefinitionString; + unselectAll ]; + + whenDeactivatedDo: [ + protocolsPresenter + headerTitle: 'Instance protocols'; + items: self visibleProtocols. + classDefinitionPresenter + text: self classDefinitionString; + unselectAll ]; + yourself. +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> initializeWindow: aWindowPresenter [ + + aWindowPresenter + title: self browserTitle; + initialExtent: 1000 @ 700; + centered +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> isClassSide [ + "Answer if the receiver's class side is selected" + + ^ classOrInstanceSelectorPresenter isActive +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> metaclassDefinitionString [ + | defs | + defs := items select: [:ea | (ea isClassDefinition or: [ea isClassDefinitionExtension]) + and: [ea className = self classSelection]]. + + defs isEmpty ifTrue: [^ 'This class is defined elsewhere.']. + + ^ String streamContents: [:stream | + defs asArray sort + do: [:ea | ea printClassDefinitionOn: stream] + separatedBy: [stream nextPut: $.; cr] ]. +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> methodsForSelectedClass [ + + ^ items select: [ :ea | ea className = self classSelection and: [ ea isMethodDefinition and: [ ea classIsMeta = self switchIsClass ] ] ] +] + +{ #category : 'executing' } +IceSnapshotBrowser >> methodsForSelectedClassCategory [ + + | visibleClasses | + visibleClasses := self visibleClasses. + ^ items select: [ :ea | + (visibleClasses includes: ea className) and: [ + ea isMethodDefinition and: [ ea classIsMeta = self switchIsClass ] ] ] +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> methodsForSelectedProtocol [ + + | methods | + + self protocolSelection ifNil: [^ Array new]. + methods := self methodsForSelectedClass asOrderedCollection. + (self protocolSelection = '-- all --') + ifFalse: [methods removeAllSuchThat: [:ea | ea protocol ~= self protocolSelection]]. + ^ methods collect: #selector + + +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> packageClassNames [ + ^ self packageClasses collect: [:ea | ea className] +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> packageClasses [ + ^ items select: [:ea | ea isClassDefinition ] +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> packageOrganizations [ + + ^ items select: [:ea | ea isOrganizationDefinition] +] + +{ #category : 'selecting' } +IceSnapshotBrowser >> protocolSelection [ + + ^ protocolsPresenter selectedItem +] + +{ #category : 'file in/out' } +IceSnapshotBrowser >> selectedClassOrMetaClass [ + + | class | + + self classSelection ifNil: [ ^ nil ]. + class := self class environment + at: self classSelection + ifAbsent: [ ^ nil ]. + ^ self switchIsClass + ifTrue: [ class class ] + ifFalse: [ class ] +] + +{ #category : 'file in/out' } +IceSnapshotBrowser >> selectedMessageName [ + "Answer a representing the currently selected method selector" + + ^ self selectedMethod + ifNotNil: [ ^ self selectedMethod selector ]. + +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> selectedMethod [ + + ^ self methodsForSelectedClass anyOne +] + +{ #category : 'accessing - model' } +IceSnapshotBrowser >> setModelBeforeInitialization: aMCSnapshot [ + + items := aMCSnapshot definitions asSortedCollection. + titleString := (aMCSnapshot definitions detect: #isOrganizationDefinition) packageName +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> spacingBetweenPanes [ + + ^ 5 +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> switchIsClass [ + + ^ classOrInstanceSelectorPresenter state +] + +{ #category : 'callbacks' } +IceSnapshotBrowser >> updateSourceCode: aMCMethodSelector [ + + | mcDef | + mcDef := items detect: [ : mcObject | + (mcObject isMethodDefinition and: [ mcObject className = self classSelection ]) + and: [ mcObject selector = aMCMethodSelector ] ]. + ^ mcDef source +] + +{ #category : 'accessing' } +IceSnapshotBrowser >> visibleCategories [ + + ^ ((self packageOrganizations flatCollect: [ :ea | ea categories ]), + (self packageClasses collect: [ :ea | ea category ]), + (self hasExtensions ifTrue: [{ self extensionsCategory }] ifFalse: [#()])) + asSet asSortedCollection +] + +{ #category : 'listing' } +IceSnapshotBrowser >> visibleClasses [ + + ^ self categorySelection = self extensionsCategory + ifTrue: [ self extensionClassNames ] + ifFalse: [ + self packageClasses + select: [:ea | ea category = self categorySelection] + thenCollect: [:ea | ea className ] ]. +] + +{ #category : 'listing' } +IceSnapshotBrowser >> visibleMethods [ + + ^ self classSelection + ifNil: [#()] + ifNotNil: [self methodsForSelectedProtocol] +] + +{ #category : 'initialization' } +IceSnapshotBrowser >> visibleProtocols [ + + | methods | + + methods := self methodsForSelectedClass. + commentPresenter + text: self classCommentString; + unselectAll. + ^ (methods collect: [ :ea | ea category ]) asSet asSortedCollection +] diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowserCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowserCommand.class.st new file mode 100644 index 0000000000..1fbf34b1df --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowserCommand.class.st @@ -0,0 +1,25 @@ +Class { + #name : 'IceSnapshotBrowserCommand', + #superclass : 'CmCommand', + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'accessing - selection' } +IceSnapshotBrowserCommand >> selectedClass [ + + ^ context classSelection +] + +{ #category : 'private' } +IceSnapshotBrowserCommand >> selectedClassIsLoaded [ + "Answer if the currently selected class is loaded in the system" + + ^ self class environment hasClassNamed: self selectedClass +] + +{ #category : 'menu messages' } +IceSnapshotBrowserCommand >> tools [ + + ^ context application tools +] diff --git a/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st b/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st new file mode 100644 index 0000000000..c87ffa2306 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st @@ -0,0 +1,784 @@ +" +Browser for snapshots +" +Class { + #name : 'MCSnapshotBrowser', + #superclass : 'IceSnapshotBrowser', + #instVars : [ + 'categorySelection', + 'classSelection', + 'protocolSelection', + 'methodSelection', + 'switch', + 'modal', + 'morph', + 'label' + ], + #category : 'Iceberg-TipUI-SnapshotBrowser', + #package : 'Iceberg-TipUI-SnapshotBrowser' +} + +{ #category : 'instance creation' } +MCSnapshotBrowser class >> forSnapshot: aSnapshot [ + + ^ self new snapshot: aSnapshot +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> accept [ + " do nothing by default" +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> allClassNames [ + ^ (items + select: [:ea | (ea isOrganizationDefinition | ea isScriptDefinition) not] + thenCollect: [:ea | ea className]) asSet. + +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> arrowKey: aCharacter from: aPluggableListMorph [ + "backstop" +] + +{ #category : 'menus' } +MCSnapshotBrowser >> browseMessages [ + "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all implementors of the selector chosen." + + self systemNavigation browseAllImplementorsOf: (self selectedMessageName ifNil: [ ^nil ]) +] + +{ #category : 'menus' } +MCSnapshotBrowser >> browseMethodFull [ + "Create and schedule a full Browser and then select the current class and message." + + | myClass | + (myClass := self selectedClassOrMetaClass) ifNotNil: + [Smalltalk tools browser openOnClass: myClass selector: self selectedMessageName] +] + +{ #category : 'menus' } +MCSnapshotBrowser >> browseSendersOfMessages [ + "Present a menu of the currently selected message, as well as all messages sent by it. Open a message set browser of all senders of the selector chosen." + + self systemNavigation browseAllSendersOf: (self selectedMessageName ifNil: [ ^nil ]) +] + +{ #category : 'menus' } +MCSnapshotBrowser >> browseVersions [ + "Create and schedule a message set browser on all versions of the + currently selected message selector." + + Smalltalk tools versionBrowser + browseVersionsForClass: self selectedClassOrMetaClass + selector: self selectedMessageName + +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> buildWindow [ + | window | + window := SystemWindow labelled: self label. + window model: self. + self widgetSpecs do: [:spec | + | send fractions offsets | + send := spec first. + fractions := spec at: 2 ifAbsent: [#(0 0 1 1)]. + offsets := spec at: 3 ifAbsent: [#(0 0 0 0)]. + window + addMorph: (self perform: send first withArguments: send allButFirst) + fullFrame: + (LayoutFrame new + leftFraction: fractions first; + topFraction: fractions second; + rightFraction: fractions third ; + bottomFraction: fractions fourth; + leftOffset: offsets first; + topOffset: offsets second; + rightOffset: offsets third; + bottomOffset: offsets fourth)]. + ^ window +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> buttonEnabled [ + ^ true +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> buttonRow [ + ^ self buttonRow: self buttonSpecs +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> buttonRow: specArray [ + | aRow | + aRow := PanelMorph new. + aRow layoutPolicy: TableLayout new; listDirection: #leftToRight. + aRow hResizing: #spaceFill; vResizing: #spaceFill; rubberBandCells: true. + aRow clipSubmorphs: true; borderWidth: 0. + aRow layoutInset: 2@2; cellInset: 1. + aRow wrapCentering: #center; cellPositioning: #leftCenter. + specArray do: + [:triplet | | aButton state | + state := triplet at: 5 ifAbsent: [#buttonState]. + aButton := PluggableButtonMorph + on: self + getState: state + action: #performButtonAction:enabled:. + aButton + hResizing: #spaceFill; + vResizing: #spaceFill; + label: triplet first asString; + getEnabledSelector: (triplet at: 4 ifAbsent: [#buttonEnabled]); + arguments: (Array with: triplet second with: (triplet at: 4 ifAbsent: [#buttonEnabled])). + aRow addMorphBack: aButton. + aButton setBalloonText: triplet third]. + ^ aRow +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> buttonSelected [ + ^ false +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> buttonSpecs [ + ^ #(('instance' switchBeInstance 'show instance' buttonEnabled switchIsInstance) + ('?' switchBeComment 'show comment' buttonEnabled switchIsComment) + ('class' switchBeClass 'show class' buttonEnabled switchIsClass)) +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> buttonState [ + ^ false +] + +{ #category : 'listing' } +MCSnapshotBrowser >> categoryList [ + ^ self visibleCategories +] + +{ #category : 'menus' } +MCSnapshotBrowser >> categoryListMenu: aMenu [ + categorySelection + ifNotNil: [aMenu + add: (categorySelection = '*Extensions' + ifTrue: ['Load all extension methods'] + ifFalse: ['Load class category {1}' format: {categorySelection}]) + selector: #loadCategorySelection]. + ^ aMenu +] + +{ #category : 'selecting' } +MCSnapshotBrowser >> categorySelection [ + ^ categorySelection ifNil: [0] ifNotNil: [self visibleCategories indexOf: categorySelection] +] + +{ #category : 'selecting' } +MCSnapshotBrowser >> categorySelection: aNumber [ + categorySelection := aNumber = 0 ifFalse: [self visibleCategories at: aNumber]. + self classSelection: 0. + self changed: #categorySelection; + changed: #classList. + +] + +{ #category : 'text' } +MCSnapshotBrowser >> classCommentString [ + ^ items + detect: [ :ea | ea isClassDefinition and: [ ea className = classSelection ] ] + ifFound: [ :classDefinition | classDefinition comment ] + ifNone: [ '' ] +] + +{ #category : 'text' } +MCSnapshotBrowser >> classDefinitionString [ + | defs | + defs := items select: [:ea | (ea isClassDefinition or: [ea isClassDefinitionExtension]) + and: [ea className = classSelection]]. + + defs isEmpty ifTrue: [^ 'This class is defined elsewhere.']. + + ^ String streamContents: [:stream | + defs asArray sort + do: [:ea | ea printDefinitionOn: stream] + separatedBy: [stream nextPut: $.; cr] + ]. +] + +{ #category : 'menus' } +MCSnapshotBrowser >> classHierarchy [ + "Create and schedule a class list browser on the receiver's hierarchy." + + self systemNavigation + browseHierarchy: self selectedClassOrMetaClass + selector: self selectedMessageName "OK if nil" +] + +{ #category : 'listing' } +MCSnapshotBrowser >> classList [ + ^ self visibleClasses +] + +{ #category : 'menus' } +MCSnapshotBrowser >> classListMenu: aMenu [ + + classSelection ifNil: [ ^ aMenu ]. + aMenu + addList: #( #- #( 'Browse full (b)' browseMethodFull ) #( 'Browse hierarchy (h)' classHierarchy ) #- #( 'Show hierarchy' methodHierarchy ) ); + addLine; + add: ('Load class {1}' format: { classSelection }) selector: #loadClassSelection. + ^ aMenu +] + +{ #category : 'selecting' } +MCSnapshotBrowser >> classSelection [ + ^ classSelection ifNil: [0] ifNotNil: [self visibleClasses indexOf: classSelection] +] + +{ #category : 'selecting' } +MCSnapshotBrowser >> classSelection: aNumber [ + classSelection := aNumber = 0 ifFalse: [self visibleClasses at: aNumber]. + self protocolSelection: 0. + self changed: #classSelection; + changed: #protocolList; + changed: #methodList. + +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> close [ + self window delete +] + +{ #category : 'menus' } +MCSnapshotBrowser >> copySelector [ + "Copy the selected selector to the clipboard" + + | selector | + (selector := self selectedMessageName) ifNotNil: + [Clipboard clipboardText: selector asString] +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> defaultLabel [ + ^ 'Snapshot Browser' +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> extensionClassNames [ + ^ (self allClassNames difference: self packageClassNames) asSortedCollection +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> extensionsCategory [ + ^ '*Extensions' +] + +{ #category : 'menus' } +MCSnapshotBrowser >> fileOutMessage [ + "Put a description of the selected message on a file" + + | fileName | + self selectedMessageName ifNotNil: [ + Cursor write showWhile: [ + self selectedClassOrMetaClass fileOutMethod: + self selectedMessageName ]. + ^ self ]. + items isEmpty ifTrue: [ ^ self ]. + fileName := MorphicUIManager new + request: 'File out on which file?' + initialAnswer: 'methods'. + Cursor write showWhile: [ + | internalStream | + internalStream := WriteStream on: (String new: 1000). + internalStream + header; + timeStamp. + items do: [ :patchOp | + patchOp definition isMethodDefinition ifTrue: [ + (patchOp definition actualClass isNotNil and: [ + patchOp definition actualClass includesSelector: + patchOp definition selector ]) + ifTrue: [ + patchOp definition actualClass + printMethodChunk: patchOp definition selector + on: internalStream ] + ifFalse: [ + internalStream nextChunkPut: + patchOp definition className , ' removeSelector: ' + , patchOp definition selector printString ] ]. + patchOp definition isClassDefinition ifTrue: [ + patchOp definition actualClass + ifNotNil: [ + internalStream nextChunkPut: + patchOp definition actualClass definition. + patchOp definition comment ifNotNil: [ + patchOp definition actualClass putCommentOnFile: internalStream ] ] + ifNil: [ + internalStream nextChunkPut: + patchOp definition className , ' removeFromSystem' ] ] ]. + CodeExporter + writeSourceCodeFrom: internalStream + baseName: fileName + isSt: true ] +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> hasExtensions [ + ^self extensionClassNames notEmpty +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> initialExtent [ + ^ 650@400. +] + +{ #category : 'menus' } +MCSnapshotBrowser >> inspectSelection [ + ^ self methodSelection inspect +] + +{ #category : 'utilities' } +MCSnapshotBrowser >> interactionModel [ + ^ self +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> label [ + ^ label ifNil: [self defaultLabel] +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> label: aString [ + + label := aString +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> listMorph: listSymbol [ + + | selectionSymbol | + selectionSymbol := (listSymbol , 'Selection') asSymbol. + + ^ PluggableListMorph + on: self + list: (listSymbol , 'List') asSymbol + selected: selectionSymbol + changeSelected: (selectionSymbol , ':') asSymbol + menu: (listSymbol , 'ListMenu:') asSymbol +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> listMorph: listSymbol selection: selectionSymbol menu: menuSymbol keystroke: keystrokeSymbol [ + ^ (PluggableListMorph + on: self + list: listSymbol + selected: selectionSymbol + changeSelected: (selectionSymbol, ':') asSymbol + menu: menuSymbol) + keystrokeActionSelector: keystrokeSymbol; + yourself +] + +{ #category : 'menus' } +MCSnapshotBrowser >> loadCategorySelection [ + "Load the entire selected category" + categorySelection ifNil: [ ^self ]. + self methodsForSelectedClassCategory do: [ :m | m load ]. +] + +{ #category : 'menus' } +MCSnapshotBrowser >> loadClassSelection [ + classSelection ifNil: [ ^ self ]. + self packageClasses + detect: [ :ea | ea className = classSelection ] + ifFound: [ :packageClass | + packageClass load. + self methodsForSelectedClass do: [ :m | m load ] ] +] + +{ #category : 'menus' } +MCSnapshotBrowser >> loadMethodSelection [ + methodSelection ifNil: [ ^self ]. + methodSelection load. +] + +{ #category : 'menus' } +MCSnapshotBrowser >> loadProtocolSelection [ + protocolSelection ifNil: [ ^self ]. + self methodsForSelectedProtocol do: [ :m | m load ]. +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> menu [ + " returns nil to let the editing mode offer the right menu" + ^ nil +] + +{ #category : 'text' } +MCSnapshotBrowser >> metaclassDefinitionString [ + | defs | + defs := items select: [:ea | (ea isClassDefinition or: [ea isClassDefinitionExtension]) + and: [ea className = classSelection]]. + + defs isEmpty ifTrue: [^ 'This class is defined elsewhere.']. + + ^ String streamContents: [:stream | + defs asArray sort + do: [:ea | ea printClassDefinitionOn: stream] + separatedBy: [stream nextPut: $.; cr] + ]. +] + +{ #category : 'menus' } +MCSnapshotBrowser >> methodHierarchy [ + "Create and schedule a method browser on the hierarchy of implementors." + + self systemNavigation methodHierarchyBrowserForClass: self selectedClassOrMetaClass + selector: self selectedMessageName +] + +{ #category : 'listing' } +MCSnapshotBrowser >> methodList [ + ^ self visibleMethods collect: [:ea | ea selector] +] + +{ #category : 'menus' } +MCSnapshotBrowser >> methodListKey: aKeystroke from: aListMorph [ + aKeystroke caseOf: { + [$b] -> [self browseMethodFull]. + [$h] -> [self classHierarchy]. + [$o] -> [self fileOutMessage]. + [$c] -> [self copySelector]. + [$n] -> [self browseSendersOfMessages]. + [$m] -> [self browseMessages]. + [$i] -> [self methodHierarchy]. + [$v] -> [self browseVersions]} + otherwise: [] +] + +{ #category : 'menus' } +MCSnapshotBrowser >> methodListMenu: aMenu [ + + self selectedMessageName + ifNil: [ items isNotEmpty ifTrue: [ aMenu add: 'FileOut (o)' selector: #fileOutMessage ] ] + ifNotNil: [ + aMenu addList: + #( #( 'Browse full (b)' browseMethodFull ) #( 'Browse hierarchy (h)' classHierarchy ) #- #( 'FileOut (o)' fileOutMessage ) #( 'Copy selector (c)' + copySelector ) ). + aMenu addList: #( #- #( 'Browse senders (n)' browseSendersOfMessages ) #( 'Browse implementors (m)' browseMessages ) + #( 'Inheritance (i)' methodHierarchy ) #( 'Versions (v)' browseVersions ) ) ]. + + + (self selectedMessageName isNotNil and: [ methodSelection isLoadable ]) ifTrue: [ + aMenu + addLine; + add: 'Load method' selector: #loadMethodSelection ]. + ^ aMenu +] + +{ #category : 'selecting' } +MCSnapshotBrowser >> methodSelection [ + ^ methodSelection + ifNil: [0] + ifNotNil: [self visibleMethods indexOf: methodSelection] +] + +{ #category : 'selecting' } +MCSnapshotBrowser >> methodSelection: aNumber [ + methodSelection := aNumber = 0 ifFalse: [self visibleMethods at: aNumber]. + self changed: #methodSelection; changed: #text. +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> methodsForSelectedClass [ + + ^ items select: [ :ea | ea className = classSelection and: [ ea isMethodDefinition and: [ ea classIsMeta = self switchIsClass ] ] ] +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> methodsForSelectedClassCategory [ + | visibleClasses | + visibleClasses := self visibleClasses. + ^ items select: [:ea | (visibleClasses includes: ea className) + and: [ea isMethodDefinition + and: [ea classIsMeta = self switchIsClass]]]. +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> methodsForSelectedProtocol [ + | methods | + protocolSelection ifNil: [^ Array new]. + methods := self methodsForSelectedClass asOrderedCollection. + (protocolSelection = '-- all --') + ifFalse: [methods removeAllSuchThat: [:ea | ea protocol ~= protocolSelection]]. + ^ methods + + +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> packageClassNames [ + ^ self packageClasses collect: [:ea | ea className] +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> packageClasses [ + ^ items select: [:ea | ea isClassDefinition] +] + +{ #category : 'listing' } +MCSnapshotBrowser >> packageOrganizations [ + ^ items select: [:ea | ea isOrganizationDefinition] +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> performButtonAction: anActionSelector enabled: anEnabledSelector [ + (self perform: anEnabledSelector) + ifTrue: [ self perform: anActionSelector ] +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> preferredColor [ + ^ (Color r: 0.627 g: 0.69 b: 0.976) +] + +{ #category : 'listing' } +MCSnapshotBrowser >> protocolList [ + ^ self visibleProtocols +] + +{ #category : 'menus' } +MCSnapshotBrowser >> protocolListMenu: aMenu [ + protocolSelection + ifNotNil: [aMenu + add: ('Load protocol ''{1}''' format: {protocolSelection}) + selector: #loadProtocolSelection ]. + ^ aMenu +] + +{ #category : 'selecting' } +MCSnapshotBrowser >> protocolSelection [ + ^ protocolSelection + ifNil: [0] + ifNotNil: [self visibleProtocols indexOf: protocolSelection] +] + +{ #category : 'selecting' } +MCSnapshotBrowser >> protocolSelection: anInteger [ + protocolSelection := (anInteger = 0 ifFalse: [self visibleProtocols at: anInteger]). + self methodSelection: 0. + self changed: #protocolSelection; + changed: #methodList. +] + +{ #category : 'text' } +MCSnapshotBrowser >> scriptDefinitionString [ + | defs | + defs := items select: [:ea | ea isScriptDefinition]. + defs isEmpty ifTrue: [^'(package defines no scripts)']. + + ^ String streamContents: [:stream | + defs asArray sort + do: [:ea | stream nextPutAll: '---------- package '; + nextPutAll: ea scriptSelector; + nextPutAll: ' ----------'; cr; + nextPutAll: ea script; cr] + separatedBy: [stream cr]]. +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> selectedClass [ + classSelection ifNil: [ ^ nil ]. + ^ Smalltalk globals at: classSelection ifAbsent: [ nil ] +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> selectedClassOrMetaClass [ + | class | + classSelection ifNil: [ ^ nil ]. + class := Smalltalk globals at: classSelection ifAbsent: [ ^ nil ]. + ^ self switchIsClass + ifTrue: [ class class ] + ifFalse: [ class ] +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> selectedMessageCategoryName [ + ^protocolSelection +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> selectedMessageName [ + ^methodSelection ifNotNil: [^ methodSelection selector ]. + +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> shoutAboutToStyle: aPluggableShoutMorphOrView [ + ^ false +] + +{ #category : 'opening' } +MCSnapshotBrowser >> show [ + "Open the tool returning the window." + + modal := false. + self window openInWorld. + ^ self window +] + +{ #category : 'opening' } +MCSnapshotBrowser >> showLabelled: labelString [ + + modal := false. + self label: labelString. + self window openInWorld. + ^ self window +] + +{ #category : 'switch' } +MCSnapshotBrowser >> signalSwitchChanged [ + self protocolSelection: 0. + self + changed: #switchIsInstance; + changed: #switchIsComment; + changed: #switchIsClass; + changed: #protocolList; + changed: #methodList; + changed: #text. +] + +{ #category : 'accessing' } +MCSnapshotBrowser >> snapshot: aSnapshot [ + items := aSnapshot definitions asSortedCollection. + self categorySelection: 0. +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> summary: aString [ + " do nothing by default" +] + +{ #category : 'switch' } +MCSnapshotBrowser >> switchBeClass [ + switch := #class. + self signalSwitchChanged. +] + +{ #category : 'switch' } +MCSnapshotBrowser >> switchBeComment [ + switch := #comment. + self signalSwitchChanged. +] + +{ #category : 'switch' } +MCSnapshotBrowser >> switchBeInstance [ + switch := #instance. + self signalSwitchChanged. +] + +{ #category : 'switch' } +MCSnapshotBrowser >> switchIsClass [ + ^ switch = #class +] + +{ #category : 'switch' } +MCSnapshotBrowser >> switchIsComment [ + ^ switch = #comment. +] + +{ #category : 'switch' } +MCSnapshotBrowser >> switchIsInstance [ + switch ifNil: [switch := #instance]. + ^ switch = #instance. +] + +{ #category : 'text' } +MCSnapshotBrowser >> text [ + self switchIsComment ifTrue: [ ^ self classCommentString ]. + methodSelection ifNotNil: [ ^ methodSelection source ]. + protocolSelection ifNotNil: [ ^ '' ]. + classSelection ifNotNil: [ + ^ self switchIsClass + ifTrue: [ self metaclassDefinitionString ] + ifFalse: [ self classDefinitionString ] ]. + categorySelection ifNil: [ ^ self scriptDefinitionString ]. + ^ '' +] + +{ #category : 'text' } +MCSnapshotBrowser >> text: aTextOrString [ + self changed: #text +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> textMorph: aSymbol [ + | textMorph | + textMorph := RubPluggableTextMorph new + getTextSelector: aSymbol; + setTextSelector: (aSymbol , ':') asSymbol; + on: self; + beWrapped; + hScrollbarShowNever; + beForSmalltalkScripting; + yourself. + textMorph announcer when: RubTextAcceptRequest send: #accept to: self. + textMorph hasUnacceptedEdits: false. + ^ textMorph +] + +{ #category : 'listing' } +MCSnapshotBrowser >> visibleCategories [ + ^ ((self packageOrganizations flatCollect: [ :ea | ea categories ]), + (self packageClasses collect: [ :ea | ea category ]), + (self hasExtensions ifTrue: [{ self extensionsCategory }] ifFalse: [#()])) + asSet asSortedCollection +] + +{ #category : 'listing' } +MCSnapshotBrowser >> visibleClasses [ + ^ categorySelection = self extensionsCategory + ifTrue: [self extensionClassNames] + ifFalse: [self packageClasses + select: [:ea | ea category = categorySelection] + thenCollect: [:ea | ea className]]. +] + +{ #category : 'listing' } +MCSnapshotBrowser >> visibleMethods [ + ^ classSelection + ifNil: [#()] + ifNotNil: [self methodsForSelectedProtocol] +] + +{ #category : 'listing' } +MCSnapshotBrowser >> visibleProtocols [ + + | methods | + self switchIsComment ifTrue: [ ^ Array new ]. + methods := self methodsForSelectedClass. + ^ (methods collect: [ :ea | ea category ]) asSet asSortedCollection +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> widgetSpecs [ + + ^#( + ((listMorph: category) (0 0 0.25 0.4)) + ((listMorph: class) (0.25 0 0.50 0.4) (0 0 0 -30)) + ((listMorph: protocol) (0.50 0 0.75 0.4)) + ((listMorph:selection:menu:keystroke: methodList methodSelection methodListMenu: methodListKey:from:) (0.75 0 1 0.4)) + ((buttonRow) (0.25 0.4 0.5 0.4) (0 -30 0 0)) + ((textMorph: text) (0 0.4 1 1)) + ) +] + +{ #category : 'morphic ui' } +MCSnapshotBrowser >> window [ + + ^ morph ifNil: [ morph := self buildWindow ] +] diff --git a/Iceberg-TipUI-SnapshotBrowser/MCVersion.extension.st b/Iceberg-TipUI-SnapshotBrowser/MCVersion.extension.st new file mode 100644 index 0000000000..0d4858e6a3 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/MCVersion.extension.st @@ -0,0 +1,7 @@ +Extension { #name : 'MCVersion' } + +{ #category : '*Iceberg-TipUI-SnapshotBrowser' } +MCVersion >> browse [ + + ^ (IceSnapshotBrowser forSnapshot: self completeSnapshot) open +] diff --git a/Iceberg-TipUI-SnapshotBrowser/package.st b/Iceberg-TipUI-SnapshotBrowser/package.st new file mode 100644 index 0000000000..7af7886cb1 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser/package.st @@ -0,0 +1 @@ +Package { #name : 'Iceberg-TipUI-SnapshotBrowser' } diff --git a/Iceberg-TipUi-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st b/Iceberg-TipUi-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st new file mode 100644 index 0000000000..21b9e9a6ac --- /dev/null +++ b/Iceberg-TipUi-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st @@ -0,0 +1,349 @@ +Class { + #name : 'IceSnapshotBrowserTest', + #superclass : 'MCTestCase', + #instVars : [ + 'model' + ], + #category : 'Iceberg-TipUi-SnapshotBrowser-Tests', + #package : 'Iceberg-TipUi-SnapshotBrowser-Tests' +} + +{ #category : 'private' } +IceSnapshotBrowserTest >> allCategories [ + ^ Array with: model extensionsCategory with: self mockCategoryName. +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> allMethods [ + ^ MCSnapshotResource current definitions + select: [:def | def isMethodDefinition] + thenCollect: [:def | def selector] +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> allProtocols [ + ^ MCSnapshotResource current definitions + select: [:def | def isMethodDefinition] + thenCollect: [:def | def category] +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> assertAListMatches: strings [ + + | lists | + lists := self presenterLists collect: #items. + lists + detect: [ :list | list size = strings size and: [ list includesAll: strings ] ] + ifNone: [ self fail: 'Could not find all "' , strings asArray asString , '" ' , 'in any of "' , (lists collect: #asArray) asArray asString , '"' ] +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> assertButtonOn: aString [ + self assert: (self findButtonWithLabel: aString) getModelState. + +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> assertTextIs: aString [ + + self + assert: self methodPresenter text + equals: aString +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> bottomLayout [ + + ^ model layout children second +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classABooleanMethods [ + ^ #(falsehood moreTruth truth) +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classAClassProtocols [ + + ^ self mockClassA class protocolNames +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classAComment [ + ^ self mockClassA comment. +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classADefinitionString [ + + ^ self mockClassA oldDefinition +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classAProtocols [ + ^ self mockClassA protocolNames +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classAclassDefinitionString [ + + ^ (ClassDefinitionPrinter oldPharo for: self mockClassA class) definitionString +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> classDefinitionPresenter [ + + ^ self codePresenters first +] + +{ #category : 'simulating' } +IceSnapshotBrowserTest >> clickOnButton: aString [ + (self findButtonWithLabel: aString) click. +] + +{ #category : 'simulating' } +IceSnapshotBrowserTest >> clickOnListItem: aString [ + | list | + list := self findListContaining: aString. + list listPresenter clickAtIndex: (list listPresenter items indexOf: aString). +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> codePresenters [ + + ^ self bottomLayout allPresenters + select: [ : p | p isKindOf: SpCodePresenter ] +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> commentPresenter [ + + ^ self textPresenters anyOne +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> definedClasses [ + ^ MCSnapshotResource current definitions + select: [:def | def isClassDefinition] + thenCollect: [:def | def className]. +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> denyAListHasSelection: aString [ + | found | + found := true. + self presenterLists + detect: [:m | m selectedItem = aString] + ifNone: [found := false]. + self deny: found. +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> denyAListIncludesAnyOf: anArrayOfStrings [ + | found | + found := true. + self presenterLists + detect: [:m | m items includesAnyOf: anArrayOfStrings] + ifNone: [found := false]. + self deny: found. +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> denyButtonOn: aString [ + self deny: (self findButtonWithLabel: aString) getModelState. + +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> falsehoodMethodSource [ + ^ 'falsehood + ^ false' +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> findButtonWithLabel: aString [ + + ^ model allPresenters + detect: [ : p | p isKindOf: SpCheckBoxPresenter ] + ifNone: [ nil ] +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> findListContaining: aString [ + + ^ self presenterLists detect: [: m | m items includes: aString ] +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> methodPresenter [ + "For now we cannot properly distinguish between method and class definition code presenters" + + ^ self codePresenters last +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> presenterListChildren [ + + ^ self upperLayout allPresenters +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> presenterLists [ + + ^ self presenterListChildren select: [ : p | p isKindOf: SpFilteringListPresenter ] +] + +{ #category : 'selecting' } +IceSnapshotBrowserTest >> selectMockClassA [ + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockClassA'. + +] + +{ #category : 'running' } +IceSnapshotBrowserTest >> setUp [ + super setUp. + model := IceSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot. + +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testCategorySelected [ + self clickOnListItem: self mockCategoryName. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self denyAListIncludesAnyOf: self allProtocols. + self denyAListIncludesAnyOf: self allMethods. + self assertTextIs: ''. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testClassSelected [ + self selectMockClassA. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self assertAListMatches: self classAProtocols. + self denyAListIncludesAnyOf: self allMethods. + self + assert: self classDefinitionPresenter text + equals: self classADefinitionString. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testClassSideClassSelected [ + + self selectMockClassA. + self clickOnButton: 'Class'. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self assertAListMatches: self classAClassProtocols. + self denyAListIncludesAnyOf: self allMethods. + self + assert: self classDefinitionPresenter text + equals: self classAclassDefinitionString. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testComment [ + + self + assert: self commentPresenter text + equals: String empty. + + self clickOnListItem: self mockCategoryName. + self + assert: self commentPresenter text + equals: String empty. + + self clickOnListItem: 'MCMockClassA'. + self + assert: self commentPresenter text + equals: self classAComment. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testFourColumns [ + + self assert: self presenterLists size equals: 4 +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testMethodIsCleared [ + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockClassA'. + self clickOnListItem: 'boolean'. + self clickOnListItem: 'falsehood'. + self clickOnListItem: 'numeric'. + + self denyAListHasSelection: 'falsehood'. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testMethodSelected [ + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockClassA'. + self clickOnListItem: 'boolean'. + self clickOnListItem: 'falsehood'. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self assertAListMatches: self classAProtocols. + self assertAListMatches: self classABooleanMethods. + self assertTextIs: self falsehoodMethodSource. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testNoSelection [ + + self assertAListMatches: self allCategories. + self denyAListIncludesAnyOf: self definedClasses. + self denyAListIncludesAnyOf: self allProtocols. + self denyAListIncludesAnyOf: self allMethods. + +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testProtocolIsCleared [ + + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockASubclass'. + self clickOnListItem: Protocol unclassified. + self clickOnListItem: 'MCMockClassA'. + + self denyAListHasSelection: Protocol unclassified +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testProtocolSelected [ + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockClassA'. + self clickOnListItem: 'boolean'. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self assertAListMatches: self classAProtocols. + self assertAListMatches: self classABooleanMethods. + self assertTextIs: ''. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testSwitchClassButton [ + + self deny: (self findButtonWithLabel: 'Class') isNil. +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> textPresenters [ + + ^ self bottomLayout allPresenters + select: [ : p | p class = SpTextPresenter ] +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> upperLayout [ + + ^ model layout children first +] diff --git a/Iceberg-TipUi-SnapshotBrowser-Tests/package.st b/Iceberg-TipUi-SnapshotBrowser-Tests/package.st new file mode 100644 index 0000000000..ae73e6506c --- /dev/null +++ b/Iceberg-TipUi-SnapshotBrowser-Tests/package.st @@ -0,0 +1 @@ +Package { #name : 'Iceberg-TipUi-SnapshotBrowser-Tests' } From f20e22bbf482850f66ad21af473d805c828bd4c0 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Thu, 9 Jan 2025 17:47:19 +0100 Subject: [PATCH 2/7] Update BaselineOfIceberg.class.st --- BaselineOfIceberg/BaselineOfIceberg.class.st | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/BaselineOfIceberg/BaselineOfIceberg.class.st b/BaselineOfIceberg/BaselineOfIceberg.class.st index 6b23321f36..2e6adfd143 100644 --- a/BaselineOfIceberg/BaselineOfIceberg.class.st +++ b/BaselineOfIceberg/BaselineOfIceberg.class.st @@ -28,13 +28,13 @@ BaselineOfIceberg >> baseline: spec [ package: 'Iceberg-Plugin-Migration' with: [ spec requires: #('Iceberg-Plugin') ]; package: 'Iceberg-Metacello-Integration' with: [ spec requires: #('Iceberg')]; package: 'Iceberg-TipUI' with: [ spec requires: #('Iceberg') ]; - package: 'Iceberg-TipUi-SnapshotBrowser'; + package: 'Iceberg-TipUI-SnapshotBrowser'; package: 'Iceberg-Memory' with: [ spec requires: #('Iceberg') ]; "tests" package: 'Iceberg-Tests' with: [ spec requires: #('Iceberg' 'Iceberg-Memory') ]; package: 'Iceberg-Tests-MetacelloIntegration' with: [ spec requires: #('Iceberg-Tests') ]; package: 'Iceberg-UI-Tests' with: [ spec requires: #('Iceberg-TipUI' 'Iceberg-Tests')]; - package: 'Iceberg-TipUi-SnapshotBrowser-Tests' with: [ spec requires: #( 'Iceberg-TipUi-SnapshotBrowser' ) ]; + package: 'Iceberg-TipUI-SnapshotBrowser-Tests' with: [ spec requires: #( 'Iceberg-TipUI-SnapshotBrowser' ) ]; package: 'Iceberg-Plugin-Migration-Tests' with: [ spec requires: #('Iceberg-Plugin-Migration' 'Iceberg-Tests') ]; "libgit" package: 'Iceberg-Libgit' with: [ spec requires: #('Iceberg' 'LibGit') ]; @@ -45,7 +45,7 @@ BaselineOfIceberg >> baseline: spec [ minimal 'Iceberg-Metacello-Integration' 'Iceberg-TipUI' - 'Iceberg-TipUi-SnapshotBrowser' + 'Iceberg-TipUI-SnapshotBrowser' 'Iceberg-Plugin' 'Iceberg-Plugin-Metacello' 'Iceberg-Plugin-GitHub' @@ -61,7 +61,7 @@ BaselineOfIceberg >> baseline: spec [ 'Iceberg-Tests-MetacelloIntegration' 'LibGit-Tests' 'Iceberg-UI-Tests' - 'Iceberg-TipUi-SnapshotBrowser-Tests' + 'Iceberg-TipUI-SnapshotBrowser-Tests' 'Iceberg-Plugin-Migration-Tests' ); group: 'development' with: #(default allTests) ]. From ea59f20db788ec2edc979c48638e41bdcd351815 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Mon, 13 Jan 2025 14:42:58 +0100 Subject: [PATCH 3/7] Fix typo --- .../IceSnapshotBrowserTest.class.st | 349 ------------------ .../package.st | 1 - 2 files changed, 350 deletions(-) delete mode 100644 Iceberg-TipUi-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st delete mode 100644 Iceberg-TipUi-SnapshotBrowser-Tests/package.st diff --git a/Iceberg-TipUi-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st b/Iceberg-TipUi-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st deleted file mode 100644 index 21b9e9a6ac..0000000000 --- a/Iceberg-TipUi-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st +++ /dev/null @@ -1,349 +0,0 @@ -Class { - #name : 'IceSnapshotBrowserTest', - #superclass : 'MCTestCase', - #instVars : [ - 'model' - ], - #category : 'Iceberg-TipUi-SnapshotBrowser-Tests', - #package : 'Iceberg-TipUi-SnapshotBrowser-Tests' -} - -{ #category : 'private' } -IceSnapshotBrowserTest >> allCategories [ - ^ Array with: model extensionsCategory with: self mockCategoryName. -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> allMethods [ - ^ MCSnapshotResource current definitions - select: [:def | def isMethodDefinition] - thenCollect: [:def | def selector] -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> allProtocols [ - ^ MCSnapshotResource current definitions - select: [:def | def isMethodDefinition] - thenCollect: [:def | def category] -] - -{ #category : 'asserting' } -IceSnapshotBrowserTest >> assertAListMatches: strings [ - - | lists | - lists := self presenterLists collect: #items. - lists - detect: [ :list | list size = strings size and: [ list includesAll: strings ] ] - ifNone: [ self fail: 'Could not find all "' , strings asArray asString , '" ' , 'in any of "' , (lists collect: #asArray) asArray asString , '"' ] -] - -{ #category : 'asserting' } -IceSnapshotBrowserTest >> assertButtonOn: aString [ - self assert: (self findButtonWithLabel: aString) getModelState. - -] - -{ #category : 'asserting' } -IceSnapshotBrowserTest >> assertTextIs: aString [ - - self - assert: self methodPresenter text - equals: aString -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> bottomLayout [ - - ^ model layout children second -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> classABooleanMethods [ - ^ #(falsehood moreTruth truth) -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> classAClassProtocols [ - - ^ self mockClassA class protocolNames -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> classAComment [ - ^ self mockClassA comment. -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> classADefinitionString [ - - ^ self mockClassA oldDefinition -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> classAProtocols [ - ^ self mockClassA protocolNames -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> classAclassDefinitionString [ - - ^ (ClassDefinitionPrinter oldPharo for: self mockClassA class) definitionString -] - -{ #category : 'accessing - presenters' } -IceSnapshotBrowserTest >> classDefinitionPresenter [ - - ^ self codePresenters first -] - -{ #category : 'simulating' } -IceSnapshotBrowserTest >> clickOnButton: aString [ - (self findButtonWithLabel: aString) click. -] - -{ #category : 'simulating' } -IceSnapshotBrowserTest >> clickOnListItem: aString [ - | list | - list := self findListContaining: aString. - list listPresenter clickAtIndex: (list listPresenter items indexOf: aString). -] - -{ #category : 'accessing - presenters' } -IceSnapshotBrowserTest >> codePresenters [ - - ^ self bottomLayout allPresenters - select: [ : p | p isKindOf: SpCodePresenter ] -] - -{ #category : 'accessing - presenters' } -IceSnapshotBrowserTest >> commentPresenter [ - - ^ self textPresenters anyOne -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> definedClasses [ - ^ MCSnapshotResource current definitions - select: [:def | def isClassDefinition] - thenCollect: [:def | def className]. -] - -{ #category : 'asserting' } -IceSnapshotBrowserTest >> denyAListHasSelection: aString [ - | found | - found := true. - self presenterLists - detect: [:m | m selectedItem = aString] - ifNone: [found := false]. - self deny: found. -] - -{ #category : 'asserting' } -IceSnapshotBrowserTest >> denyAListIncludesAnyOf: anArrayOfStrings [ - | found | - found := true. - self presenterLists - detect: [:m | m items includesAnyOf: anArrayOfStrings] - ifNone: [found := false]. - self deny: found. -] - -{ #category : 'asserting' } -IceSnapshotBrowserTest >> denyButtonOn: aString [ - self deny: (self findButtonWithLabel: aString) getModelState. - -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> falsehoodMethodSource [ - ^ 'falsehood - ^ false' -] - -{ #category : 'accessing - presenters' } -IceSnapshotBrowserTest >> findButtonWithLabel: aString [ - - ^ model allPresenters - detect: [ : p | p isKindOf: SpCheckBoxPresenter ] - ifNone: [ nil ] -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> findListContaining: aString [ - - ^ self presenterLists detect: [: m | m items includes: aString ] -] - -{ #category : 'accessing - presenters' } -IceSnapshotBrowserTest >> methodPresenter [ - "For now we cannot properly distinguish between method and class definition code presenters" - - ^ self codePresenters last -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> presenterListChildren [ - - ^ self upperLayout allPresenters -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> presenterLists [ - - ^ self presenterListChildren select: [ : p | p isKindOf: SpFilteringListPresenter ] -] - -{ #category : 'selecting' } -IceSnapshotBrowserTest >> selectMockClassA [ - self clickOnListItem: self mockCategoryName. - self clickOnListItem: 'MCMockClassA'. - -] - -{ #category : 'running' } -IceSnapshotBrowserTest >> setUp [ - super setUp. - model := IceSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot. - -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testCategorySelected [ - self clickOnListItem: self mockCategoryName. - - self assertAListMatches: self allCategories. - self assertAListMatches: self definedClasses. - self denyAListIncludesAnyOf: self allProtocols. - self denyAListIncludesAnyOf: self allMethods. - self assertTextIs: ''. -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testClassSelected [ - self selectMockClassA. - - self assertAListMatches: self allCategories. - self assertAListMatches: self definedClasses. - self assertAListMatches: self classAProtocols. - self denyAListIncludesAnyOf: self allMethods. - self - assert: self classDefinitionPresenter text - equals: self classADefinitionString. -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testClassSideClassSelected [ - - self selectMockClassA. - self clickOnButton: 'Class'. - - self assertAListMatches: self allCategories. - self assertAListMatches: self definedClasses. - self assertAListMatches: self classAClassProtocols. - self denyAListIncludesAnyOf: self allMethods. - self - assert: self classDefinitionPresenter text - equals: self classAclassDefinitionString. -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testComment [ - - self - assert: self commentPresenter text - equals: String empty. - - self clickOnListItem: self mockCategoryName. - self - assert: self commentPresenter text - equals: String empty. - - self clickOnListItem: 'MCMockClassA'. - self - assert: self commentPresenter text - equals: self classAComment. -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testFourColumns [ - - self assert: self presenterLists size equals: 4 -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testMethodIsCleared [ - self clickOnListItem: self mockCategoryName. - self clickOnListItem: 'MCMockClassA'. - self clickOnListItem: 'boolean'. - self clickOnListItem: 'falsehood'. - self clickOnListItem: 'numeric'. - - self denyAListHasSelection: 'falsehood'. -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testMethodSelected [ - self clickOnListItem: self mockCategoryName. - self clickOnListItem: 'MCMockClassA'. - self clickOnListItem: 'boolean'. - self clickOnListItem: 'falsehood'. - - self assertAListMatches: self allCategories. - self assertAListMatches: self definedClasses. - self assertAListMatches: self classAProtocols. - self assertAListMatches: self classABooleanMethods. - self assertTextIs: self falsehoodMethodSource. -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testNoSelection [ - - self assertAListMatches: self allCategories. - self denyAListIncludesAnyOf: self definedClasses. - self denyAListIncludesAnyOf: self allProtocols. - self denyAListIncludesAnyOf: self allMethods. - -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testProtocolIsCleared [ - - self clickOnListItem: self mockCategoryName. - self clickOnListItem: 'MCMockASubclass'. - self clickOnListItem: Protocol unclassified. - self clickOnListItem: 'MCMockClassA'. - - self denyAListHasSelection: Protocol unclassified -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testProtocolSelected [ - self clickOnListItem: self mockCategoryName. - self clickOnListItem: 'MCMockClassA'. - self clickOnListItem: 'boolean'. - - self assertAListMatches: self allCategories. - self assertAListMatches: self definedClasses. - self assertAListMatches: self classAProtocols. - self assertAListMatches: self classABooleanMethods. - self assertTextIs: ''. -] - -{ #category : 'testing' } -IceSnapshotBrowserTest >> testSwitchClassButton [ - - self deny: (self findButtonWithLabel: 'Class') isNil. -] - -{ #category : 'accessing - presenters' } -IceSnapshotBrowserTest >> textPresenters [ - - ^ self bottomLayout allPresenters - select: [ : p | p class = SpTextPresenter ] -] - -{ #category : 'private' } -IceSnapshotBrowserTest >> upperLayout [ - - ^ model layout children first -] diff --git a/Iceberg-TipUi-SnapshotBrowser-Tests/package.st b/Iceberg-TipUi-SnapshotBrowser-Tests/package.st deleted file mode 100644 index ae73e6506c..0000000000 --- a/Iceberg-TipUi-SnapshotBrowser-Tests/package.st +++ /dev/null @@ -1 +0,0 @@ -Package { #name : 'Iceberg-TipUi-SnapshotBrowser-Tests' } From dfd8dd74025816b7219ee1bc5f0dc9a00dd4132a Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Mon, 13 Jan 2025 14:43:53 +0100 Subject: [PATCH 4/7] Weird, last commit did not take all changes --- .../IceSnapshotBrowserTest.class.st | 349 ++++++++++++++++++ .../package.st | 1 + 2 files changed, 350 insertions(+) create mode 100644 Iceberg-TipUI-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st create mode 100644 Iceberg-TipUI-SnapshotBrowser-Tests/package.st diff --git a/Iceberg-TipUI-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st b/Iceberg-TipUI-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st new file mode 100644 index 0000000000..ac4ac94577 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser-Tests/IceSnapshotBrowserTest.class.st @@ -0,0 +1,349 @@ +Class { + #name : 'IceSnapshotBrowserTest', + #superclass : 'MCTestCase', + #instVars : [ + 'model' + ], + #category : 'Iceberg-TipUI-SnapshotBrowser-Tests', + #package : 'Iceberg-TipUI-SnapshotBrowser-Tests' +} + +{ #category : 'private' } +IceSnapshotBrowserTest >> allCategories [ + ^ Array with: model extensionsCategory with: self mockCategoryName. +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> allMethods [ + ^ MCSnapshotResource current definitions + select: [:def | def isMethodDefinition] + thenCollect: [:def | def selector] +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> allProtocols [ + ^ MCSnapshotResource current definitions + select: [:def | def isMethodDefinition] + thenCollect: [:def | def category] +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> assertAListMatches: strings [ + + | lists | + lists := self presenterLists collect: #items. + lists + detect: [ :list | list size = strings size and: [ list includesAll: strings ] ] + ifNone: [ self fail: 'Could not find all "' , strings asArray asString , '" ' , 'in any of "' , (lists collect: #asArray) asArray asString , '"' ] +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> assertButtonOn: aString [ + self assert: (self findButtonWithLabel: aString) getModelState. + +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> assertTextIs: aString [ + + self + assert: self methodPresenter text + equals: aString +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> bottomLayout [ + + ^ model layout children second +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classABooleanMethods [ + ^ #(falsehood moreTruth truth) +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classAClassProtocols [ + + ^ self mockClassA class protocolNames +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classAComment [ + ^ self mockClassA comment. +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classADefinitionString [ + + ^ self mockClassA oldDefinition +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classAProtocols [ + ^ self mockClassA protocolNames +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> classAclassDefinitionString [ + + ^ (ClassDefinitionPrinter oldPharo for: self mockClassA class) definitionString +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> classDefinitionPresenter [ + + ^ self codePresenters first +] + +{ #category : 'simulating' } +IceSnapshotBrowserTest >> clickOnButton: aString [ + (self findButtonWithLabel: aString) click. +] + +{ #category : 'simulating' } +IceSnapshotBrowserTest >> clickOnListItem: aString [ + | list | + list := self findListContaining: aString. + list listPresenter clickAtIndex: (list listPresenter items indexOf: aString). +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> codePresenters [ + + ^ self bottomLayout allPresenters + select: [ : p | p isKindOf: SpCodePresenter ] +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> commentPresenter [ + + ^ self textPresenters anyOne +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> definedClasses [ + ^ MCSnapshotResource current definitions + select: [:def | def isClassDefinition] + thenCollect: [:def | def className]. +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> denyAListHasSelection: aString [ + | found | + found := true. + self presenterLists + detect: [:m | m selectedItem = aString] + ifNone: [found := false]. + self deny: found. +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> denyAListIncludesAnyOf: anArrayOfStrings [ + | found | + found := true. + self presenterLists + detect: [:m | m items includesAnyOf: anArrayOfStrings] + ifNone: [found := false]. + self deny: found. +] + +{ #category : 'asserting' } +IceSnapshotBrowserTest >> denyButtonOn: aString [ + self deny: (self findButtonWithLabel: aString) getModelState. + +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> falsehoodMethodSource [ + ^ 'falsehood + ^ false' +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> findButtonWithLabel: aString [ + + ^ model allPresenters + detect: [ : p | p isKindOf: SpCheckBoxPresenter ] + ifNone: [ nil ] +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> findListContaining: aString [ + + ^ self presenterLists detect: [: m | m items includes: aString ] +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> methodPresenter [ + "For now we cannot properly distinguish between method and class definition code presenters" + + ^ self codePresenters last +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> presenterListChildren [ + + ^ self upperLayout allPresenters +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> presenterLists [ + + ^ self presenterListChildren select: [ : p | p isKindOf: SpFilteringListPresenter ] +] + +{ #category : 'selecting' } +IceSnapshotBrowserTest >> selectMockClassA [ + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockClassA'. + +] + +{ #category : 'running' } +IceSnapshotBrowserTest >> setUp [ + super setUp. + model := IceSnapshotBrowser forSnapshot: MCSnapshotResource current snapshot. + +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testCategorySelected [ + self clickOnListItem: self mockCategoryName. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self denyAListIncludesAnyOf: self allProtocols. + self denyAListIncludesAnyOf: self allMethods. + self assertTextIs: ''. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testClassSelected [ + self selectMockClassA. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self assertAListMatches: self classAProtocols. + self denyAListIncludesAnyOf: self allMethods. + self + assert: self classDefinitionPresenter text + equals: self classADefinitionString. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testClassSideClassSelected [ + + self selectMockClassA. + self clickOnButton: 'Class'. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self assertAListMatches: self classAClassProtocols. + self denyAListIncludesAnyOf: self allMethods. + self + assert: self classDefinitionPresenter text + equals: self classAclassDefinitionString. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testComment [ + + self + assert: self commentPresenter text + equals: String empty. + + self clickOnListItem: self mockCategoryName. + self + assert: self commentPresenter text + equals: String empty. + + self clickOnListItem: 'MCMockClassA'. + self + assert: self commentPresenter text + equals: self classAComment. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testFourColumns [ + + self assert: self presenterLists size equals: 4 +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testMethodIsCleared [ + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockClassA'. + self clickOnListItem: 'boolean'. + self clickOnListItem: 'falsehood'. + self clickOnListItem: 'numeric'. + + self denyAListHasSelection: 'falsehood'. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testMethodSelected [ + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockClassA'. + self clickOnListItem: 'boolean'. + self clickOnListItem: 'falsehood'. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self assertAListMatches: self classAProtocols. + self assertAListMatches: self classABooleanMethods. + self assertTextIs: self falsehoodMethodSource. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testNoSelection [ + + self assertAListMatches: self allCategories. + self denyAListIncludesAnyOf: self definedClasses. + self denyAListIncludesAnyOf: self allProtocols. + self denyAListIncludesAnyOf: self allMethods. + +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testProtocolIsCleared [ + + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockASubclass'. + self clickOnListItem: Protocol unclassified. + self clickOnListItem: 'MCMockClassA'. + + self denyAListHasSelection: Protocol unclassified +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testProtocolSelected [ + self clickOnListItem: self mockCategoryName. + self clickOnListItem: 'MCMockClassA'. + self clickOnListItem: 'boolean'. + + self assertAListMatches: self allCategories. + self assertAListMatches: self definedClasses. + self assertAListMatches: self classAProtocols. + self assertAListMatches: self classABooleanMethods. + self assertTextIs: ''. +] + +{ #category : 'testing' } +IceSnapshotBrowserTest >> testSwitchClassButton [ + + self deny: (self findButtonWithLabel: 'Class') isNil. +] + +{ #category : 'accessing - presenters' } +IceSnapshotBrowserTest >> textPresenters [ + + ^ self bottomLayout allPresenters + select: [ : p | p class = SpTextPresenter ] +] + +{ #category : 'private' } +IceSnapshotBrowserTest >> upperLayout [ + + ^ model layout children first +] diff --git a/Iceberg-TipUI-SnapshotBrowser-Tests/package.st b/Iceberg-TipUI-SnapshotBrowser-Tests/package.st new file mode 100644 index 0000000000..2f38f86413 --- /dev/null +++ b/Iceberg-TipUI-SnapshotBrowser-Tests/package.st @@ -0,0 +1 @@ +Package { #name : 'Iceberg-TipUI-SnapshotBrowser-Tests' } From ccfcf41a281def19c0cc7dcd527ae0690ff826e2 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Mon, 13 Jan 2025 16:58:56 +0100 Subject: [PATCH 5/7] Fix tests --- Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st | 6 ++++++ Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st | 8 ++------ 2 files changed, 8 insertions(+), 6 deletions(-) diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st index 0d456c7ec4..c608db8b44 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st @@ -84,6 +84,12 @@ IceSnapshotBrowser class >> buildCommandsGroupWith: presenterInstance forRoot: r yourself) ] +{ #category : 'accessing' } +IceSnapshotBrowser class >> defaultPreferredExtent [ + + ^ 650 @ 400 +] + { #category : 'instance creation' } IceSnapshotBrowser class >> forSnapshot: aMCSnapshot [ diff --git a/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st b/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st index c87ffa2306..f2c3887822 100644 --- a/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st @@ -250,7 +250,8 @@ MCSnapshotBrowser >> classSelection: aNumber [ { #category : 'morphic ui' } MCSnapshotBrowser >> close [ - self window delete + + self window ifNotNil: [ :w | w delete ] ] { #category : 'menus' } @@ -331,11 +332,6 @@ MCSnapshotBrowser >> hasExtensions [ ^self extensionClassNames notEmpty ] -{ #category : 'morphic ui' } -MCSnapshotBrowser >> initialExtent [ - ^ 650@400. -] - { #category : 'menus' } MCSnapshotBrowser >> inspectSelection [ ^ self methodSelection inspect From 786f64e9d6c7976f691e2e5c7af311f112f28a33 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Tue, 14 Jan 2025 11:59:59 +0100 Subject: [PATCH 6/7] Add class comments --- .../IceSBBrowseFullClassCommand.class.st | 3 +++ .../IceSBBrowseFullMethodCommand.class.st | 3 +++ .../IceSBBrowseHierarchyClassCommand.class.st | 3 +++ .../IceSBBrowseHierarchyMethodCommand.class.st | 3 +++ .../IceSBBrowseMethodImplementorsCommand.class.st | 3 +++ .../IceSBBrowseMethodInheritanceCommand.class.st | 3 +++ .../IceSBBrowseMethodSendersCommand.class.st | 3 +++ .../IceSBBrowseMethodVersionsCommand.class.st | 3 +++ .../IceSBBrowserAbstractClassCommand.class.st | 3 +++ .../IceSBBrowserAbstractMethodCommand.class.st | 3 +++ .../IceSBCopySelectorCommand.class.st | 3 +++ .../IceSBFileOutMethodCommand.class.st | 3 +++ Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st | 3 +++ .../IceSBLoadMethodCommand.class.st | 3 +++ Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st | 5 +++++ .../IceSnapshotBrowserCommand.class.st | 5 +++++ 16 files changed, 52 insertions(+) diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullClassCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullClassCommand.class.st index 33ebb7e362..b8fe4cebef 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullClassCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullClassCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command used to browse a selected class of the snapshot browser. +" Class { #name : 'IceSBBrowseFullClassCommand', #superclass : 'IceSBBrowserAbstractClassCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullMethodCommand.class.st index b881ca5fdc..b8c4d84338 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullMethodCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseFullMethodCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to browse a method from the snapshot browser. +" Class { #name : 'IceSBBrowseFullMethodCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyClassCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyClassCommand.class.st index eb1a8fca05..7208060eb5 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyClassCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyClassCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to browse the hierarchy of a class. +" Class { #name : 'IceSBBrowseHierarchyClassCommand', #superclass : 'IceSBBrowserAbstractClassCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyMethodCommand.class.st index a5b432d821..c62e86a3e8 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyMethodCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseHierarchyMethodCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to be able to see the hierarchy of a method. +" Class { #name : 'IceSBBrowseHierarchyMethodCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodImplementorsCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodImplementorsCommand.class.st index 47d4fff32c..436dc8bc09 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodImplementorsCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodImplementorsCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to be able to browse the implementors of a method. +" Class { #name : 'IceSBBrowseMethodImplementorsCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodInheritanceCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodInheritanceCommand.class.st index 6b5d86313d..945f504bac 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodInheritanceCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodInheritanceCommand.class.st @@ -1,3 +1,6 @@ +" +I am a method to be able to see a method inheritance hierarchy +" Class { #name : 'IceSBBrowseMethodInheritanceCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodSendersCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodSendersCommand.class.st index e5b1292d50..7e079d93bf 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodSendersCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodSendersCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to be able to see the senders of a method in the snapshot browser +" Class { #name : 'IceSBBrowseMethodSendersCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodVersionsCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodVersionsCommand.class.st index 92c2c7f7e9..da5673a78e 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodVersionsCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowseMethodVersionsCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to see different versions of a method +" Class { #name : 'IceSBBrowseMethodVersionsCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractClassCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractClassCommand.class.st index 08e8248440..2a85bdb2e8 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractClassCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractClassCommand.class.st @@ -1,3 +1,6 @@ +" +I am an abstract class to manage the snapshot browser commands about classes. +" Class { #name : 'IceSBBrowserAbstractClassCommand', #superclass : 'IceSnapshotBrowserCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractMethodCommand.class.st index ebaa469a64..f107068e8f 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractMethodCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBBrowserAbstractMethodCommand.class.st @@ -1,3 +1,6 @@ +" +I am an abstract class to manage the snapshot browser commands about methods. +" Class { #name : 'IceSBBrowserAbstractMethodCommand', #superclass : 'IceSnapshotBrowserCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBCopySelectorCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBCopySelectorCommand.class.st index 197922d6c7..61138dd9a8 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBCopySelectorCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBCopySelectorCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to copy the selector of a method in the snapshot browser. +" Class { #name : 'IceSBCopySelectorCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBFileOutMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBFileOutMethodCommand.class.st index 7b2f2bb720..82aa1b0bc6 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBFileOutMethodCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBFileOutMethodCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to file out a method in the snapshot browser. +" Class { #name : 'IceSBFileOutMethodCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st index 5c57924399..f709b9c159 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadClassCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to load a class in the snapshot browser. +" Class { #name : 'IceSBLoadClassCommand', #superclass : 'IceSBBrowserAbstractClassCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSBLoadMethodCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadMethodCommand.class.st index 043d37986b..b97483c123 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSBLoadMethodCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSBLoadMethodCommand.class.st @@ -1,3 +1,6 @@ +" +I am a command to load a method from the Snapshot browser +" Class { #name : 'IceSBLoadMethodCommand', #superclass : 'IceSBBrowserAbstractMethodCommand', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st index c608db8b44..195af1b69d 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowser.class.st @@ -1,3 +1,8 @@ +" +I am a browser to be able to browse the code of a Monticello snapshot. + +I am made with the Spec framework. +" Class { #name : 'IceSnapshotBrowser', #superclass : 'StPresenter', diff --git a/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowserCommand.class.st b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowserCommand.class.st index 1fbf34b1df..016e339138 100644 --- a/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowserCommand.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/IceSnapshotBrowserCommand.class.st @@ -1,3 +1,8 @@ +" +I am a common superclass for all the commands of the Snapshot browser. + +Probably we could reuse some of the Iceberg commands instead of those, we should iterate. +" Class { #name : 'IceSnapshotBrowserCommand', #superclass : 'CmCommand', From 0611cc419bf6578ebc5d378f7d1dc30e04d90448 Mon Sep 17 00:00:00 2001 From: CyrilFerlicot Date: Tue, 14 Jan 2025 12:13:04 +0100 Subject: [PATCH 7/7] Remove duplicated methods --- .../MCSnapshotBrowser.class.st | 104 ------------------ 1 file changed, 104 deletions(-) diff --git a/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st b/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st index f2c3887822..72f609697c 100644 --- a/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st +++ b/Iceberg-TipUI-SnapshotBrowser/MCSnapshotBrowser.class.st @@ -29,14 +29,6 @@ MCSnapshotBrowser >> accept [ " do nothing by default" ] -{ #category : 'accessing' } -MCSnapshotBrowser >> allClassNames [ - ^ (items - select: [:ea | (ea isOrganizationDefinition | ea isScriptDefinition) not] - thenCollect: [:ea | ea className]) asSet. - -] - { #category : 'morphic ui' } MCSnapshotBrowser >> arrowKey: aCharacter from: aPluggableListMorph [ "backstop" @@ -268,70 +260,6 @@ MCSnapshotBrowser >> defaultLabel [ ^ 'Snapshot Browser' ] -{ #category : 'accessing' } -MCSnapshotBrowser >> extensionClassNames [ - ^ (self allClassNames difference: self packageClassNames) asSortedCollection -] - -{ #category : 'accessing' } -MCSnapshotBrowser >> extensionsCategory [ - ^ '*Extensions' -] - -{ #category : 'menus' } -MCSnapshotBrowser >> fileOutMessage [ - "Put a description of the selected message on a file" - - | fileName | - self selectedMessageName ifNotNil: [ - Cursor write showWhile: [ - self selectedClassOrMetaClass fileOutMethod: - self selectedMessageName ]. - ^ self ]. - items isEmpty ifTrue: [ ^ self ]. - fileName := MorphicUIManager new - request: 'File out on which file?' - initialAnswer: 'methods'. - Cursor write showWhile: [ - | internalStream | - internalStream := WriteStream on: (String new: 1000). - internalStream - header; - timeStamp. - items do: [ :patchOp | - patchOp definition isMethodDefinition ifTrue: [ - (patchOp definition actualClass isNotNil and: [ - patchOp definition actualClass includesSelector: - patchOp definition selector ]) - ifTrue: [ - patchOp definition actualClass - printMethodChunk: patchOp definition selector - on: internalStream ] - ifFalse: [ - internalStream nextChunkPut: - patchOp definition className , ' removeSelector: ' - , patchOp definition selector printString ] ]. - patchOp definition isClassDefinition ifTrue: [ - patchOp definition actualClass - ifNotNil: [ - internalStream nextChunkPut: - patchOp definition actualClass definition. - patchOp definition comment ifNotNil: [ - patchOp definition actualClass putCommentOnFile: internalStream ] ] - ifNil: [ - internalStream nextChunkPut: - patchOp definition className , ' removeFromSystem' ] ] ]. - CodeExporter - writeSourceCodeFrom: internalStream - baseName: fileName - isSt: true ] -] - -{ #category : 'accessing' } -MCSnapshotBrowser >> hasExtensions [ - ^self extensionClassNames notEmpty -] - { #category : 'menus' } MCSnapshotBrowser >> inspectSelection [ ^ self methodSelection inspect @@ -495,15 +423,6 @@ MCSnapshotBrowser >> methodsForSelectedClass [ ^ items select: [ :ea | ea className = classSelection and: [ ea isMethodDefinition and: [ ea classIsMeta = self switchIsClass ] ] ] ] -{ #category : 'accessing' } -MCSnapshotBrowser >> methodsForSelectedClassCategory [ - | visibleClasses | - visibleClasses := self visibleClasses. - ^ items select: [:ea | (visibleClasses includes: ea className) - and: [ea isMethodDefinition - and: [ea classIsMeta = self switchIsClass]]]. -] - { #category : 'accessing' } MCSnapshotBrowser >> methodsForSelectedProtocol [ | methods | @@ -516,21 +435,6 @@ MCSnapshotBrowser >> methodsForSelectedProtocol [ ] -{ #category : 'accessing' } -MCSnapshotBrowser >> packageClassNames [ - ^ self packageClasses collect: [:ea | ea className] -] - -{ #category : 'accessing' } -MCSnapshotBrowser >> packageClasses [ - ^ items select: [:ea | ea isClassDefinition] -] - -{ #category : 'listing' } -MCSnapshotBrowser >> packageOrganizations [ - ^ items select: [:ea | ea isOrganizationDefinition] -] - { #category : 'morphic ui' } MCSnapshotBrowser >> performButtonAction: anActionSelector enabled: anEnabledSelector [ (self perform: anEnabledSelector) @@ -727,14 +631,6 @@ MCSnapshotBrowser >> textMorph: aSymbol [ ^ textMorph ] -{ #category : 'listing' } -MCSnapshotBrowser >> visibleCategories [ - ^ ((self packageOrganizations flatCollect: [ :ea | ea categories ]), - (self packageClasses collect: [ :ea | ea category ]), - (self hasExtensions ifTrue: [{ self extensionsCategory }] ifFalse: [#()])) - asSet asSortedCollection -] - { #category : 'listing' } MCSnapshotBrowser >> visibleClasses [ ^ categorySelection = self extensionsCategory