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

"{ NameSpace: Smalltalk }"

TestCase subclass:#PPCNodeTest
	instanceVariableNames:'node'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Tests-Nodes'
!


!PPCNodeTest methodsFor:'as yet unclassified'!

testCopy
	| newNode |
	node := PPCDelegateNode new
		child: #foo;
		yourself.
	newNode := node copy.
	self assert: (node = newNode).
	self assert: (node hash = newNode hash).
	
	newNode child: #bar.
	self assert: (node = newNode) not.
!

testCopy2
	|  newNode |
	node := PPCSequenceNode new
		children: { #foo . #bar }
		yourself.
	newNode := node copy.

	self assert: (node = newNode).
	self assert: (node hash = newNode hash).
	
	node children at: 1 put: #zorg.
	self assert: (node = newNode) not.
!

testCopy3
	| newNode |
	node := PPCMessagePredicateNode new
		predicate: #block;
		message: #message;
		yourself.
		
	newNode := node copy.
	
	self assert: (node == newNode) not.
	self assert: (node = newNode).
	self assert: node hash = newNode hash.
!

testCopy4
	| node1 node2 |
	node1 := #letter asParser asCompilerNode.
	node2 := #letter asParser asCompilerNode.
	
	self assert: (node == node2) not.
	self assert: (node1 = node2).
	self assert: node1 hash = node2 hash.
!

testEquals
	self assert: (PPCNode new = PPCNode new).
!

testEquals2
	| n1 n2 n3 |
	n1 := PPCDelegateNode new
		child: #foo;
		yourself.
	n2 := PPCDelegateNode new
		child: #bar;
		yourself.
	n3 := PPCDelegateNode new
		child: #foo;
		yourself.
		
	self assert: (n1 = n3).
	self assert: (n1 = n2) not.
!

testReplaceNode
	| literalNode anotherLiteralNode |
	literalNode := PPCLiteralNode new
		literal: 'foo';
		yourself.
		
	anotherLiteralNode := PPCLiteralNode new
		literal: 'bar';
		yourself.
		
	node := PPCForwardNode new
		child: literalNode;
		yourself.
	
	self assert: node child == literalNode.
	node replace: literalNode with: anotherLiteralNode.
	self assert: node child == anotherLiteralNode.
	self assert: (node child == literalNode) not.
! !

!PPCNodeTest methodsFor:'test support'!

assert: object type: class
	self assert: object class == class
! !

!PPCNodeTest methodsFor:'tests - converting'!

testConvertBlock
	| parser tree |
	parser := [ :ctx | [ctx atEnd] whileFalse ] asParser.
	tree := parser asCompilerTree.
	
	self assert: tree type: PPCPluggableNode.
	self assert: tree block asString = '[ :ctx | [ ctx atEnd ] whileFalse ]'.
!

testConvertChoice
	| parser tree |
	parser := 'foo' asParser / $b asParser.
	tree := parser asCompilerTree.
	
	self assert: tree type: PPCChoiceNode.
	self assert: tree children size = 2.
	self assert: tree children first type: PPCLiteralNode.
	self assert: tree children second type: PPCCharacterNode.
!

testConvertNil
	| parser tree |
	parser := nil asParser.
	tree := parser asCompilerTree.
	
	self assert: tree type: PPCNilNode.
!

testConvertSequence
	| parser tree |
	parser := 'foo' asParser, $b asParser.
	tree := parser asCompilerTree.
	
	self assert: tree type: PPCSequenceNode.
	self assert: tree children size = 2.
	self assert: tree children first type: PPCLiteralNode.
	self assert: tree children second type: PPCCharacterNode.
!

testConvertToken
	| parser tree |
	parser := 'foo' asParser token.
	tree := parser asCompilerTree.
	
	self assert: tree type: PPCTokenNode.
	self assert: tree child type: PPCLiteralNode.

	parser := ('foo' asParser, $b asParser) token.
	tree := parser asCompilerTree.
	
	self assert: tree type: PPCTokenNode.
	self assert: tree child type: PPCSequenceNode.
	
	parser := $d asParser token star.
	tree := parser asCompilerTree.
	
	self assert: tree type: PPCStarNode.
	self assert: tree child type: PPCTokenNode.
	self assert: tree child child type: PPCCharacterNode.
!

testConvertTrimmingToken
	| parser tree |
	parser := 'foo' asParser trimmingToken.
	tree := parser asCompilerTree optimizeTree.
	
	self assert: tree type: PPCTrimmingTokenNode.
	self assert: tree child type: PPCLiteralNode.
	self assert: tree child isMarkedForInline.
	self assert: (tree whitespace allNodes allSatisfy: [ :n | n isKindOf: PPCNode ]).
!

testConvertTrimmingToken2
	| parser tree |
	parser := ('foo' asParser, $b asParser) trimmingToken.
	tree := parser asCompilerTree optimizeTree.
	
	self assert: tree type: PPCTrimmingTokenNode.
	self assert: tree child type: PPCTokenSequenceNode.
	self assert: tree whitespace type: PPCTokenStarSeparatorNode.
	self assert: tree whitespace isMarkedForInline.
!

testConvertTrimmingToken3
	| parser tree |
	
	parser := $d asParser trimmingToken star.
	tree := parser asCompilerTree optimizeTree.
	
	self assert: tree type: PPCStarNode.
	self assert: tree child type: PPCTrimmingTokenNode.
	self assert: tree child child type: PPCCharacterNode.	
	self assert: tree child child isMarkedForInline.
! !

!PPCNodeTest methodsFor:'tests - epsilon'!

testActionAcceptsEpsilon
	| tree |
	tree := ('foo' asParser token optional ==> [ :e | e ]) asCompilerTree.
	self assert: tree acceptsEpsilon.
!

testChoiceAcceptsEpsilon
	| tree |
	tree := ($a asParser / $b asParser star) asCompilerTree.
	self assert: tree acceptsEpsilon.
!

testLiteralAcceptsEpsilon
	| tree |
	tree := 'foo' asParser asCompilerTree.
	self assert: tree acceptsEpsilon not.
	
	tree := '' asParser asCompilerTree.
	self assert: tree acceptsEpsilon.
!

testPlusAcceptsEpsilon
	| tree |
	tree := ($b asParser plus) asCompilerTree.
	self assert: tree acceptsEpsilon not.
	
	tree := #letter asParser plus asCompilerTree.
	self assert: tree acceptsEpsilon not.
!

testSequenceAcceptsEpsilon
	| tree parser |
	parser := 'foo' asParser token optional, 'bar' asParser token star, ($a asParser / $b asParser star).
	tree := parser asCompilerTree.
	self assert: tree acceptsEpsilon.
!

testStarAcceptsEpsilon
	| tree |
	tree := $b asParser star asCompilerTree.
	self assert: tree acceptsEpsilon.
!

testTokenAcceptsEpsilon
	| tree |
	tree := ($a asParser / $b asParser plus) token asCompilerTree.
	self assert: tree acceptsEpsilon not.
	
	tree := ($a asParser / $b asParser star) token asCompilerTree.
	self assert: tree acceptsEpsilon.
! !

!PPCNodeTest class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'
! !