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

Object subclass:#PPParser

	instanceVariableNames:'properties'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitParser-Parsers'

!

!PPParser class methodsFor:'instance creation'!

named: aString

	^ self new name: aString

!

new

	^ self basicNew initialize

! !

!PPParser methodsFor:'*petitanalyzer-enumerating'!

allParsers

	"Answer all the parse nodes of the receiver."

	| result |

	result := OrderedCollection new.

	self allParsersDo: [ :parser | result addLast: parser ].

	^ result

!

allParsersDo: aBlock

	"Iterate over all the parse nodes of the receiver."

	self allParsersDo: aBlock seen: IdentitySet new

!

allParsersDo: aBlock seen: aSet

	"Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."

	(aSet includes: self)

		ifTrue: [ ^ self ].

	aSet add: self.

	aBlock value: self.

	self children

		do: [ :each | each allParsersDo: aBlock seen: aSet ]

! !

!PPParser methodsFor:'*petitanalyzer-matching'!

copyInContext: aDictionary

	^ self copyInContext: aDictionary seen: IdentityDictionary new

!

copyInContext: aDictionary seen: aSeenDictionary

	| copy |

	aSeenDictionary 

		at: self 

		ifPresent: [ :value | ^ value ].

	copy := aSeenDictionary

		at: self

		put: self copy.

	copy children do: [ :each |

		copy

			replace: each

			with: (each copyInContext: aDictionary seen: aSeenDictionary) ].

	^ copy

!

match: aParser inContext: aDictionary

	^ self match: aParser inContext: aDictionary seen: IdentitySet new

!

match: aParser inContext: aDictionary seen: anIdentitySet

	"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: [ anIdentitySet includes: self ])

		ifTrue: [ ^ true ].

	anIdentitySet add: self.

	^ self class = aParser class and: [ self matchList: self children against: aParser children inContext: aDictionary seen: anIdentitySet ]

!

matchList: matchList against: parserList inContext: aDictionary seen: aSet

	^ self matchList: matchList index: 1 against: parserList index: 1 inContext: aDictionary seen: aSet

!

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:'*petitanalyzer-named'!

allNamedParsers

	"Answer all the named parse nodes of the receiver."

	| result |

	result := OrderedCollection new.

	self allNamedParsersDo: [ :parser | result addLast: parser ].

	^ result

!

allNamedParsersDo: aBlock

	"Iterate over all the named parse nodes of the receiver."

	self allParsersDo: [ :each | 

		each name notNil

			ifTrue: [ aBlock value: each ] ]

!

innerChildren

	"Answer the inner children of the receiver."

	| result |

	result := OrderedCollection new.

	self innerChildrenDo: [ :parser | result addLast: parser ].

	^ result

!

innerChildrenDo: aBlock

	"Iterate over the inner children of the receiver."

	self innerChildrenDo: aBlock seen: IdentitySet new

!

innerChildrenDo: aBlock seen: aSet

	"Iterate over the inner children of the receiver."

	self children do: [ :each |

		(aSet includes: each)

			ifTrue: [ ^ self ].

		aSet add: each.

		each name isNil ifTrue: [

			aBlock value: each.

			each innerChildrenDo: aBlock seen: aSet ] ]

!

namedChildren

	"Answer the named children of the receiver."

	| result |

	result := OrderedCollection new.

	self namedChildrenDo: [ :parser | result addLast: parser ].

	^ result

!

namedChildrenDo: aBlock

	"Iterate over the named children of the receiver."

	self namedChildrenDo: aBlock seen: IdentitySet new

!

namedChildrenDo: aBlock seen: aSet

	"Iterate over the named children of the receiver."

	self children do: [ :each |

		(aSet includes: each)

			ifTrue: [ ^ self ].

		aSet add: each.

		each name isNil

			ifTrue: [ each namedChildrenDo: aBlock seen: aSet ]

			ifFalse: [ aBlock value: each ] ]

! !

!PPParser methodsFor:'*petitanalyzer-private'!

cycleSet: aDictionary

	"PRIVATE: Answer the children that could be part of a cycle-set with the receiver, subclasses might restrict the number of children returned. aDictionary is pre-calcualted first-sets."

	^ self children

!

