"{ 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

! !