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

"{ NameSpace: Smalltalk }"

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


!PPCOptimizingTest methodsFor:'test support'!

assert: object type: class
	self assert: (object isKindOf: class)
!

optimize: p
	^ p asCompilerTree optimizeTree 
!

optimize: p parameters: parameters
	^ p asCompilerTree optimizeTree: parameters 
! !

!PPCOptimizingTest methodsFor:'tests'!

testAnyPredicate
	| tree |
	tree := self optimize: #any asParser.
	
	self assert: tree type: PPCAnyNode.
!

testCharSetPredicate
	| tree |
	tree := self optimize: (PPPredicateObjectParser on: [:each | each = $b or: [each = $c] ] message: #foo).

	self assert: tree type: PPCCharSetPredicateNode
!

testChoiceInlining
	| tree |
	tree := self optimize: $a asParser  / $b asParser.

	self assert: tree type: PPCChoiceNode.
	self assert: tree children first  type: PPCCharacterNode.
	self assert: tree children first isMarkedForInline.
	self assert: tree children second type: PPCCharacterNode.
	self assert: tree children first isMarkedForInline.
	
!

testForwarding
	| tree p1 p2 |
	p2 := $a asParser.
	p1 := p2 wrapped.
	p1 name: 'p1'.
	tree := self optimize: p1.

	self assert: tree type: PPCAbstractCharacterNode.
	self assert: tree name = 'p1'.
	
	p2 name: 'p2'.
	tree := self optimize: p1.
	self assert: tree type: PPCForwardNode.
	self assert: tree name = 'p1'.
	self assert: tree child name = 'p2'.
!

testInlineCharacter
	| tree |
	tree := self optimize: $a asParser plus.

	self assert: tree type: PPCPlusNode.
	self assert: tree child type: PPCCharacterNode.
	self assert: tree child isMarkedForInline.
	self assert: tree child character = $a.
!

testInlineCharacter2
	| tree |
	tree := self optimize: $a asParser star.

	self assert: tree type: PPCStarNode.
	self assert: tree child type: PPCCharacterNode.
	self assert: tree child isMarkedForInline.
	self assert: tree child character = $a.
!

testInlineCharacter3
	| tree |
	tree := self optimize: $a asParser, $b asParser.

	self assert: tree type: PPCSequenceNode.
	self assert: tree children first type: PPCCharacterNode.
	self assert: tree children first isMarkedForInline.
	self assert: tree children first character = $a.
	self assert: tree children second type: PPCCharacterNode.
	self assert: tree children second isMarkedForInline.
	self assert: tree children second character = $b.	
!

testInlineNil
	| tree |
	tree := self optimize: nil asParser star.

	self assert: tree type: PPCStarNode.
	self assert: tree child type: PPCNilNode.
	self assert: tree child isMarkedForInline.
!

testInlineNotLiteral
	| tree |
	tree := self optimize: 'foo' asParser not star.

	self assert: tree type: PPCStarNode.
	self assert: tree child type: PPCNotLiteralNode.
	self assert: tree child literal = 'foo'.
	self assert: tree child isMarkedForInline.
!

testInlineNotPredicate
	| tree |
	tree := self optimize: (#letter asParser not, (PPPredicateObjectParser on: [ :e | e = $a or: [  e = $b ]] message: #foo) not).

	self assert: tree type: PPCSequenceNode.
	self assert: tree children first type: PPCNotMessagePredicateNode.
	self assert: tree children first isMarkedForInline.
	self assert: tree children second type: PPCNotCharSetPredicateNode.
	self assert: tree children second isMarkedForInline.
	
!

testInlinePluggable
	| tree |
	tree := self optimize: [:ctx | nil] asParser star.

	((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) 
		ifTrue:[ self skip: 'not supported in St/X' ].

	self assert: tree type: PPCStarNode.
	self assert: tree child type: PPCPluggableNode.
	self assert: tree child isMarkedForInline.

    "Modified: / 23-04-2015 / 12:19:42 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

testInlinePredicate
	| tree |
	tree := self optimize: (#letter asParser, (PPPredicateObjectParser on: [ :e | e = $a or: [  e = $b ]] message: #foo)).

	self assert: tree type: PPCSequenceNode.
	self assert: tree children first type: PPCMessagePredicateNode.
	self assert: tree children first isMarkedForInline.
	self assert: tree children second type: PPCCharSetPredicateNode.
	self assert: tree children second isMarkedForInline.
	
!

testLetterPredicate
	| tree |
	tree := self optimize: #letter asParser.

	self assert: tree type: PPCMessagePredicateNode.
	self assert: tree message = #isLetter.
!

testNotAction
	| tree |
	tree := self optimize: (($f asParser, $o asParser) ==> #second) not.

	self assert: tree type: PPCNotNode.
	self assert: tree child type: PPCTokenSequenceNode.
!

testNotCharSetPredicate
	| tree |
	tree := self optimize: (PPPredicateObjectParser on: [:each | each = $b or: [each = $c] ] message: #foo) asParser not.

	self assert: tree type: PPCNotCharSetPredicateNode.
!

testNotLiteral
	| tree |
	tree := self optimize: 'foo' asParser not.

	self assert: tree type: PPCNotLiteralNode.
	self assert: tree literal = 'foo'.
!

testNotMessagePredicate
	| tree |
	tree := self optimize: #letter asParser not.

	self assert: tree type: PPCNotMessagePredicateNode.
!

testNotSequence
	| tree |
	tree := self optimize: ($f asParser, $o asParser) not.

	self assert: tree type: PPCNotNode.
	self assert: tree child type: PPCTokenSequenceNode.
!

testStarAny
	| tree |
	tree := self optimize: #any asParser star.

	self assert: tree type: PPCStarAnyNode.
!

testStarCharSetPredicate
	| tree |
	tree := self optimize: (PPPredicateObjectParser on: [:each | each = $b or: [each = $c] ] message: #foo) star.

	self assert: tree type: PPCStarCharSetPredicateNode
!

testStarMessagePredicate
	| tree |
	tree := self optimize: #letter asParser star.

	self assert: tree type: PPCStarMessagePredicateNode.
!

testStarSeparator
	| tree |
	tree := self optimize: #space asParser star trimmingToken parameters: { #rewrite . #token }.

	self assert: tree type: PPCTrimmingTokenNode.
	self assert: tree child type: PPCTokenStarSeparatorNode.
!

testStarSeparator2
	| tree |
	tree := self optimize: (#space asParser star, 'whatever' asParser) trimmingToken.

	self assert: tree type: PPCTrimmingTokenNode.
	self assert: tree child type: PPCTokenSequenceNode.
	self assert: tree child children first type: PPCTokenStarSeparatorNode.
	self assert: tree child children first isMarkedForInline.
!

testSymbolAction
	| tree |
	tree := self optimize: (#letter asParser) ==> #second.

	self assert: tree type: PPCSymbolActionNode.

	tree := self optimize: (#letter asParser) ==> [:e | e second ].
	self assert: tree type: PPCActionNode.
!

testToken
	| tree |
	tree := self optimize: ((#letter asParser, #word asParser star) token).

	self assert: tree type: PPCTokenNode.
	self assert: tree child type: PPCTokenSequenceNode.
	self assert: tree child children size = 2.
	self assert: tree child children first type: PPCMessagePredicateNode.
	self assert: tree child children first isMarkedForInline.
	self assert: tree child children second type: PPCTokenStarMessagePredicateNode.	
	self assert: tree child children second isMarkedForInline.
	
!

testTokenSequence2
	| tree |
	tree := self optimize: ($a asParser, $b asParser) token.

	self assert: tree type: PPCTokenNode.
	self assert: tree child type: PPCTokenSequenceNode.
	
	tree := self optimize: ($a asParser, $b asParser) trimmingToken.

	self assert: tree type: PPCTrimmingTokenNode.
	self assert: tree child type: PPCTokenSequenceNode.
!

testTrimmingToken
	| tree |
	tree := self optimize: ((#letter asParser, #word asParser star) trimmingToken).

	self assert: tree type: PPCTrimmingTokenNode.
	self assert: tree whitespace type: PPCTokenStarSeparatorNode.
	self assert: tree whitespace isMarkedForInline.
	
	self assert: tree child type: PPCTokenSequenceNode.
	self assert: tree child children size = 2.
	self assert: tree child children first type: PPCMessagePredicateNode.
	self assert: tree child children first isMarkedForInline.
	self assert: tree child children second type: PPCTokenStarMessagePredicateNode.	
	self assert: tree child children first isMarkedForInline.
!

testTrimmingToken2
	| 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 ]).

	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.
	
	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.
!

testTrimmingToken3
	| parser tree |
	parser := ('foo' asParser trimmingToken name: 'foo'), ('bar' asParser trimmingToken name: 'bar').
	tree := parser asCompilerTree optimizeTree.
	
	self assert: tree type: PPCSequenceNode.
	self assert: tree children first type: PPCTrimmingTokenNode.
	self assert: tree children second type: PPCTrimmingTokenNode.
!

testTrimmingTokenNested
	| parser tree foo|
	foo := 'foo' asParser trimmingToken name: 'foo'.
	parser := (foo not, 'bar' asParser) trimmingToken name: 'token'.
	tree := self optimize: parser.
	
	self assert: tree type: PPCTrimmingTokenNode.
	self assert: tree children second type: PPCTokenSequenceNode.
	self assert: tree children second children first type: PPCNotLiteralNode.
	self assert: tree children second children first isMarkedForInline.
! !

!PPCOptimizingTest class methodsFor:'documentation'!

version_HG

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