cycleSet: aStack firstSets: aDictionary into: aSet

	"PRIVATE: Try to find a cycle, where aStack contains the previously visited parsers. The method returns quickly when the receiver is a terminal, terminals cannot be part of a cycle. If aStack already contains the receiver, then we are in a cycle. In this case we don't process the children further and add the nodes to aSet."

	| index |

	self isTerminal

		ifTrue: [ ^ self ].	

	(index := aStack indexOf: self) > 0

		ifTrue: [ ^ aSet addAll: (aStack copyFrom: index to: aStack size) ].

	aStack addLast: self.

	(self cycleSet: aDictionary)

		do: [ :each | each cycleSet: aStack firstSets: aDictionary into: aSet ].

	aStack removeLast

!

firstSets: aFirstDictionary into: aSet

	"PRIVATE: Try to add additional elements to the first-set aSet of the receiver, use the incomplete aFirstDictionary."

	self children do: [ :parser | aSet addAll: (aFirstDictionary at: parser) ]

!

followSets: aFollowDictionary firstSets: aFirstDictionary into: aSet

	"PRIVATE: Try to add additional elements to the follow-set aSet of the receiver, use the incomplete aFollowDictionary and the complete aFirstDictionary."

	self children do: [ :parser | (aFollowDictionary at: parser) addAll: aSet ]

! !

!PPParser methodsFor:'*petitanalyzer-querying'!

cycleSet

	"Answer a set of all nodes that are within one or more cycles of left-recursion. This is generally not a problem if at least one of the nodes is memoized, but it might make the grammar very inefficient and should be avoided if possible."

	| cycles |

	cycles := IdentitySet new.

	self cycleSet: OrderedCollection new firstSets: self firstSets into: cycles.

	^ cycles

!

firstSet

	"Answer the first-set of the receiver. Note, this implementation is inefficient when called on different receivers of the same grammar, instead use #firstSets to calculate the first-sets at once."

	^ self firstSets at: self

!

firstSets

	"Answer a dictionary with all the parsers reachable from the receiver as key and their first-set as value. The first-set of a parser is the list of terminal parsers that begin the parser derivable from that parser."

	| firstSets |

	firstSets := IdentityDictionary new.

	self allParsersDo: [ :each |

		firstSets at: each put: (each isTerminal

			ifTrue: [ IdentitySet with: each ]

			ifFalse: [ IdentitySet new ]).

		each isNullable

			ifTrue: [ (firstSets at: each) add: PPSentinel instance ] ].

	[	| changed tally |

		changed := false.

		firstSets keysAndValuesDo: [ :parser :first |

			tally := first size.

			parser firstSets: firstSets into: first.

			changed := changed or: [ tally ~= first size ] ].

		changed ] whileTrue.

	^ firstSets

!

followSet

	"Answer the follow-set of the receiver starting at the receiver. Note, this implementation is inefficient when called on different receivers of the same grammar, instead use #followSets to calculate the follow-sets at once."

	^ self followSets at: self

!

followSets

	"Answer a dictionary with all the parsers reachable from the receiver as key and their follow-set as value. The follow-set of a parser is the list of terminal parsers that can appear immediately to the right of that parser."

	| current previous continue firstSets followSets |

	current := previous := 0.

	firstSets := self firstSets.

	followSets := IdentityDictionary new.

	self allParsersDo: [ :each | followSets at: each put: IdentitySet new ].

	(followSets at: self) add: PPSentinel instance.

	[	followSets keysAndValuesDo: [ :parser :follow |

			parser 

				followSets: followSets

				firstSets: firstSets

				into: follow ].

		current := followSets

			inject: 0

			into: [ :result :each | result + each size ].

		continue := previous < current.

		previous := current.

		continue ] whileTrue.

	^ followSets

! !

!PPParser methodsFor:'*petitanalyzer-testing'!

isNullable

	"Answer true if the receiver is a nullable parser, e.g. it can successfully parse nothing."

	^ false

!

isTerminal

	"Answer true if the receiver is a terminal or leaf parser, that means it does not delegate to any other parser."

	^ self children isEmpty

! !

!PPParser methodsFor:'*petitanalyzer-transforming'!

replace: aParser with: anotherParser

	"Replace the references of the receiver pointing to aParser with anotherParser."

!

transform: aBlock

	"Answer a copy of all parsers reachable from the receiver transformed using aBlock."

	| mapping root |

	mapping := IdentityDictionary new.

	self allParsersDo: [ :each |

		mapping

			at: each

			put: (aBlock value: each copy) ].

	root := mapping at: self.

	[	| changed |

		changed := false.

		root allParsersDo: [ :each |

			each children do: [ :old |

				mapping at: old ifPresent: [ :new |

					each replace: old with: new.

					changed := true ] ] ].

		changed ] whileTrue.

	^ root

