"{ 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 $'
! !