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

!PPPluggableParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 11:02'!
match: aParser inContext: aDictionary seen: aSet
	^ (super match: aParser inContext: aDictionary seen: aSet) and: [ self block = aParser block ]! !

!PPEpsilonParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 12:01'!
match: aParser inContext: aDictionary seen: anIdentitySet
	^ self class = aParser class! !

!PPTokenParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 11:01'!
match: aParser inContext: aDictionary seen: aSet
	^ (super match: aParser inContext: aDictionary seen: aSet) and: [ self tokenClass = aParser tokenClass ]! !

!PPLiteralParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 12:01'!
match: aParser inContext: aDictionary seen: anIdentitySet
	^ self class = aParser class and: [ self literal = aParser literal ]! !

!PPListParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 08:15'!
copyInContext: aDictionary seen: aSeenDictionary
	| copy copies |
	aSeenDictionary at: self ifPresent: [ :value | ^ value ].
	copy := aSeenDictionary at: self put: self copy.
	copies := OrderedCollection new.
	parsers do: [ :each |
		| result |
		result := each 
			copyInContext: aDictionary
			seen: aSeenDictionary.
		result isCollection
			ifTrue: [ copies addAll: result ]
			ifFalse: [ copies add: result ] ].
	^ copy
		setParsers: copies;
		yourself! !

!PPListParser methodsFor: '*petitbeta-storing' stamp: 'lr 5/1/2010 16:12'!
storeSeparatorOn: aStream
	self subclassResponsibility! !

!PPParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 07:49'!
copyInContext: aDictionary
	^ self copyInContext: aDictionary seen: IdentityDictionary new! !

!PPParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 08:11'!
copyInContext: aDictionary seen: aSeenDictionary
	^ aSeenDictionary at: self ifAbsentPut: [ self copy ]! !

!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-matching' stamp: 'lr 4/29/2010 23:14'!
match: aParser inContext: aDictionary
	^ self match: aParser inContext: aDictionary seen: IdentitySet new! !

!PPParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 11:07'!
match: aParser inContext: aDictionary seen: aSet
	"This is the default implementation to match two parsers. This code can properly handle recursion. This is code is supposed to be overridden in subclasses that add new state."

	(self == aParser or: [ aSet includes: self ])
		ifTrue: [ ^ true ].
	aSet add: self.
	^ self class = aParser class
		and: [ self matchList: self children against: aParser children inContext: aDictionary seen: aSet ]! !

!PPParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/29/2010 23:07'!
matchList: matchList against: parserList inContext: aDictionary seen: aSet
	^ self matchList: matchList index: 1 against: parserList index: 1 inContext: aDictionary seen: aSet! !

!PPParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/29/2010 23:10'!
matchList: matchList index: matchIndex against: parserList index: parserIndex inContext: aDictionary seen: aSet
	| parser currentIndex currentDictionary currentSeen parsers |
	matchList size < matchIndex
		ifTrue: [ ^ parserList size < parserIndex ].
	parser := matchList at: matchIndex.
	parser class = PPListPattern ifTrue: [
		currentIndex := parserIndex - 1.
		[ currentDictionary := aDictionary copy.
		currentSeen := aSet copy.
		parserList size < currentIndex
			or: [ 
				parsers := parserList copyFrom: parserIndex to: currentIndex.
				(currentDictionary at: parser ifAbsentPut: [ parsers ]) = parsers
					and: [ 
						(self
							matchList: matchList
							index: matchIndex + 1
							against: parserList
							index: currentIndex + 1
							inContext: currentDictionary
							seen: currentSeen)
							ifTrue: [ 
								currentDictionary keysAndValuesDo: [ :key :value | aDictionary at: key put: value ].
								^ true ].
						false ] ] ] whileFalse: [ currentIndex := currentIndex + 1 ].
		^ false ].
	parserList size < parserIndex
		ifTrue: [ ^ false ].
	(parser match: (parserList at: parserIndex) inContext: aDictionary seen: aSet)
		ifFalse: [ ^ false ].
	^ self
		matchList: matchList
		index: matchIndex + 1
		against: parserList
		index: parserIndex + 1
		inContext: aDictionary
		seen: aSet! !