! !

!PPParser methodsFor:'accessing'!

children

	"Answer a set of child parsers that could follow the receiver."

	^ #()

!

name

	"Answer the production name of the receiver."

	^ self propertyAt: #name ifAbsent: [ nil ]

!

name: aString

	self propertyAt: #name put: aString

! !

!PPParser methodsFor:'accessing-properties'!

hasProperty: aKey

	"Test if the property aKey is present."

	^ properties notNil and: [ properties includesKey: aKey ]

!

propertyAt: aKey

	"Answer the property value associated with aKey."

	^ self propertyAt: aKey ifAbsent: [ self error: 'Property not found' ]

!

propertyAt: aKey ifAbsent: aBlock

	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."

	^ properties isNil

		ifTrue: [ aBlock value ]

		ifFalse: [ properties at: aKey ifAbsent: aBlock ]

!

propertyAt: aKey ifAbsentPut: aBlock

	"Answer the property associated with aKey or, if aKey isn't found store the result of evaluating aBlock as new value."

	^ self propertyAt: aKey ifAbsent: [ self propertyAt: aKey put: aBlock value ]

!

propertyAt: aKey put: anObject

	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."

	^ (properties ifNil: [ properties := Dictionary new: 1 ])

		at: aKey put: anObject

!

removeProperty: aKey

	"Remove the property with aKey. Answer the property or raise an error if aKey isn't found."

	^ self removeProperty: aKey ifAbsent: [ self error: 'Property not found' ]

!

removeProperty: aKey ifAbsent: aBlock

	"Remove the property with aKey. Answer the value or, if aKey isn't found, answer the result of evaluating aBlock."

	| answer |

	properties isNil ifTrue: [ ^ aBlock value ].

	answer := properties removeKey: aKey ifAbsent: aBlock.

	properties isEmpty ifTrue: [ properties := nil ].

	^ answer

! !

!PPParser methodsFor:'converting'!

asParser

	"Answer the receiving parser."

	^ self

! !

!PPParser methodsFor:'copying'!

postCopy

	super postCopy.

	properties := properties copy

! !

!PPParser methodsFor:'initialization'!

initialize

! !

!PPParser methodsFor:'operations'!

, aParser 

	"Answer a new parser that parses the receiver followed by aParser."

	^ PPSequenceParser with: self with: aParser

!

/ aParser 

	"Answer a new parser that parses the receiver, if the receiver fails try with aParser (ordered-choice)."

	^ PPChoiceParser with: self with: aParser

!

and

	"Answer a new parser (logical and-predicate) that succeeds whenever the receiver does, but never consumes input."

	^ PPAndParser on: self

!

def: aParser

	"Redefine the receiver as the argument aParser. This method is useful when defining recursive parsers: instantiate a PPUnresolvedParser and later redefine it with another one."

	^ self becomeForward: (aParser name: self name)

!

end

	"Answer a new parser that succeeds at the end of the input and return the result of the receiver."

	^ PPEndOfInputParser on: self

!

memoized

	"Answer a new memoized parser, for refraining redundant computations. This ensures polynomial time O(n^4) for left-recursive grammars and O(n^3) for non left-recursive grammars in the worst case. Not necessary for most grammars that are carefully written and in O(n) anyway."

	^ PPMemoizedParser on: self

!

negate

        "Answer a new parser consumes any input token but the receiver."

        ^ self not , #any asParser ==> #second

!

not

	"Answer a new parser (logical not-predicate) that succeeds whenever the receiver fails, but never consumes input."

	^ PPNotParser on: self

!

optional

	"Answer a new parser that parses the receiver, if possible."

	^ PPOptionalParser on: self

!

times: anInteger

	"Answer a new parser that parses the receiver exactly anInteger times."

	^ self min: anInteger max: anInteger

!

wrapped

	"Answer a new parser that is simply wrapped."

	^ PPDelegateParser on: self

!

| aParser

	"Answer a new parser that either parses the receiver or aParser. Fail if both pass or fail (exclusive choice, unordered choice)."

	^ (self not , aParser) / (aParser not , self) ==> #second

! !

!PPParser methodsFor:'operations-convenience'!

delimitedBy: aParser