SystemOrganization addCategory: #'PetitBeta-Processor'!
SystemOrganization addCategory: #'PetitBeta-Tests'!

!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/29/2010 23:13'!
optimize
	"Optimizes the receiving parser for speed and size."

	^ PPOptimizer new optimize: self! !

!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-Tests'!

!PPOptimizerTest class methodsFor: 'accessing' stamp: 'lr 5/31/2010 18:50'!
packageNamesUnderTest
	^ #('PetitBeta')! !

!PPOptimizerTest methodsFor: 'utilities' stamp: 'lr 4/29/2010 23:21'!
optimize: aParser
	^ aParser optimize! !

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

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 5/3/2010 21:49'!
testEmptyChoice
	| grammar |
	grammar := self optimize: PPChoiceParser new.
	self assert: grammar class = PPEpsilonParser! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/28/2010 20:57'!
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/28/2010 20:57'!
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/29/2010 22:10'!
testPostfixChoice
	| grammar |
	grammar := self optimize: (a , b) / (c , b).
	self assert: grammar class = PPSequenceParser.
	self assert: grammar children size = 2.
	self assert: grammar children first class = PPChoiceParser.
	self assert: grammar children first children size = 2.
	self assert: grammar children first children first literal = $a.
	self assert: grammar children first children last literal = $c.
	self assert: grammar children last literal = $b! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/29/2010 22:09'!
testPrefixChoice
	| grammar |
	grammar := self optimize: (a , b) / (a , c).
	self assert: grammar class = PPSequenceParser.
	self assert: grammar children size = 2.
	self assert: grammar children first literal = $a.
	self assert: grammar children last class = PPChoiceParser.
	self assert: grammar children last children size = 2.
	self assert: grammar children last children first literal = $b.
	self assert: grammar children last children last literal = $c! !

!PPOptimizerTest methodsFor: 'testing-delegate' stamp: 'lr 4/19/2010 18:39'!
testReduceDelegate
	| grammar |
	grammar := self optimize: (PPAndParser on: (PPAndParser on: a)).
	self assert: grammar class = PPAndParser.
	self assert: grammar children first class = PPLiteralObjectParser.
	
	grammar := self optimize: (PPNotParser on: (PPNotParser on: a)).
	self assert: grammar class = PPNotParser.
	self assert: grammar children first class = PPLiteralObjectParser.
	
	grammar := self optimize: (PPFlattenParser on: (PPFlattenParser on: a)).
	self assert: grammar class = PPFlattenParser.
	self assert: grammar children first class = PPLiteralObjectParser.
	
	grammar := self optimize: (PPTokenParser on: (PPTokenParser on: a)).
	self assert: grammar class = PPTokenParser.
	self assert: grammar children first class = PPLiteralObjectParser.

	grammar := self optimize: (PPMemoizedParser on: (PPMemoizedParser on: a)).
	self assert: grammar class = PPMemoizedParser.
	self assert: grammar children first class = PPLiteralObjectParser.

	grammar := self optimize: (PPTrimmingParser on: (PPTrimmingParser on: a)).
	self assert: grammar class = PPTrimmingParser.
	self assert: grammar children first class = PPLiteralObjectParser! !

!PPOptimizerTest methodsFor: 'testing-delegate' stamp: 'lr 4/28/2010 20:57'!
testRemoveDelegate
	| grammar |
	grammar := self optimize: a wrapped.
	self assert: grammar class = PPLiteralObjectParser.
	
	grammar := self optimize: a wrapped wrapped.
	self assert: grammar class = PPLiteralObjectParser.
	
	grammar := self optimize: a wrapped / b wrapped wrapped.
	self assert: grammar class = PPChoiceParser.
	self assert: grammar children first class = PPLiteralObjectParser.
	self assert: grammar children last class = PPLiteralObjectParser! !

!PPOptimizerTest methodsFor: 'testing-choice' stamp: 'lr 4/28/2010 20:57'!
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 5/3/2010 21:50'!
testSingleChoice
	| grammar |
	grammar := self optimize: (PPChoiceParser with: a).
	self assert: grammar class = PPLiteralObjectParser! !

Object subclass: #PPOptimizer
	instanceVariableNames: 'rewriter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPOptimizer commentStamp: '<historical>' prior: 0!
PPOptimizer improves the internal structure of a grammar without touching its behavior.

Instance Variables:
	rewriter	<PPRewriter>	The rewriter that knows how to optimize a grammar.!

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 4/29/2010 21:40'!
emptyChoice
	<optimize>

	rewriter
		replace: PPChoiceParser new
		with: PPEpsilonParser new! !

!PPOptimizer methodsFor: 'optimizations' stamp: 'lr 4/29/2010 21:41'!
identityWrapper
	<optimize>
	
	rewriter
		replace: (PPPattern kind: PPDelegateParser)
		withValueFrom: [ :parser | parser children first ]! !

!PPOptimizer methodsFor: 'optimizations' stamp: 'lr 4/29/2010 21:41'!
idepotentDelegate
	<optimize>
	
	rewriter
		replace: PPPattern any
		withValueFrom: [ :parser | parser children first ]
		when: [ :parser |
			parser children size = 1
				and: [ parser class = parser children first class
				and: [ #(PPAndParser PPNotParser PPEndOfInputParser PPFlattenParser PPTokenParser PPMemoizedParser PPTrimmingParser)
					includes: parser class name ] ] ]! !

!PPOptimizer methodsFor: 'initialization' stamp: 'lr 4/29/2010 21:01'!
initialize
	rewriter := PPRewriter new.
	(Pragma allNamed: #optimize in: self class)
		do: [ :each | self perform: each selector ]! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 5/3/2010 21:50'!
nestedChoice
	<optimize>
	
	| before inside after |
	before := PPListPattern any.
	inside := PPListPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / (PPChoiceParser with: inside) / after
		with: before / inside / after! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 4/29/2010 21:40'!
nulledChoice
	<optimize>
	
	| before parser after |
	before := PPListPattern any.
	parser := PPPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / PPEpsilonParser new / parser / after
		with: before / PPEpsilonParser new! !

!PPOptimizer methodsFor: 'public' stamp: 'lr 4/29/2010 21:29'!
optimize: aParser
	"Transform aParser by applying all the matching optimization rules. Repeatedly apply the rules until no more changes can be done."
	
	| current |
	current := aParser.
	[ current := rewriter execute: current.
	  rewriter hasChanged ]
			whileTrue.
	^ current! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 4/29/2010 23:19'!
prefixedChoice
	<optimize>
	
	| before prefix body1 body2 postfix after |
	before := PPListPattern any.
	prefix := PPPattern any.
	body1 := PPListPattern any.
	body2 := PPListPattern any.
	postfix := PPPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / (prefix , body1) / (prefix , body2) / after
		with: before / (prefix , (body1 / body2)) / after.
	rewriter
		replace: before / (body1 , postfix) / (body2 , postfix) / after
		with: before / ((body1 / body2) , postfix) / after! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 4/29/2010 21:41'!
repeatedChoice
	<optimize>
	
	| before parser between after |
	before := PPListPattern any.
	parser := PPPattern any.
	between := PPListPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / parser / between / parser / after
		with: before / parser / between / after! !

!PPOptimizer methodsFor: 'optimizations-choice' stamp: 'lr 5/3/2010 21:50'!
singleChoice
	<optimize>

	| parser |
	parser := PPPattern any.
	rewriter
		replace: (PPChoiceParser with: parser)
		with: parser! !