# HG changeset patch
# User Claus Gittinger <cg@exept.de>
# Date 1393967662 -3600
# Node ID a5bd27e8e4c15e5ff3a0f7049c408419cb4a3ed0
# Parent  2562070b22a5f7e6b0c66f83732d8e672ff83b95
initial checkin

diff -r 2562070b22a5 -r a5bd27e8e4c1 gui/PPDrabBrowser.st
--- /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 $'
+! !
+