"{ 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.2 2014-03-04 21:19:25 cg Exp $'
!

version_CVS
    ^ '$Header: /cvs/stx/stx/goodies/petitparser/gui/PPDrabBrowser.st,v 1.2 2014-03-04 21:19:25 cg Exp $'
! !