!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.
	^ #()! !

PPParser subclass: #PPPattern
	instanceVariableNames: 'verificationBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPPattern commentStamp: '<historical>' prior: 0!
PPPattern is meta-parser that is solely used to match other types of parsers. It cannot be used for actually parsing something. The constructor method determines what can be matched.!

PPPattern subclass: #PPListPattern
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPPattern class methodsFor: 'instance creation' stamp: 'lr 4/30/2010 08:47'!
any
	"Matches all parsers."

	^ self on: [ :parser :context | true ]! !

!PPPattern class methodsFor: 'instance creation' stamp: 'lr 4/30/2010 08:46'!
kind: aBehavior
	"Matches parsers that are of the class aBehavior."

	^ self on: [ :parser :context | parser class = aBehavior ]! !

!PPPattern class methodsFor: 'instance creation' stamp: 'lr 4/30/2010 08:46'!
name: aString
	"Matches parsers with the name aString."

	^ self on: [ :parser :context | parser name = aString ]! !

!PPPattern class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 10:21'!
new
	self error: 'Use an explicit constructur on ' , self name! !

!PPPattern class methodsFor: 'instance creation' stamp: 'lr 4/30/2010 08:46'!
on: aBlock
	"Matches parsers that satisfy an arbitrary condition in aBlock."

	^ self basicNew initializeOn: aBlock! !

!PPPattern methodsFor: 'comparing' stamp: 'lr 4/29/2010 10:33'!
= aParser
	^ self == aParser or: [ self name notNil and: [ self name = aParser name ] ]! !

!PPPattern methodsFor: 'matching' stamp: 'lr 4/30/2010 07:53'!
copyInContext: aDictionary seen: aSeenDictionary
	^ aDictionary at: self! !

!PPPattern methodsFor: 'comparing' stamp: 'lr 4/29/2010 10:33'!
hash
	^ self identityHash! !

!PPPattern methodsFor: 'initialization' stamp: 'lr 4/29/2010 10:20'!
initializeOn: aBlock
	verificationBlock := aBlock! !

!PPPattern methodsFor: 'matching' stamp: 'lr 4/30/2010 12:01'!
match: aParser inContext: aDictionary seen: anIdentitySet
	(verificationBlock value: aParser value: aDictionary)
		ifFalse: [ ^ false ].
	^ (aDictionary at: self ifAbsentPut: [ aParser ])
		match: aParser inContext: aDictionary seen: anIdentitySet! !

!PPPattern methodsFor: 'parsing' stamp: 'lr 4/30/2010 08:48'!
parseOn: aStream
	"This is just a pattern used for matching. It should not be used in actual grammars."

	self shouldNotImplement! !

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

