SystemOrganization addCategory: #'PetitBeta-Core'!

!PPParser methodsFor: '*petitbeta-operations' stamp: 'lr 4/16/2010 15:43'!
dynamicChoice: aParser
	| dynamicChoice |
	^ dynamicChoice := self | aParser / [ :stream |
		| resolution |
		resolution := UIManager default
			chooseFrom: { self name. aParser name }
			values: { self. aParser }
			title: 'Resolve ambiguity'.
		dynamicChoice def: resolution.
		resolution parseOn: stream ] asParser! !

!PPParser methodsFor: '*petitbeta-operations' stamp: 'lr 4/16/2010 21:09'!
whatFollows: aString at: anInteger
	| stream |
	stream := aString asPetitStream.
	(self transform: [ :parser |
		parser ==> [ :node |
			stream position < anInteger
				ifTrue: [ node ]
				ifFalse: [ ^ parser followSets ] ] ])
		parseOn: stream.
	^ #()! !

PPAbstractParseTest subclass: #PPOptimizerTest
	instanceVariableNames: 'a b c'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Core'!

!PPOptimizerTest methodsFor: 'utilities' stamp: 'lr 4/18/2010 18:35'!
optimize: aParser
	^ PPOptimizer new optimize: aParser! !

!PPOptimizerTest methodsFor: 'running' stamp: 'lr 4/18/2010 18:32'!
setUp
	super setUp.
	a := $a asParser.
	b := $b asParser.
	c := $c asParser! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/18/2010 18:44'!
testEmptyChoice
	| grammar |
	grammar := self optimize: (PPChoiceParser withAll: #()).
	self assert: grammar class = PPEpsilonParser! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/18/2010 18:47'!
testNestedChoice
	| grammar |
	grammar := self optimize: a / (b / c).
	self assert: grammar class = PPChoiceParser.
	self assert: grammar children size = 3.
	self assert: grammar children first class = PPLiteralObjectParser.
	self assert: grammar children last class = PPLiteralObjectParser.

	grammar := self optimize: (a / b) / c.
	self assert: grammar class = PPChoiceParser.
	self assert: grammar children size = 3.
	self assert: grammar children first class = PPLiteralObjectParser.
	self assert: grammar children last class = PPLiteralObjectParser! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/18/2010 18:47'!
testNulledChoice
	| grammar |
	grammar := self optimize: a / nil asParser / b / c.
	self assert: grammar class = PPChoiceParser.
	self assert: grammar children size = 2.
	self assert: grammar children first class = PPLiteralObjectParser.
	self assert: grammar children last class = PPEpsilonParser.	

	grammar := self optimize: a / b / nil asParser / c.
	self assert: grammar class = PPChoiceParser.
	self assert: grammar children size = 3.
	self assert: grammar children first class = PPLiteralObjectParser.
	self assert: grammar children last class = PPEpsilonParser.	
	
	grammar := self optimize: a / b / c / nil asParser.
	self assert: grammar class = PPChoiceParser.
	self assert: grammar children size = 4.
	self assert: grammar children first class = PPLiteralObjectParser.
	self assert: grammar children last class = PPEpsilonParser
! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/18/2010 18:46'!
testRepeatedChoice
	| grammar |
	grammar := self optimize: a / a / b / c.
	self assert: grammar class = PPChoiceParser.
	self assert: grammar children size = 3.
	
	grammar := self optimize: a / b / a / a.
	self assert: grammar class = PPChoiceParser.
	self assert: grammar children size = 2.

	grammar := self optimize: a / a / a / a.
	self assert: grammar class = PPLiteralObjectParser! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/18/2010 18:45'!
testSingleChoice
	| grammar |
	grammar := self optimize: (PPChoiceParser withAll: (Array with: a)).
	self assert: grammar class = PPLiteralObjectParser! !

Object subclass: #PPOptimizer
	instanceVariableNames: 'typeMap'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Core'!

!PPOptimizer commentStamp: '<historical>' prior: 0!
- fold duplicate productions into a single production
- combine prefixes of an ordered choice
- fold nested choices and sequences into the embedding choice or sequence (done, not possible for sequences)
- eliminate choices and sequences with only one alternative or element (done, not possible for sequences)
- reduce repetitions and options to their simplest form
- reduce trivial character classes and string literals to character
- transform direct left-recursions into equivalent right-recursions
- implement direct left-recursions as repetitions, not recursions.
!

!PPOptimizer methodsFor: 'initialization' stamp: 'lr 4/17/2010 17:07'!
initialize
	self initializeMap! !

!PPOptimizer methodsFor: 'initialization' stamp: 'lr 4/17/2010 17:07'!
initializeMap
	| class |
	typeMap := Dictionary new.
	(Pragma allNamed: #optimize: in: self class) do: [ :pragma |
		class := Smalltalk classNamed: pragma arguments first.
		class isNil ifFalse: [
			class withAllSubclassesDo: [ :each | 
				(typeMap at: each name ifAbsentPut: [ Set new ])
					add: pragma selector ] ] ]! !

!PPOptimizer methodsFor: 'public' stamp: 'lr 4/18/2010 13:04'!
optimize: aParser
	"Transform aParser by applying all the matching optimization rules."

	^ aParser transform: [ :parser |
		(typeMap at: parser class name ifAbsent: [ #() ])
			inject: parser
			into: [ :result :selector | self perform: selector with: result ] ]! !

!PPOptimizer methodsFor: 'optimizations' stamp: 'lr 4/18/2010 18:29'!
reduceChoice: aChoiceParser
	"Reduce nested choices and remove repeated elements."
	<optimize: #PPChoiceParser>

	| choices index |
	choices := OrderedCollection new.
	self reduceChoice: aChoiceParser into: choices.
	index := choices
		findFirst: [ :parser | parser class = PPEpsilonParser ].
	index isZero
		ifFalse: [ choices := choices copyFrom: 1 to: index ].	
	choices isEmpty
		ifTrue: [ ^ PPEpsilonParser new ].
	choices size = 1
		ifTrue: [ ^ choices first ].
	aChoiceParser children size = choices size
		ifTrue: [ ^ aChoiceParser ].
	^ aChoiceParser class withAll: choices! !

!PPOptimizer methodsFor: 'optimizations' stamp: 'lr 4/18/2010 13:21'!
reduceChoice: aChoiceParser into: aCollection
	aChoiceParser children do: [ :parser |
		aChoiceParser class = parser class
			ifTrue: [ self reduceChoice: parser into: aCollection ]
			ifFalse: [
				(aCollection includes: parser)
					ifFalse: [ aCollection addLast: parser ] ] ]! !