# HG changeset patch
# User Claus Gittinger <cg@exept.de>
# Date 1393964741 -3600
# Node ID 185ab6ab79b3826e7e0804d3908b02799d64442e
# Parent  bb28e80dbcc8e05b159f09db1737507048c41b3e
moved

diff -r bb28e80dbcc8 -r 185ab6ab79b3 analyzer/extensions.st
--- a/analyzer/extensions.st	Tue Mar 04 21:25:40 2014 +0100
+++ b/analyzer/extensions.st	Tue Mar 04 21:25:41 2014 +0100
@@ -0,0 +1,525 @@
+"{ Package: 'stx:goodies/petitparser/analyzer' }"!
+
+!PPActionParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self block = aParser block ]
+! !
+
+!PPDelegateParser methodsFor:'*petitanalyzer-transforming'!
+
+replace: aParser with: anotherParser
+	super replace: aParser with: anotherParser.
+	parser == aParser ifTrue: [ parser := anotherParser ]
+! !
+
+!PPEpsilonParser methodsFor:'*petitanalyzer-testing'!
+
+isNullable
+	^ true
+! !
+
+!PPFailingParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self message = aParser message ]
+! !
+
+!PPLimitedRepeatingParser methodsFor:'*petitanalyzer-transforming'!
+
+replace:aParser with:anotherParser
+    super replace:aParser with:anotherParser.
+    limit == aParser ifTrue:[limit := anotherParser].
+! !
+
+!PPListParser methodsFor:'*petitanalyzer-matching'!
+
+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:'*petitanalyzer-transforming'!
+
+replace: aParser with: anotherParser
+	super replace: aParser with: anotherParser.
+	parsers keysAndValuesDo: [ :index :parser |
+		parser == aParser
+			ifTrue: [ parsers at: index put: anotherParser ] ]
+! !
+
+!PPLiteralParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self literal = aParser literal and: [ self message = aParser message ] ]
+! !
+
+!PPOptionalParser methodsFor:'*petitanalyzer-testing'!
+
+isNullable
+	^ true
+! !
+
+!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
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+allNamedParsersDo: aBlock
+	"Iterate over all the named parse nodes of the receiver."
+
+	self allParsersDo: [ :each | 
+		each name notNil
+			ifTrue: [ aBlock value: each ] ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-enumerating'!
+
+allParsers
+	"Answer all the parse nodes of the receiver."
+
+	| result |
+	result := OrderedCollection new.
+	self allParsersDo: [ :parser | result addLast: parser ].
+	^ result
+! !
+
+!PPParser methodsFor:'*petitanalyzer-enumerating'!
+
+allParsersDo: aBlock
+	"Iterate over all the parse nodes of the receiver."
+
+	self allParsersDo: aBlock seen: IdentitySet new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-enumerating'!
+
+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
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+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
+! !
+
+!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
+! !
+
+!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
+! !
+
+!PPParser methodsFor:'*petitanalyzer-private'!
+
+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
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+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
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+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
+! !
+
+!PPParser methodsFor:'*petitanalyzer-private'!
+
+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) ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+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
+! !
+
+!PPParser methodsFor:'*petitanalyzer-querying'!
+
+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-private'!
+
+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-named'!
+
+innerChildren
+	"Answer the inner children of the receiver."
+
+	| result |
+	result := OrderedCollection new.
+	self innerChildrenDo: [ :parser | result addLast: parser ].
+	^ result
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+innerChildrenDo: aBlock
+	"Iterate over the inner children of the receiver."
+
+	self innerChildrenDo: aBlock seen: IdentitySet new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+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 ] ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-testing'!
+
+isNullable
+	"Answer true if the receiver is a nullable parser, e.g. it can successfully parse nothing."
+	
+	^ false
+! !
+
+!PPParser methodsFor:'*petitanalyzer-testing'!
+
+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-matching'!
+
+match: aParser inContext: aDictionary
+	^ self match: aParser inContext: aDictionary seen: IdentitySet new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+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 ]
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+matchList: matchList against: parserList inContext: aDictionary seen: aSet
+	^ self matchList: matchList index: 1 against: parserList index: 1 inContext: aDictionary seen: aSet
+! !
+
+!PPParser methodsFor:'*petitanalyzer-matching'!
+
+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'!
+
+namedChildren
+	"Answer the named children of the receiver."
+
+	| result |
+	result := OrderedCollection new.
+	self namedChildrenDo: [ :parser | result addLast: parser ].
+	^ result
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+namedChildrenDo: aBlock
+	"Iterate over the named children of the receiver."
+
+	self namedChildrenDo: aBlock seen: IdentitySet new
+! !
+
+!PPParser methodsFor:'*petitanalyzer-named'!
+
+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-transforming'!
+
+replace: aParser with: anotherParser
+	"Replace the references of the receiver pointing to aParser with anotherParser."
+! !
+
+!PPParser methodsFor:'*petitanalyzer-transforming'!
+
+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
+! !
+
+!PPPluggableParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self block = aParser block ]
+! !
+
+!PPPredicateParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self block = aParser block and: [ self message = aParser message ] ]
+! !
+
+!PPPredicateSequenceParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self size = aParser size ]
+! !
+
+!PPRepeatingParser methodsFor:'*petitanalyzer-testing'!
+
+isNullable
+	^ min = 0
+! !
+
+!PPRepeatingParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self min = aParser min and: [ self max = aParser max ] ]
+! !
+
+!PPSequenceParser methodsFor:'*petitanalyzer-private'!
+
+cycleSet: aDictionary
+	| firstSet |
+	1 to: parsers size do: [ :index |
+		firstSet := aDictionary at: (parsers at: index).
+		(firstSet anySatisfy: [ :each | each isNullable ])
+			ifFalse: [ ^ parsers copyFrom: 1 to: index ] ].
+	^ parsers
+! !
+
+!PPSequenceParser methodsFor:'*petitanalyzer-private'!
+
+firstSets: aFirstDictionary into: aSet
+	| nullable |
+	parsers do: [ :parser |
+		nullable := false.
+		(aFirstDictionary at: parser) do: [ :each |
+			each isNullable
+				ifTrue: [ nullable := true ]
+				ifFalse: [ aSet add: each ] ].
+		nullable
+			ifFalse: [ ^ self ] ].
+	aSet add: PPSentinel instance
+! !
+
+!PPSequenceParser methodsFor:'*petitanalyzer-private'!
+
+followSets: aFollowDictionary firstSets: aFirstDictionary into: aSet
+	parsers keysAndValuesDo: [ :index :parser |
+		| followSet firstSet |
+		followSet := aFollowDictionary at: parser.
+		index = parsers size
+			ifTrue: [ followSet addAll: aSet ]
+			ifFalse: [
+				(self class withAll: (parsers 
+					copyFrom: index + 1 to: parsers size))
+						firstSets: aFirstDictionary
+						into: (firstSet := IdentitySet new).
+				(firstSet anySatisfy: [ :each | each isNullable ])
+					ifTrue: [ followSet addAll: aSet ].
+				followSet addAll: (firstSet 
+					reject: [ :each | each isNullable ]) ] ]
+! !
+
+!PPTokenParser methodsFor:'*petitanalyzer-matching'!
+
+match: aParser inContext: aDictionary seen: anIdentitySet
+	^ (super match: aParser inContext: aDictionary seen: anIdentitySet) and: [ self tokenClass = aParser tokenClass ]
+! !
+
+!stx_goodies_petitparser_analyzer class methodsFor:'documentation'!
+
+extensionsVersion_CVS
+    ^ '$Header: /cvs/stx/stx/goodies/petitparser/analyzer/extensions.st,v 1.2 2014-03-04 20:25:41 cg Exp $'
+! !