!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 4/29/2010 23:21'!
testEmptyChoice
	| grammar |
	grammar := self optimize: (PPChoiceParser withAll: #()).
	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 4/28/2010 20:57'!
testSingleChoice
	| grammar |
	grammar := self optimize: (PPChoiceParser withAll: (Array with: a)).
	self assert: grammar class = PPLiteralObjectParser! !

PPAbstractParseTest subclass: #PPRewriterTest
	instanceVariableNames: 'rewriter'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Tests'!

!PPRewriterTest methodsFor: 'running' stamp: 'lr 4/29/2010 08:47'!
setUp
	rewriter := PPRewriter new! !

!PPRewriterTest methodsFor: 'testing' stamp: 'lr 4/29/2010 17:19'!
testDuplicationRemoval
	| duplicate before between after result |
	duplicate := PPPattern any.
	before := PPListPattern any.
	between := PPListPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / duplicate / between / duplicate / after
		with: before / duplicate / between / after.
	
	result := rewriter execute: $a asParser / $a asParser.
	self assert: result children size = 1.
	self assert: result children first literal = $a.
	
	result := rewriter execute: $b asParser / $a asParser / $a asParser.
	self assert: result children size = 2.
	self assert: result children first literal = $b.
	self assert: result children last literal = $a.
	
	result := rewriter execute: $a asParser / $b asParser / $a asParser.
	self assert: result children size = 2.
	self assert: result children first literal = $a.
	self assert: result children last literal = $b.
	
	result := rewriter execute: $a asParser / $a asParser / $b asParser.
	self assert: result children size = 2.
	self assert: result children first literal = $a.
	self assert: result children last literal = $b	! !

!PPRewriterTest methodsFor: 'testing' stamp: 'lr 4/29/2010 10:51'!
testPatternRemoval
	| pattern result |
	pattern := PPPattern kind: PPLiteralObjectParser.
	rewriter
		replace: pattern / pattern
		with: pattern.
	
	result := rewriter execute: $a asParser / $a asParser.
	self assert: result class = PPLiteralObjectParser.
	self assert: result literal = $a! !

!PPRewriterTest methodsFor: 'testing' stamp: 'lr 4/29/2010 10:50'!
testPatternReplacement
	| pattern result |
	pattern := PPPattern kind: PPLiteralObjectParser.
	rewriter
		replace: pattern
		with: pattern , pattern.
	
	result := rewriter execute: $a asParser.
	self assert: result class = PPSequenceParser.
	self assert: result children first literal = $a.
	self assert: result children last literal = $a! !

!PPRewriterTest methodsFor: 'testing' stamp: 'lr 4/29/2010 10:44'!
testReplaceLiteral
	| result |
	rewriter
		replace: $a asParser 
		with: $b asParser.
	
	result := rewriter execute: $a asParser.
	self assert: result literal = $b.
	
	result := rewriter execute: $c asParser.
	self assert: result literal = $c.
	
	result := rewriter execute: $a asParser , $b asParser , $c asParser.
	self assert: result children size = 3.
	self assert: result children first literal = $b.
	self assert: result children last literal = $c! !

!PPRewriterTest methodsFor: 'testing' stamp: 'lr 4/29/2010 10:43'!
testSwapTwoPattern
	| first second result |
	first := PPPattern any.
	second := PPPattern any.
	rewriter
		replace: first , second
		with: second , first.
	
	result := rewriter execute: $a asParser , $b asParser.
	self assert: result children first literal = $b.
	self assert: result children last literal = $a.
	
	result := rewriter execute: $a asParser / $b asParser.
	self assert: result children first literal = $a.
	self assert: result children last literal = $b! !

!PPRewriterTest methodsFor: 'testing' stamp: 'lr 4/29/2010 10:44'!
testWrapLiteral
	| result |
	rewriter
		replace: $a asParser
		withValueFrom: [ :parser | parser token ].
	
	result := rewriter execute: $a asParser.
	self assert: result class = PPTokenParser.
	self assert: result children first literal = $a.
	
	result := rewriter execute: $c asParser.
	self assert: result literal = $c.
	
	result := rewriter execute: $a asParser , $b asParser.
	self assert: result children first class = PPTokenParser.
	self assert: result children first children first literal = $a.
	self assert: result children last class = PPLiteralObjectParser.
	self assert: result children last literal = $b! !

PPAbstractParseTest subclass: #PPSearcherTest
	instanceVariableNames: 'searcher'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Tests'!

!PPSearcherTest class methodsFor: 'accessing' stamp: 'lr 4/29/2010 00:52'!
packageNamesUnderTest
	^ #('PetitBeta')! !

!PPSearcherTest methodsFor: 'running' stamp: 'lr 4/29/2010 08:09'!
setUp
	searcher := PPSearcher new! !

!PPSearcherTest methodsFor: 'testing' stamp: 'lr 4/28/2010 23:04'!
testAnyPattern
	| result |
	searcher
		matches: PPPattern any
		do: [ :parser :answer | answer add: parser; yourself ].

	result := searcher
		execute: ($a asParser)
		initialAnswer: OrderedCollection new.
	self assert: result size = 1.
	
	result := searcher
		execute: ($a asParser star)
		initialAnswer: OrderedCollection new.
	self assert: result size = 2.
	
	result := searcher
		execute: ($a asParser , $b asParser)
		initialAnswer: OrderedCollection new.
	self assert: result size = 3! !

!PPSearcherTest methodsFor: 'testing-copy' stamp: 'lr 4/30/2010 08:04'!
testCopyMatchDelegate
	| old new |
	old := $a asParser token trim.
	new := old copyInContext: Dictionary new.
	self assert: (old match: old inContext: Dictionary new).
	self assert: (old match: new inContext: Dictionary new).
	self deny: (old == new).! !

!PPSearcherTest methodsFor: 'testing-copy' stamp: 'lr 4/30/2010 08:04'!
testCopyMatchList
	| old new |
	old := $a asParser , $b asParser , $c asParser.
	new := old copyInContext: Dictionary new.
	self assert: (old match: old inContext: Dictionary new).
	self assert: (old match: new inContext: Dictionary new).
	self deny: (old == new).! !

!PPSearcherTest methodsFor: 'testing-copy' stamp: 'lr 4/30/2010 08:04'!
testCopyMatchLiteral
	| old new |
	old := $a asParser.
	new := old copyInContext: Dictionary new.
	self assert: (old match: old inContext: Dictionary new).
	self assert: (old match: new inContext: Dictionary new).
	self deny: (old == new).! !

!PPSearcherTest methodsFor: 'testing-copy' stamp: 'lr 4/30/2010 08:15'!
testCopyMatchRecursiveDelegate
	| old new |
	old := PPDelegateParser new.
	old setParser: old.
	new := old copyInContext: Dictionary new.
	self assert: (old match: old inContext: Dictionary new).
	self assert: (old match: new inContext: Dictionary new).
	self deny: (old == new).! !

!PPSearcherTest methodsFor: 'testing-copy' stamp: 'lr 4/30/2010 08:16'!
testCopyMatchRecursiveList
	| old new |
	old := PPChoiceParser new.
	old setParsers: (Array with: old).
	new := old copyInContext: Dictionary new.
	self assert: (old match: old inContext: Dictionary new).
	self assert: (old match: new inContext: Dictionary new).
	self deny: (old == new).! !

!PPSearcherTest methodsFor: 'testing' stamp: 'lr 4/28/2010 23:05'!
testKindPattern
	| result |
	searcher 
		matches: (PPPattern kind: PPLiteralObjectParser)
		do: [ :parser :answer | answer add: parser; yourself ].

	result := searcher
		execute: ($a asParser)
		initialAnswer: OrderedCollection new.
	self assert: result size = 1.
	self assert: (result allSatisfy: [ :each | each class = PPLiteralObjectParser ]).
	
	result := searcher
		execute: (#any asParser)
		initialAnswer: OrderedCollection new.
	self assert: result isEmpty.
	
	result := searcher
		execute: ($a asParser / #any asParser , $b asParser)
		initialAnswer: OrderedCollection new.
	self assert: result size = 2.
	self assert: (result allSatisfy: [ :each | each class = PPLiteralObjectParser ])! !

!PPSearcherTest methodsFor: 'testing-lists' stamp: 'lr 4/29/2010 00:37'!
testListInfix
	| pattern result |
	searcher
		matches: PPListPattern any , $a asParser , PPListPattern any
		do: [ :parser :answer | true ].
	
	result := searcher
		execute: $a asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $a asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $b asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $a asParser , $a asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $a asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $a asParser , $b asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $a asParser , $a asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $b asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $a asParser , $b asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $a asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $b asParser , $b asParser
		initialAnswer: false.
	self deny: result! !

!PPSearcherTest methodsFor: 'testing-lists' stamp: 'lr 4/29/2010 00:37'!
testListPostfix
	| pattern result |
	searcher
		matches: PPListPattern any , $b asParser
		do: [ :parser :answer | true ].
	
	result := searcher
		execute: $a asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $a asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $b asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $a asParser , $a asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $b asParser , $a asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $a asParser , $b asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $a asParser , $a asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $b asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $a asParser , $b asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $a asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $b asParser , $b asParser
		initialAnswer: false.
	self assert: result! !

!PPSearcherTest methodsFor: 'testing-lists' stamp: 'lr 4/29/2010 00:37'!
testListPrefix
	| pattern result |
	searcher
		matches: $a asParser , PPListPattern any
		do: [ :parser :answer | true ].
	
	result := searcher
		execute: $a asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $a asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $b asParser , $b asParser
		initialAnswer: false.
	self deny: result.
	
	
	
	result := searcher
		execute: $a asParser , $a asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $a asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $a asParser , $b asParser , $a asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $a asParser , $a asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $b asParser , $a asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $a asParser , $b asParser , $b asParser
		initialAnswer: false.
	self assert: result.
	
	result := searcher
		execute: $b asParser , $a asParser , $b asParser
		initialAnswer: false.
	self deny: result.
	
	result := searcher
		execute: $b asParser , $b asParser , $b asParser
		initialAnswer: false.
	self deny: result! !

!PPSearcherTest methodsFor: 'testing' stamp: 'lr 4/29/2010 00:10'!
testMultiplePattern
	| result |
	searcher
		matches: $a asParser
		do: [ :parser :answer | answer first add: parser. answer ].
	searcher
		matches: PPPattern any
		do: [ :parser :answer | answer second add: parser. answer ].

	result := searcher
		execute: $a asParser , $a asParser , $b asParser
		initialAnswer: (Array 
			with: OrderedCollection new 
			with: OrderedCollection new).
	self assert: result first size = 2.
	self assert: result second size = 4! !

!PPSearcherTest methodsFor: 'testing' stamp: 'lr 4/28/2010 23:04'!
testNamePattern
	| result |
	searcher 
		matches: (PPPattern name: 'foo')
		do: [ :parser :answer | answer add: parser; yourself ].

	result := searcher 
		execute: ($a asParser)
		initialAnswer: OrderedCollection new.
	self assert: result isEmpty.
	
	result := searcher
		execute: ($a asParser name: 'foo')
		initialAnswer: OrderedCollection new.
	self assert: result size = 1.
	self assert: result first name = 'foo'.
	
	result := searcher
		execute: ($a asParser name: 'bar') , ($b asParser name: 'foo')
		initialAnswer: OrderedCollection new.
	self assert: result size = 1.
	self assert: result first name = 'foo'! !

!PPSearcherTest methodsFor: 'testing' stamp: 'lr 4/29/2010 21:03'!
testNewPattern
	self 
		should: [ PPPattern new ]
		raise: Error! !

!PPSearcherTest methodsFor: 'testing' stamp: 'lr 4/30/2010 07:58'!
testRecursivePattern
	| recursive |
	recursive := PPDelegateParser new.
	recursive setParser: recursive.
	searcher 
		matches: recursive 
		do: [ :parser :answer | parser ].
	
	self assert: (searcher execute: recursive) = recursive.
	self assert: (searcher execute: $a asParser) isNil.
	self assert: (searcher execute: $a asParser / $b asParser star) isNil! !

!PPSearcherTest methodsFor: 'testing' stamp: 'lr 4/28/2010 23:20'!
testRepeatedPattern
	| pattern result |
	searcher
		matches: (pattern := PPPattern any) , pattern
		do: [ :parser :answer | answer add: parser; yourself ].

	result := searcher
		execute: ($a asParser , $b asParser)
		initialAnswer: OrderedCollection new.
	self assert: result isEmpty.
	
	result := searcher
		execute: $a asParser , $a asParser
		initialAnswer: OrderedCollection new.
	self assert: result size = 1.
	
	result := searcher
		execute: ($a asParser , ($a asParser , $b asParser))
		initialAnswer: OrderedCollection new.
	self assert: result isEmpty.
	
	result := searcher
		execute: ($b asParser , ($a asParser , $a asParser))
		initialAnswer: OrderedCollection new.
	self assert: result size = 1! !

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

!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/2/2010 19:27'!
nestedChoice
	<optimize>
	
	| before inside after |
	before := PPListPattern any.
	inside := PPListPattern any.
	after := PPListPattern any.
	rewriter
		replace: before / (PPChoiceParser withAll: (Array 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/2/2010 19:27'!
singleChoice
	<optimize>

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

Object subclass: #PPProcessor
	instanceVariableNames: 'searches context'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPProcessor commentStamp: '<historical>' prior: 0!
PPProcessor is an abstract superclass to PPRewriter and PPSearcher. It implements common functionality to search and transform grammars.

The implementation of these matching algorithms is heavily inspired from the refactoring engine by Don Roberts and John Brant. Contrary to the original implementation that worked on syntax trees, this implementation was generalized and works on recursive pattern and search graphs.!

!PPProcessor class methodsFor: 'instance creation' stamp: 'lr 4/30/2010 08:34'!
new
	^ self basicNew initialize! !

!PPProcessor methodsFor: 'rules' stamp: 'lr 4/29/2010 09:34'!
addRule: aGrammarRule
	searches add: (aGrammarRule setOwner: self)! !

!PPProcessor methodsFor: 'private' stamp: 'lr 4/29/2010 09:34'!
context
	^ context! !

!PPProcessor methodsFor: 'initialization' stamp: 'lr 4/29/2010 09:38'!
initialize
	super initialize.
	searches := OrderedCollection new.
	context := Dictionary new! !

!PPProcessor methodsFor: 'private' stamp: 'lr 4/29/2010 09:42'!
perform: aRule on: aParser
	context := Dictionary new.
	^ aRule performOn: aParser! !

PPProcessor subclass: #PPRewriter
	instanceVariableNames: 'changed'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPRewriter commentStamp: '<historical>' prior: 0!
PPRewriter walks over a grammar graph and transforms its parsers. If the grammar is modified, #hasChanged returns true.!

!PPRewriter methodsFor: 'public' stamp: 'lr 4/29/2010 21:31'!
execute: aParser
	"Perform the replace rules of the receiver on aParser, answer the resulting parser."

	| old result |
	old := context.
	changed := false.
	context := Dictionary new.
	result := aParser transform: [ :each |
		| transformed |
		transformed := searches
			inject: each
			into: [ :parser :rule | 
				(self perform: rule on: parser)
					ifNil: [ parser ] ].
		transformed == each
			ifFalse: [ changed := true ].
		transformed ].
	context := old.
	^ result! !

!PPRewriter methodsFor: 'testing' stamp: 'lr 4/29/2010 21:28'!
hasChanged
	"Answer if the last operation has changed anything."
	
	^ changed! !

!PPRewriter methodsFor: 'initialization' stamp: 'lr 4/29/2010 21:28'!
initialize
	super initialize.
	changed := false! !

!PPRewriter methodsFor: 'accessing' stamp: 'lr 4/29/2010 10:16'!
replace: aSearchParser with: aReplaceParser
	self replace: aSearchParser with: aReplaceParser when: [ :node | true ]! !

!PPRewriter methodsFor: 'accessing' stamp: 'lr 4/29/2010 08:25'!
replace: aSearchParser with: aReplaceParser when: aValidationBlock
	self addRule: (PPParserReplaceRule searchFor: aSearchParser replaceWith: aReplaceParser when: aValidationBlock)! !

!PPRewriter methodsFor: 'accessing' stamp: 'lr 4/29/2010 10:16'!
replace: aSearchParser withValueFrom: aReplaceBlock
	self replace: aSearchParser withValueFrom: aReplaceBlock when: [ :node | true ]! !

!PPRewriter methodsFor: 'accessing' stamp: 'lr 4/29/2010 08:25'!
replace: aSearchParser withValueFrom: aReplaceBlock when: aValidationBlock
	self addRule: (PPBlockReplaceRule searchFor: aSearchParser replaceWith: aReplaceBlock when: aValidationBlock)! !

PPProcessor subclass: #PPSearcher
	instanceVariableNames: 'answer'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPSearcher commentStamp: '<historical>' prior: 0!
PPSearcher walks over a grammar specification and matches its parsers against the patterns using #match:inContext:.!

!PPSearcher methodsFor: 'private' stamp: 'lr 4/29/2010 09:46'!
answer
	^ answer! !

!PPSearcher methodsFor: 'public' stamp: 'lr 4/29/2010 09:45'!
execute: aParser
	"Perform the search rules of the receiver on aParser. Answer the result of the search."

	^ self execute: aParser initialAnswer: nil! !

!PPSearcher methodsFor: 'public' stamp: 'lr 4/29/2010 09:58'!
execute: aParser initialAnswer: anObject
	"Perform the search rules of the receiver on aParser. Inject anObject into the matches and answer the result."

	| old |
	old := context.
	answer := anObject.
	context := Dictionary new.
	aParser allParsersDo: [ :each |
		searches
			do: [ :rule | self perform: rule on: each ] ].
	context := old.
	^ answer! !

!PPSearcher methodsFor: 'rules' stamp: 'lr 4/29/2010 09:48'!
matches: aParser do: anAnswerBlock
	"Add a search expression aParser, evaluate anAnswerBlock with the matched node and the previous answer."

	self addRule: (PPSearchRule searchFor: aParser thenDo: anAnswerBlock)! !

!PPSearcher methodsFor: 'rules' stamp: 'lr 4/29/2010 09:56'!
matchesAnyOf: aCollectionOfParsers do: anAnswerBlock
	"Add a collection of search expressions aCollectionOfParsers, evaluate anAnswerBlock with the matched node and the previous answer."
	
	aCollectionOfParsers
		do: [ :each | self matches: each do: anAnswerBlock ]! !

!PPSearcher methodsFor: 'initialization' stamp: 'lr 4/29/2010 09:37'!
setAnswer: anObject
	answer := anObject! !

Object subclass: #PPRule
	instanceVariableNames: 'owner search'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPRule commentStamp: '<historical>' prior: 0!
PPRule is the abstract superclass of all of the grammar search rules. A rule is the first class representation of a particular pattern to search for. The owner of the rule is the algorithms that actually executes the search. This arrangement allows multiple searches to be conducted by a single processor.!

PPRule subclass: #PPReplaceRule
	instanceVariableNames: 'verificationBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPReplaceRule commentStamp: '<historical>' prior: 0!
PPReplaceRule is the abstract superclass of all of the transforming rules. The rules change the grammar by replacing the node that matches the rule. Subclasses implement different strategies for this replacement.!

PPReplaceRule subclass: #PPBlockReplaceRule
	instanceVariableNames: 'replaceBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPBlockReplaceRule commentStamp: '<historical>' prior: 0!
PPBlockReplaceRule replaces the matching node by the result of evaluating replaceBlock. This allows arbitrary computation to come up with a replacement.!

!PPBlockReplaceRule class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 08:28'!
searchFor: aSearchParser replaceWith: aReplaceBlock when: aVerificationBlock
	^ (self searchFor: aSearchParser) 
		setReplaceBlock: aReplaceBlock;
		setVerificationBlock: aVerificationBlock;
		yourself! !

!PPBlockReplaceRule methodsFor: 'matching' stamp: 'lr 4/29/2010 08:15'!
foundMatchFor: aParser 
	^ replaceBlock value: aParser! !

!PPBlockReplaceRule methodsFor: 'initialization' stamp: 'lr 4/29/2010 08:29'!
setReplaceBlock: aBlock
	replaceBlock := aBlock! !

PPReplaceRule subclass: #PPParserReplaceRule
	instanceVariableNames: 'replaceParser'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPParserReplaceRule commentStamp: '<historical>' prior: 0!
PPParserReplaceRule replaces a matched grammar with another grammar, which may include patterns from the matching grammar.!

!PPParserReplaceRule class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 08:28'!
searchFor: aSearchParser replaceWith: aReplaceParser when: aVerificationBlock
	^ (self searchFor: aSearchParser) 
		setReplaceParser: aReplaceParser;
		setVerificationBlock: aVerificationBlock;
		yourself! !

!PPParserReplaceRule methodsFor: 'matching' stamp: 'lr 4/29/2010 08:16'!
foundMatchFor: aParser 
	^ replaceParser copyInContext: owner context! !

!PPParserReplaceRule methodsFor: 'initialization' stamp: 'lr 4/29/2010 08:29'!
setReplaceParser: aParser
	replaceParser := aParser! !

!PPReplaceRule methodsFor: 'matching' stamp: 'lr 4/29/2010 08:14'!
canMatch: aParser 
	^ verificationBlock value: aParser! !

!PPReplaceRule methodsFor: 'initialization' stamp: 'lr 4/29/2010 08:13'!
initialize
	super initialize.
	verificationBlock := [ :parser | true ]! !

!PPReplaceRule methodsFor: 'initialization' stamp: 'lr 4/29/2010 08:26'!
setVerificationBlock: aBlock
	verificationBlock := aBlock! !

!PPRule class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 09:51'!
new
	^ self basicNew initialize! !

!PPRule class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 09:51'!
searchFor: aParser
	^ self new setSearch: aParser! !

!PPRule methodsFor: 'matching' stamp: 'lr 4/28/2010 21:10'!
canMatch: aParser 
	^ true! !

!PPRule methodsFor: 'matching' stamp: 'lr 4/29/2010 08:14'!
foundMatchFor: aParser 
	self subclassResponsibility! !

!PPRule methodsFor: 'initialization' stamp: 'lr 4/29/2010 08:51'!
initialize! !

!PPRule methodsFor: 'matching' stamp: 'lr 4/29/2010 08:53'!
performOn: aParser
	(search match: aParser inContext: owner context)
		ifFalse: [ ^ nil ].
	(self canMatch: aParser)
		ifFalse: [ ^ nil ].
	^ self foundMatchFor: aParser! !

!PPRule methodsFor: 'initialization' stamp: 'lr 4/28/2010 20:45'!
setOwner: aGrammarSearcher
	owner := aGrammarSearcher! !

!PPRule methodsFor: 'initialization' stamp: 'lr 4/29/2010 08:23'!
setSearch: aParser
	search := aParser! !

PPRule subclass: #PPSearchRule
	instanceVariableNames: 'answerBlock'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'PetitBeta-Processor'!

!PPSearchRule commentStamp: '<historical>' prior: 0!
PPSearchRule is a rule that simply searches for matches to the rule. Every time a match is found, answerBlock is evaluated with the parser that matches and the current answer. This two-argument approach allows a collection to be formed from all of the matches, like with #inject:into:.!

!PPSearchRule class methodsFor: 'instance creation' stamp: 'lr 4/29/2010 08:21'!
searchFor: aParser thenDo: aBlock
	^ (self searchFor: aParser) setAnswerBlock: aBlock! !

!PPSearchRule methodsFor: 'matching' stamp: 'lr 4/29/2010 08:22'!
canMatch: aParser
	owner setAnswer: (answerBlock value: aParser value: owner answer).
	^ super canMatch: aParser! !

!PPSearchRule methodsFor: 'matching' stamp: 'lr 4/29/2010 08:15'!
foundMatchFor: aParser 
	^ aParser! !

!PPSearchRule methodsFor: 'initialization' stamp: 'lr 4/29/2010 09:51'!
setAnswerBlock: aBlock
	answerBlock := aBlock! !

!PPPredicateParser methodsFor: '*petitbeta-matching' stamp: 'lr 5/1/2010 17:07'!
match: aParser inContext: aDictionary seen: aSet
	^ (super match: aParser inContext: aDictionary seen: aSet) and: [ self selector = aParser selector and: [ self arguments = aParser arguments ] ]! !

!PPFailingParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 12:01'!
match: aParser inContext: aDictionary seen: anIdentitySet
	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self message = aParser message ]! !

!PPRepeatingParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 11:01'!
match: aParser inContext: aDictionary seen: aSet
	^ (super match: aParser inContext: aDictionary seen: aSet) and: [ self min = aParser min and: [ self max = aParser max ] ]! !

!PPDelegateParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 08:13'!
copyInContext: aDictionary seen: aSeenDictionary
	aSeenDictionary 
		at: self 
		ifPresent: [ :value | ^ value ].
	^ (aSeenDictionary at: self put: self copy)
		setParser: (parser copyInContext: aDictionary seen: aSeenDictionary);
		yourself! !

!PPActionParser methodsFor: '*petitbeta-matching' stamp: 'lr 4/30/2010 11:00'!
match: aParser inContext: aDictionary seen: aSet
	^ (super match: aParser inContext: aDictionary seen: aSet) and: [ self block = aParser block ]! !