--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/parsers/smalltalk/tests/PPSmalltalkClassesTests.st	Tue Oct 07 09:42:03 2014 +0100
@@ -0,0 +1,203 @@
+"{ Package: 'stx:goodies/petitparser/parsers/smalltalk/tests' }"
+
+PPCompositeParserTest subclass:#PPSmalltalkClassesTests
+	instanceVariableNames:''
+	classVariableNames:''
+	poolDictionaries:''
+	category:'PetitSmalltalk-Tests'
+!
+
+PPSmalltalkClassesTests comment:'Evalaute the following code to verify the complete image.'
+!
+
+!PPSmalltalkClassesTests class methodsFor:'accessing'!
+
+packageNamesUnderTest
+	^ #('PetitSmalltalk')
+! !
+
+!PPSmalltalkClassesTests class methodsFor:'utilities'!
+
+benchmark: aParser
+	"self benchmark: PPSmalltalkGrammar new"
+	"self benchmark: PPSmalltalkParser new"
+	"self benchmark: RBParser"
+	
+	| sources |
+	sources := OrderedCollection new.
+	SequenceableCollection withAllSubclassesDo: [ :class |
+		class selectorsDo: [ :selector |
+			sources add: (class sourceCodeAt: selector) ] ].
+	^ self benchmark: aParser sources: sources asArray
+!
+
+benchmark: aParser sources: aCollection
+	| count start |
+	count := 0.
+	start := Time millisecondClockValue.
+	[  aCollection do: [ :each | aParser parseMethod: each ].
+		count := count + 1.
+		(Time millisecondsSince: start) < 10000 ] whileTrue.
+	^ (1000 * count * (aCollection detectSum: [ :each | each size ]) 
+		/ (Time millisecondsSince: start)) asInteger asString , ' characters/sec'
+!
+
+verifySystem
+	Smalltalk globals allClasses
+		inject: self new
+		into: [ :test :class | test verifyClass: class ]
+! !
+
+!PPSmalltalkClassesTests methodsFor:'accessing'!
+
+parserClass
+	^ PPSmalltalkParser
+! !
+
+!PPSmalltalkClassesTests methodsFor:'private'!
+
+assert: aBoolean description: aString 
+	self 
+		assert: aBoolean
+		description: aString
+		resumable: true
+!
+
+verifyClass: aClass 
+	aClass selectors 
+		do: [ :selector | self verifyClass: aClass selector: selector ].
+	aClass isMeta
+		ifFalse: [ self verifyClass: aClass class ]
+!
+
+verifyClass: aClass selector: aSelector 
+	"Verifies that the method aSelector in aClass parses the same using the standard refactoring parser and the petit smalltalk parser. Also make sure that the position information of all tokens and comments is equal."
+
+	| signature source original other checker |
+	signature := aClass name , '>>#' , aSelector.
+	source := aClass sourceCodeAt: aSelector.
+	source isNil ifTrue: [ ^ self ].
+	original := aClass parseTreeFor: aSelector.
+	original isNil ifTrue: [ ^ self ].
+	other := self parserInstance
+		parseMethod: source
+		onError: [ :err | self assert: false description: signature ].
+	self 
+		assert: original = other
+		description: 'Code in ' , signature.
+	checker := [ :node1 :node2 |
+		self 
+			assert: node1 sourceInterval = node2 sourceInterval 
+			description: 'Source intervals in ' , signature.
+		(node1 isArray or: [ node1 isBlock or: [ node1 isPragma ] ]) ifTrue: [
+			self
+				assert: node1 left = node2 left
+				description: 'Source position left in ' , signature.
+			self
+				assert: node1 right = node2 right
+				description: 'Source position right in ' , signature ].
+		(node1 isSequence) ifTrue: [
+			self
+				assert: node1 leftBar = node2 leftBar
+				description: 'Source position leftBar in ' , signature.
+			self
+				assert: node1 rightBar = node2 rightBar
+				description: 'Source position rightBar in ' , signature ].
+		(node1 isBlock) ifTrue: [
+			self
+				assert: node1 bar = node2 bar
+				description: 'Source position bar in ' , signature ].
+		(node1 isReturn) ifTrue: [
+			self
+				assert: node1 return = node2 return
+				description: 'Source position return in ' , signature ].
+		(node1 isAssignment) ifTrue: [
+			self
+				assert: node1 assignment = node2 assignment
+				description: 'Source position return in ' , signature ].
+		(node1 isCascade) ifTrue: [
+			self
+				assert: node1 semicolons asArray = node2 semicolons asArray
+				description: 'Source position semicolons in ' , signature ].
+		(node1 isArray or: [ node1 isSequence ]) ifTrue: [
+			self
+				assert: node1 periods asArray = node2 periods asArray
+				description: 'Source position periods in ' , signature ].
+		(node1 isMethod or: [ node1 isMessage or: [ node1 isPragma ] ]) ifTrue: [
+			node1 selectorParts with: node2 selectorParts do: [ :a :b |
+				self
+					assert: a start = b start
+					description: 'Source position selector parts in ' , signature ] ].
+		node1 children with: node2 children do: checker ].
+	checker value: original value: other
+! !
+
+!PPSmalltalkClassesTests methodsFor:'testing'!
+
+testCollection
+	self verifyClass: Collection.
+	self verifyClass: Array.
+	self verifyClass: Set.
+	self verifyClass: Dictionary.
+	self verifyClass: Bag.
+	self verifyClass: OrderedCollection.
+	self verifyClass: SortedCollection
+!
+
+testException
+	self verifyClass: Exception.
+	self verifyClass: Notification.
+	self verifyClass: Warning.
+	self verifyClass: Error
+!
+
+testFundamental
+	self verifyClass: Object.
+	self verifyClass: Boolean.
+	self verifyClass: True.
+	self verifyClass: False.
+	self verifyClass: Character
+
+
+!
+
+testMagnitude
+	self verifyClass: Magnitude.
+	self verifyClass: Number.
+	self verifyClass: Integer.
+	self verifyClass: Float.
+	self verifyClass: Fraction
+!
+
+testStream
+	self verifyClass: Stream.
+	self verifyClass: ReadStream.
+	self verifyClass: WriteStream
+! !
+
+!PPSmalltalkClassesTests methodsFor:'testing-protocol'!
+
+testParseExpression
+	result := self parserClass parseExpression: '1 + 2'.
+	self assert: result isMessage.
+	self assert: result source equals: '1 + 2'.
+	result := self parserClass parseExpression: '| a | 1 + a'.
+	self assert: result isSequence.
+	self assert: result source equals: '| a | 1 + a'.
+	result := self parserClass parseExpression: '1 + 2. ^ 3'.
+	self assert: result isSequence.
+	self assert: result source equals: '1 + 2. ^ 3'.
+	result := self parserClass parseExpression: '1 + ' onError: [ :err | true ].
+	self assert: result.
+	self should: [ self parserClass parseExpression: '1 + ' ] raise: Error
+!
+
+testParseMethod
+	result := self parserClass parseMethod: 'do 1 + 2'.
+	self assert: result isMethod.
+	self assert: result source equals: 'do 1 + 2'.
+	result := self parserClass parseMethod: 'do 1 +' onError: [ :err | true ].
+	self assert: result.
+	self should: [ self parserClass parseMethod: 'do 1 +' ] raise: Error
+! !
+