--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/gui/PPDrabBrowser.st Tue Mar 04 22:14:22 2014 +0100
@@ -0,0 +1,383 @@
+"{ Package: 'stx:goodies/petitparser/gui' }"
+
+Object subclass:#PPDrabBrowser
+ instanceVariableNames:'browser input stream output rootClass'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'PetitGui-Core'
+!
+
+
+!PPDrabBrowser methodsFor:'accessing'!
+
+rootClass
+ ^ rootClass
+!
+
+rootModel
+ ^ self subclassesOf: self rootClass
+! !
+
+!PPDrabBrowser methodsFor:'accessing-view'!
+
+production
+ | parser |
+ ^ (parser := self selectedClass new)
+ productionAt: (self selectedSelector
+ ifNil: [ ^ parser ])
+!
+
+selectedClass
+ ^ ((browser paneNamed: #class) port: #selection) value
+!
+
+selectedClass: aClass
+ ((browser paneNamed: #class) update; port: #selection) value: aClass
+!
+
+selectedSelector
+ ^ ((browser paneNamed: #selector) port: #selection) value
+!
+
+selectedSelector: aSelector
+ ((browser paneNamed: #selector) update; port: #selection) value: aSelector
+!
+
+sourceCode
+ ^ (self selectedClass ifNil: [ ^ String new ])
+ sourceCodeAt: (self selectedSelector ifNil: [ #start ])
+ ifAbsent: [ String new ]
+!
+
+sourceCode: aString in: aClass
+ | tree source selector |
+ tree := RBParser parseMethod: aString onError: [ :msg :pos | nil ].
+ source := tree isNil
+ ifTrue: [ aString ]
+ ifFalse: [
+ | rewriter |
+ rewriter := ParseTreeRewriter new.
+ rewriter
+ replace: '`#literal' with: '`#literal asParser' when: [ :node |
+ (node isLiteralNode and: [ node value isString or: [ node value isCharacter ] ])
+ and: [ (node parent isNil or: [ node parent isMessage not or: [ node parent selector ~= #asParser ] ])
+ and: [ (node parents noneSatisfy: [ :each | each isBlock ]) ] ] ];
+ replaceMethod: '`@method: `@args | `@temps | ``@.statements. ``.statement `{ :node | node isReturn not }'
+ with: '`@method: `@args | `@temps | ``@.statements. ^ ``.statement'.
+ (rewriter executeTree: tree)
+ ifTrue: [ rewriter tree newSource ]
+ ifFalse: [ aString ] ].
+ selector := aClass compile: source.
+ (aString numArgs = 0 and: [ (aClass allInstVarNames includes: selector) not ])
+ ifTrue: [ aClass addInstVarNamed: selector asString ].
+ ^ selector
+! !
+
+!PPDrabBrowser methodsFor:'browse'!
+
+browseClassesOn: aBrowser
+ aBrowser tree
+ title: 'Grammars';
+ format: [ :class | class name ];
+ children: [ :class | self subclassesOf: class ];
+ selectionAct: [
+ | className |
+ className := UIManager default
+ request: 'Class name'
+ initialAnswer: ''
+ title: 'New Parser'.
+ className isNil ifFalse: [
+ PPRefactoringUtils new
+ performRefactoring: (PPAddParserRefactoring
+ name: className asSymbol
+ category: #ParserExample
+ superclass: self selectedClass).
+ self selectedClass: (self class environment classNamed: className) ] ]
+ on: $n entitled: 'New ... (n)';
+ selectionAct: [
+ | superclass |
+ superclass := self selectedClass superclass.
+ self performRefactoring: (PPRemoveParserRefactoring onClass: self selectedClass).
+ self selectedClass: superclass ]
+ on: $r entitled: 'Remove (x)';
+ selectionAct: [
+ self selectedClass browse ]
+ on: $b entitled: 'Browse (b)'
+!
+
+browseDynamicOn: aBrowser
+ | tabulator |
+ aBrowser useExplicitNotNil.
+
+ tabulator := aBrowser tabulator.
+ tabulator
+ title: 'Dynamic';
+ useExplicitNotNil;
+ row: #input; row: #output.
+ tabulator transmit
+ to: #input;
+ andShow: [ :a | self browseInputOn: a ].
+ tabulator transmit
+ to: #output;
+ from: #input;
+ andShow: [ :a | self browseOutputOn: a ].
+
+ tabulator transmit
+ from: #output;
+ to: #input->#selectionInterval;
+ when: [ :selection | selection notNil ];
+ transformed: [ :selection | selection second to: selection third ]
+!
+
+browseOn: aComposite
+ aComposite title: PPBrowser label; color: Color yellow muchDarker.
+ aComposite row: [ :row | row column: #class; column: #selector ].
+ aComposite row: [ :row | row column: #part span: 2 ] span: 2.
+ aComposite transmit
+ to: #class;
+ andShow: [ :composite | self browseClassesOn: composite ].
+ aComposite transmit
+ to: #selector;
+ from: #class;
+ andShow: [ :composite | self browseSelectorsOn: composite ].
+ aComposite transmit
+ to: #part;
+ from: #class;
+ from: #selector;
+ andShow: [ :composite | self browsePartsOn: composite ]
+!
+
+browsePartsOn: aComposite
+ aComposite useExplicitNotNil.
+ aComposite tabbedArrangement.
+ self browseStaticOn: aComposite.
+ self browseDynamicOn: aComposite
+!
+
+browseSelectorsOn: aBrowser
+ aBrowser list
+ title: 'Productions';
+ format: [ :class | class asString ];
+ display: [ :class |
+ ((((class allInstVarNames
+ copyWithoutAll: class ignoredNames)
+ copyWithoutAll: self rootClass allInstVarNames)
+ collect: [ :each | each asSymbol ])
+ select: [ :each | class includesSelector: each ])
+ asSortedCollection ];
+ selectionAct: [
+ | selector |
+ selector := UIManager default
+ request: 'Production name'
+ initialAnswer: self selectedSelector
+ title: 'New production'.
+ selector isNil ifFalse: [
+ self performRefactoring: (PPRenameProdcutionRefactoring
+ onClass: self selectedClass
+ rename: self selectedSelector
+ to: selector asSymbol).
+ self selectedSelector: selector asSymbol ] ]
+ on: $r entitled: 'Rename... (r)';
+ selectionAct: [
+ self performRefactoring: (PPRemoveProdcutionRefactoring
+ onClass: self selectedClass
+ production: self selectedSelector).
+ self selectedSelector: nil ]
+ on: $r entitled: 'Remove (x)';
+ selectionAct: [
+ Smalltalk tools browser
+ fullOnClass: self selectedClass
+ selector: self selectedSelector ]
+ on: $b entitled: 'Browse (b)'
+!
+
+browseStaticOn: aBrowser
+ aBrowser useExplicitNotNil.
+ aBrowser tabbedArrangement.
+ self browseSourceOn: aBrowser.
+ self browseGraphOn: aBrowser.
+ self browseCyclesOn: aBrowser.
+ self browseFirstOn: aBrowser.
+ self browseFollowOn: aBrowser.
+ self browseExampleOn: aBrowser
+! !
+
+!PPDrabBrowser methodsFor:'browse-dynamic'!
+
+browseInputOn: aBrowser
+ aBrowser text
+ useExplicitNotNil;
+ display: [ :class :selector | input ];
+ selectionPopulate: #selection on: $s entitled: 'Parse (s)' with: [ :presentation |
+ input := presentation text asString.
+ stream := PPBrowserStream on: input.
+ output := self production end
+ parse: stream.
+ output isPetitFailure
+ ifTrue: [ presentation selectionInterval: (output position + 1 to: output position) ].
+ output ]
+!
+
+browseOutputOn: aBrowser
+ aBrowser text
+ title: 'Result';
+ display: [ output ];
+ act: [:text | output inspect ] entitled: 'Inspect'.
+
+ aBrowser list
+ title: 'Debugger';
+ format: [ :each | (String new: 2 * each fourth withAll: $ ) asText , each first, ' - ', each last printString ];
+ selectionAct: [:list | list selection last inspect ] entitled: 'Inspect token';
+ display: [
+ | depth trace |
+ depth := -1.
+ trace := OrderedCollection new.
+ (self production end transform: [ :each |
+ each name notNil
+ ifTrue: [
+ each >=> [ :s :cc |
+ | t r |
+ depth := depth + 1.
+ trace addLast: (t := Array with: each name with: s position + 1 with: s position with: depth with: Object new with: nil).
+ r := cc value.
+ t at: t size put: r.
+ t at: 3 put: s position.
+ r isPetitFailure
+ ifFalse: [ t at: 1 put: (t at: 1) asText allBold ].
+ depth := depth - 1.
+ r ] ]
+ ifFalse: [ each ] ])
+ parse: input.
+ trace ].
+ aBrowser table
+ title: 'Tally';
+ column: 'Parser' evaluated: [ :each | each first displayName ];
+ column: 'Count' evaluated: [ :each | each second printString ];
+ column: 'Percentage (%)' evaluated: [ :each | each third printString ];
+ display: [ stream asFrequencyTable ].
+ aBrowser table
+ title: 'Profile';
+ column: 'Parser' evaluated: [ :each | each first displayName ];
+ column: 'Time (ms)' evaluated: [ :each | each second printString ];
+ column: 'Percentage (%)' evaluated: [ :each | each third printString ];
+ display: [ stream asTimingTable ].
+ aBrowser morph
+ title: 'Progress';
+ display: [
+ | morph |
+ morph := ScrollPane new.
+ morph color: Color white.
+ morph scroller addMorph: stream asPositionMorph.
+ morph ]
+! !
+
+!PPDrabBrowser methodsFor:'browse-static'!
+
+browseCyclesOn: aBrowser
+ aBrowser list
+ title: 'Cycles';
+ useExplicitNotNil;
+ format: [ :parser | parser displayName ];
+ display: [ :parsers | self production cycleSet ]
+!
+
+browseExampleOn: aBrowser
+ aBrowser text
+ title: 'Example';
+ useExplicitNotNil;
+ display: [ :parsers | self production example ]
+!
+
+browseFirstOn: aBrowser
+ aBrowser list
+ title: 'First';
+ useExplicitNotNil;
+ format: [ :parser | parser displayName ];
+ display: [ :parsers | self production firstSet ]
+!
+
+browseFollowOn: aBrowser
+ aBrowser list
+ title: 'Follow';
+ useExplicitNotNil;
+ format: [ :parser | parser displayName ];
+ display: [ :parsers |
+ | parser |
+ parser := self selectedClass new.
+ parser followSets
+ at: (parser productionAt: self selectedSelector)
+ ifAbsent: [ Array with: nil asParser ] ]
+!
+
+browseGraphOn: aBrowser
+ aBrowser morph
+ title: 'Graph';
+ useExplicitNotNil;
+ display: [ :parsers |
+ | morph |
+ morph := ScrollPane new.
+ morph color: Color white.
+ morph scroller addMorph: self production morphicProduction.
+ morph ]
+!
+
+browseSourceOn: aBrowser
+ aBrowser smalltalkCode
+ title: 'Source';
+ useExplicitNotNil;
+ display: [ self sourceCode ];
+ smalltalkClass: [ self selectedClass ];
+ act: [ :node |
+ | refactoring |
+ refactoring := PPDefineProdcutionRefactoring
+ onClass: self selectedClass
+ source: node text asString
+ protocols: #(production).
+ self performRefactoring: refactoring.
+ self selectedSelector: refactoring selector ]
+ on: $s
+ entitled: 'accept (s)'
+! !
+
+!PPDrabBrowser methodsFor:'initialize-release'!
+
+initialize
+ super initialize.
+ input := String new.
+ output := String new.
+ stream := PPBrowserStream on: input
+! !
+
+!PPDrabBrowser methodsFor:'public'!
+
+openOn: aClass
+ rootClass := aClass.
+ browser := GLMTabulator new.
+ self browseOn: browser.
+ browser openOn: self rootModel
+!
+
+update
+ browser entity: self rootModel
+! !
+
+!PPDrabBrowser methodsFor:'querying'!
+
+performRefactoring: aRefactoring
+ ^ PPRefactoringUtils new performRefactoring: aRefactoring
+!
+
+subclassesOf: aBehavior
+ ^ aBehavior subclasses asSortedCollection: [ :a :b | a name < b name ]
+! !
+
+!PPDrabBrowser class methodsFor:'documentation'!
+
+version
+ ^ '$Header: /cvs/stx/stx/goodies/petitparser/gui/PPDrabBrowser.st,v 1.1 2014-03-04 21:14:22 cg Exp $'
+!
+
+version_CVS
+ ^ '$Header: /cvs/stx/stx/goodies/petitparser/gui/PPDrabBrowser.st,v 1.1 2014-03-04 21:14:22 cg Exp $'
+! !
+