1 "{ Package: 'stx:goodies/petitparser/gui' }"

     2 

     3 Object subclass:#PPDrabBrowser

     4 	instanceVariableNames:'browser input stream output rootClass'

     5 	classVariableNames:''

     6 	poolDictionaries:''

     7 	category:'PetitGui-Core'

     8 !

     9 

    10 

    11 !PPDrabBrowser methodsFor:'accessing'!

    12 

    13 rootClass

    14 	^ rootClass

    15 !

    16 

    17 rootModel

    18 	^ self subclassesOf: self rootClass

    19 ! !

    20 

    21 !PPDrabBrowser methodsFor:'accessing-view'!

    22 

    23 production

    24 	| parser |

    25 	^ (parser := self selectedClass new)

    26 		productionAt: (self selectedSelector

    27 			ifNil: [ ^ parser ])

    28 !

    29 

    30 selectedClass

    31 	^ ((browser paneNamed: #class) port: #selection) value

    32 !

    33 

    34 selectedClass: aClass

    35 	((browser paneNamed: #class) update; port: #selection) value: aClass

    36 !

    37 

    38 selectedSelector

    39 	^ ((browser paneNamed: #selector) port: #selection) value

    40 !

    41 

    42 selectedSelector: aSelector

    43 	((browser paneNamed: #selector) update; port: #selection) value: aSelector

    44 !

    45 

    46 sourceCode

    47 	^ (self selectedClass ifNil: [ ^ String new ]) 

    48 		sourceCodeAt: (self selectedSelector ifNil: [ #start ])

    49 		ifAbsent: [ String new ]

    50 !

    51 

    52 sourceCode: aString in: aClass

    53         | tree source selector |

    54         tree := RBParser parseMethod: aString onError: [ :msg :pos | nil ].

    55         source := tree isNil

    56                 ifTrue: [ aString ]

    57                 ifFalse: [ 

    58                         | rewriter |

    59                         rewriter := ParseTreeRewriter new.

    60                         rewriter

    61                                 replace: '`#literal' with: '`#literal asParser' when: [ :node |

    62                                         (node isLiteralNode and: [ node value isString or: [ node value isCharacter ] ])

    63                                                 and: [ (node parent isNil or: [ node parent isMessage not or: [ node parent selector ~= #asParser ] ])

    64                                                 and: [ (node parents noneSatisfy: [ :each | each isBlock ]) ] ] ];

    65                                 replaceMethod: '`@method: `@args | `@temps | ``@.statements. ``.statement `{ :node | node isReturn not }' 

    66                                         with: '`@method: `@args | `@temps | ``@.statements. ^ ``.statement'.

    67                         (rewriter executeTree: tree)

    68                                 ifTrue: [ rewriter tree newSource ]

    69                                 ifFalse: [ aString ] ].

    70         selector := aClass compile: source.

    71         (aString numArgs = 0 and: [ (aClass allInstVarNames includes: selector) not ])

    72                 ifTrue: [ aClass addInstVarNamed: selector asString ].

    73         ^ selector

    74 ! !

    75 

    76 !PPDrabBrowser methodsFor:'browse'!

    77 

    78 browseClassesOn: aBrowser

    79 	aBrowser tree

    80 		title: 'Grammars';

    81 		format: [ :class | class name ];

    82 		children: [ :class | self subclassesOf: class ];

    83 		selectionAct: [

    84 			| className |

    85 			className := UIManager default 

    86 				request: 'Class name' 

    87 				initialAnswer: '' 

    88 				title: 'New Parser'.

    89 			className isNil ifFalse: [ 

    90 				PPRefactoringUtils new 

    91 					performRefactoring: (PPAddParserRefactoring

    92 						name: className asSymbol

    93 						category: #ParserExample

    94 						superclass: self selectedClass).

    95 				self selectedClass: (self class environment classNamed: className) ] ]

    96 			on: $n entitled: 'New ... (n)';

    97 		selectionAct: [

    98 			| superclass |

    99 			superclass := self selectedClass superclass.

   100 			self performRefactoring: (PPRemoveParserRefactoring onClass: self selectedClass).

   101 			self selectedClass: superclass ]

   102 			on: $r entitled: 'Remove (x)';

   103 		selectionAct: [

   104 			self selectedClass browse ]

   105 			on: $b entitled: 'Browse (b)'

   106 !

   107 

   108 browseDynamicOn: aBrowser

   109 	| tabulator |

   110 	aBrowser useExplicitNotNil.

   111 	

   112 	tabulator := aBrowser tabulator.

   113 	tabulator

   114 		title: 'Dynamic';

   115 		useExplicitNotNil;

   116 		row: #input; row: #output.

   117 	tabulator transmit

   118 		to: #input;

   119 		andShow: [ :a | self browseInputOn: a ].

   120 	tabulator transmit

   121 		to: #output;

   122 		from: #input;

   123 		andShow: [ :a | self browseOutputOn: a ].

   124 		

   125 	tabulator transmit

   126 		from: #output;

   127 		to: #input->#selectionInterval;

   128 		when: [ :selection | selection notNil ];

   129 		transformed: [ :selection | selection second to: selection third ]

   130 !

   131 

   132 browseOn: aComposite

   133 	aComposite title: PPBrowser label; color: Color yellow muchDarker.

   134 	aComposite row: [ :row | row column: #class; column: #selector ].

   135 	aComposite row: [ :row | row column: #part span: 2 ] span: 2.

   136 	aComposite transmit 

   137 		to: #class; 

   138 		andShow: [ :composite | self browseClassesOn: composite ].

   139 	aComposite transmit 

   140 		to: #selector; 

   141 		from: #class; 

   142 		andShow: [ :composite | self browseSelectorsOn: composite ].

   143 	aComposite transmit

   144 		to: #part;

   145 		from: #class;

   146 		from: #selector;

   147 		andShow: [ :composite | self browsePartsOn: composite ]

   148 !

   149 

   150 browsePartsOn: aComposite

   151 	aComposite useExplicitNotNil.

   152 	aComposite tabbedArrangement.

   153 	self browseStaticOn: aComposite.

   154 	self browseDynamicOn: aComposite

   155 !

   156 

   157 browseSelectorsOn: aBrowser

   158 	aBrowser list

   159 		title: 'Productions';

   160 		format: [ :class | class asString ];

   161 		display: [ :class | 

   162 			((((class allInstVarNames

   163 				copyWithoutAll: class ignoredNames)

   164 				copyWithoutAll: self rootClass allInstVarNames)

   165 				collect: [ :each | each asSymbol ])

   166 				select: [ :each | class includesSelector: each ])

   167 				asSortedCollection ];

   168 		selectionAct: [

   169 			| selector |

   170 			selector := UIManager default 

   171 				request: 'Production name' 

   172 				initialAnswer: self selectedSelector

   173 				title: 'New production'.

   174 			selector isNil ifFalse: [ 

   175 				self performRefactoring: (PPRenameProdcutionRefactoring

   176 					onClass: self selectedClass

   177 					rename: self selectedSelector

   178 					to: selector asSymbol).

   179 				self selectedSelector: selector asSymbol ] ]

   180 			on: $r entitled: 'Rename... (r)';

   181 		selectionAct: [

   182 			self performRefactoring: (PPRemoveProdcutionRefactoring

   183 				onClass: self selectedClass

   184 				production: self selectedSelector).

   185 			self selectedSelector: nil ]

   186 			on: $r entitled: 'Remove (x)';

   187 		selectionAct: [

   188 			Smalltalk tools browser 

   189 				fullOnClass: self selectedClass 

   190 				selector: self selectedSelector ] 

   191 			on: $b entitled: 'Browse (b)'

   192 !

   193 

   194 browseStaticOn: aBrowser

   195 	aBrowser useExplicitNotNil.

   196 	aBrowser tabbedArrangement.

   197 	self browseSourceOn: aBrowser.

   198 	self browseGraphOn: aBrowser.

   199 	self browseCyclesOn: aBrowser.

   200 	self browseFirstOn: aBrowser.

   201 	self browseFollowOn: aBrowser.

   202 	self browseExampleOn: aBrowser

   203 ! !

   204 

   205 !PPDrabBrowser methodsFor:'browse-dynamic'!

   206 

   207 browseInputOn: aBrowser

   208 	aBrowser text

   209 		useExplicitNotNil;

   210 		display: [ :class :selector | input ];

   211 		selectionPopulate: #selection on: $s entitled: 'Parse (s)' with: [ :presentation |

   212 			input := presentation text asString.

   213 			stream := PPBrowserStream on: input.

   214 			output := self production end 

   215 				parse: stream.

   216 			output isPetitFailure

   217 				ifTrue: [ presentation selectionInterval: (output position + 1 to: output position) ].

   218 			output ]

   219 !

   220 

   221 browseOutputOn: aBrowser

   222 	aBrowser text

   223 		title: 'Result';

   224 		display: [ output ];

   225 		act: [:text | output inspect ] entitled: 'Inspect'.

   226 

   227 	aBrowser list

   228 		title: 'Debugger';

   229 		format: [ :each | (String new: 2 * each fourth withAll: $ ) asText , each first, ' - ', each last printString ];

   230 		selectionAct: [:list | list selection last inspect ] entitled: 'Inspect token';

   231 		display: [ 

   232 			| depth trace |

   233 			depth := -1.

   234 			trace := OrderedCollection new.

   235 			(self production end transform: [ :each |

   236 				each name notNil 

   237 					ifTrue: [ 

   238 						each >=> [ :s :cc |

   239 							| t r |

   240 							depth := depth + 1. 

   241 							trace addLast: (t := Array with: each name with: s position + 1 with: s position with: depth with: Object new with: nil).

   242 							r := cc value.

   243 							t at: t size put: r.

   244 							t at: 3 put: s position.

   245 							r isPetitFailure

   246 								ifFalse: [ t at: 1 put: (t at: 1) asText allBold ].

   247 							depth := depth - 1.

   248 							r ] ]

   249 					ifFalse: [ each ] ])

   250 				parse: input.

   251 			trace ].

   252 	aBrowser table 

   253 		title: 'Tally';

   254 		column: 'Parser' evaluated: [ :each | each first displayName ];

   255 		column: 'Count' evaluated: [ :each | each second printString ];

   256 		column: 'Percentage (%)' evaluated: [ :each | each third printString ];

   257 		display: [ stream asFrequencyTable ].

   258 	aBrowser table 

   259 		title: 'Profile';

   260 		column: 'Parser' evaluated: [ :each | each first displayName ];

   261 		column: 'Time (ms)' evaluated: [ :each | each second printString ];

   262 		column: 'Percentage (%)' evaluated: [ :each | each third printString ];

   263 		display: [ stream asTimingTable ].

   264 	aBrowser morph 

   265 		title: 'Progress';

   266 		display: [

   267 			| morph |

   268 			morph := ScrollPane new.

   269 			morph color: Color white.

   270 			morph scroller addMorph: stream asPositionMorph.

   271 			morph ]

   272 ! !

   273 

   274 !PPDrabBrowser methodsFor:'browse-static'!

   275 

   276 browseCyclesOn: aBrowser

   277 	aBrowser list

   278 		title: 'Cycles';

   279 		useExplicitNotNil;

   280 		format: [ :parser | parser displayName ];

   281 		display: [ :parsers | self production cycleSet ]

   282 !

   283 

   284 browseExampleOn: aBrowser

   285 	aBrowser text

   286 		title: 'Example';

   287 		useExplicitNotNil;

   288 		display: [ :parsers | self production example ]

   289 !

   290 

   291 browseFirstOn: aBrowser

   292 	aBrowser list

   293 		title: 'First';

   294 		useExplicitNotNil;

   295 		format: [ :parser | parser displayName ];

   296 		display: [ :parsers | self production firstSet ]

   297 !

   298 

   299 browseFollowOn: aBrowser

   300 	aBrowser list

   301 		title: 'Follow';

   302 		useExplicitNotNil;

   303 		format: [ :parser | parser displayName ];

   304 		display: [ :parsers | 

   305 			| parser |

   306 			parser := self selectedClass new.

   307 			parser followSets

   308 				at: (parser productionAt: self selectedSelector)

   309 				ifAbsent: [ Array with: nil asParser ] ]

   310 !

   311 

   312 browseGraphOn: aBrowser

   313 	aBrowser morph

   314 		title: 'Graph';

   315 		useExplicitNotNil;

   316 		display: [ :parsers |

   317 			| morph |

   318 			morph := ScrollPane new.

   319 			morph color: Color white.

   320 			morph scroller addMorph: self production morphicProduction.

   321 			morph ]

   322 !

   323 

   324 browseSourceOn: aBrowser

   325 	aBrowser smalltalkCode

   326 		title: 'Source';

   327 		useExplicitNotNil;

   328 		display: [ self sourceCode ];

   329 		smalltalkClass: [ self selectedClass ];

   330 		act: [ :node |

   331 			| refactoring |

   332 			refactoring := PPDefineProdcutionRefactoring 	

   333 				onClass: self selectedClass 

   334 				source: node text asString

   335 				protocols: #(production).

   336 			self performRefactoring: refactoring.

   337 			self selectedSelector: refactoring selector ]

   338 		on: $s 

   339 		entitled: 'accept (s)'

   340 ! !

   341 

   342 !PPDrabBrowser methodsFor:'initialize-release'!

   343 

   344 initialize

   345 	super initialize.

   346 	input := String new.

   347 	output := String new.

   348 	stream := PPBrowserStream on: input

   349 ! !

   350 

   351 !PPDrabBrowser methodsFor:'public'!

   352 

   353 openOn: aClass

   354 	rootClass := aClass.

   355 	browser := GLMTabulator new.

   356 	self browseOn: browser.

   357 	browser openOn: self rootModel

   358 !

   359 

   360 update

   361 	browser entity: self rootModel

   362 ! !

   363 

   364 !PPDrabBrowser methodsFor:'querying'!

   365 

   366 performRefactoring: aRefactoring

   367 	^ PPRefactoringUtils new performRefactoring: aRefactoring

   368 !

   369 

   370 subclassesOf: aBehavior

   371 	^ aBehavior subclasses asSortedCollection: [ :a :b | a name < b name ]

   372 ! !

   373 

   374 !PPDrabBrowser class methodsFor:'documentation'!

   375 

   376 version

   377     ^ '$Header: /cvs/stx/stx/goodies/petitparser/gui/PPDrabBrowser.st,v 1.1 2014-03-04 21:14:22 cg Exp $'

   378 !

   379 

   380 version_CVS

   381     ^ '$Header: /cvs/stx/stx/goodies/petitparser/gui/PPDrabBrowser.st,v 1.1 2014-03-04 21:14:22 cg Exp $'

   382 ! !

   383