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

PPAbstractParserTest subclass:#PPCNodeCompilingTest

	instanceVariableNames:'parser context tree result'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Tests-Nodes'

!

!PPCNodeCompilingTest methodsFor:'context'!

context	

	^ context := PPCProfilingContext new

! !

!PPCNodeCompilingTest methodsFor:'test support'!

assert: whatever parse: input

	result := super assert: whatever parse: input.

!

compileTree: root 

	^ self compileTree: root params: #()

!

compileTree: root params: params

	| compiler mock |

	compiler := PPCCompiler new.

	compiler profile: true.

	mock := nil asParser.

	^ (compiler compileTree: root as: #PPGeneratedParser parser: mock params: params) new.

! !

!PPCNodeCompilingTest methodsFor:'tests - compiling'!

testCompileAction

	tree := PPCActionNode new

		block: [ :res | res collect: [:each | each asUppercase ]];

		child: #letter asParser plus asCompilerTree;

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'foo' to: { $F . $O . $O}.

	self assert: parser parse: 'bar' to: { $B . $A . $R}.

	self assert: parser fail: ''.

!

testCompileAnd

	tree := PPCAndNode new

		child: #digit asParser asCompilerNode;

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: '1' to: $1 end: 0.

	self assert: parser fail: 'a'.

	self assert: parser fail: ''.

!

testCompileAny

	tree := PPCAnyNode new.

	parser := self compileTree: tree.

	self assert: parser parse: 'a' to: $a.

	self assert: parser parse: '_' to: $_.

	self assert: parser parse: '

' to: Character cr.

!

testCompileCharSetPredicate

	tree := PPCCharSetPredicateNode new 

		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'a'  to: $a.

	self assert: parser fail: 'b'.

!

testCompileCharacter

	tree := PPCCharacterNode new character: $a; yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'a'  to: $a.

	self assert: parser fail: 'b'.

	parser := self compileTree: (PPCCharacterNode new character: $#; yourself).

	self assert: parser parse: '#'.

	parser := self compileTree: (PPCCharacterNode new character: Character lf; yourself).

	self assert: parser parse: String lf.

!

testCompileChoice

	tree := PPCChoiceNode new

		children: { #digit asParser asCompilerNode. #letter asParser asCompilerNode };

		yourself.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 4.

	self assert: parser parse: '1' to: $1.

	self assert: parser parse: 'a' to: $a.

	self assert: parser fail: '_'.

!

testCompileLiteral

	tree := PPCLiteralNode new

		literal: 'foo';

		yourself.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'foo'  to: 'foo'.

	self assert: parser parse: 'foobar'  to: 'foo' end: 3.

	self assert: parser fail: 'boo'.

!

testCompileLiteral2

	|  |

	tree := PPCLiteralNode new

		literal: '''''';

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: ''''''  to: ''''''.

!

testCompileNil

	tree := PPCNilNode new.

	parser := self compileTree: tree.

	self assert: parser parse: 'a' to: nil end: 0.

	self assert: parser parse: '' to: nil end: 0.

!

testCompileNot

	tree := PPCNotNode new

		child: #digit asParser asCompilerNode;

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'a' to: nil end: 0.

	self assert: parser fail: '1'.

	self assert: parser parse: '' to: nil end: 0.

!

testCompileNotCharSetPredicate

	tree := PPCNotCharSetPredicateNode new

		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);

		yourself.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'b' to: nil end: 0.

	self assert: context invocationCount = 2.

	self assert: parser fail: 'a'.

	self assert: parser parse: '' to: nil end: 0.

!

testCompileNotLiteral

	tree := PPCNotLiteralNode new

		literal: 'foo';

		yourself.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'bar' to: nil end: 0.

	self assert: context invocationCount = 2.

	self assert: parser fail: 'foo'.

	self assert: parser parse: '' to: nil end: 0.

!

testCompileNotMessagePredicate

	tree := PPCNotMessagePredicateNode new

		message: #isDigit;

		yourself.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'a' to: nil end: 0.

	self assert: context invocationCount = 2.

	self assert: parser fail: '1'.

	self assert: parser parse: '' to: nil end: 0.

!

testCompileOptional

	tree := PPCOptionalNode new

		child: ($a asParser asCompilerNode);

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'b' to: nil end: 0.

	self assert: parser parse: 'a' to: $a.

	self assert: parser parse: '' to: nil end: 0.

!

testCompilePluggable

	tree := PPCPluggableNode new

		block: [:ctx | ctx next ];

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'foo' to: $f end: 1.

	self assert: parser parse: 'bar' to: $b end: 1.

	self assert: parser parse: '' to: nil.

!

testCompilePlus

	tree := PPCPlusNode new

		child: ($a asParser asCompilerNode);

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'aaa' to: #($a $a $a) end: 3.

	self assert: parser parse: 'ab' to: #( $a ) end: 1.

	self assert: parser fail: 'b'.

!

testCompileSequence

	tree := PPCSequenceNode new

		children: {  $a asParser asCompilerNode . $b asParser asCompilerNode . $c asParser asCompilerNode  }

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'abc' to: #($a $b $c) end: 3.

	self assert: parser parse: 'abcd' to: #( $a $b $c ) end: 3.

	self assert: parser fail: 'ab'.

!

testCompileStar

	tree := PPCStarNode new

		child: ($a asParser asCompilerNode);

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'aaa' to: #($a $a $a) end: 3.

	self assert: parser parse: 'ab' to: #( $a ) end: 1.

	self assert: parser parse: 'b' to: #( ) end: 0.

!

testCompileStarAny

	tree := PPCStarAnyNode new child: PPCNilNode new; yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'abc' to: #($a $b $c).

	self assert: parser parse: 'a' to: #($a).

	self assert: parser parse: '' to: #().

!

testCompileStarCharSetPredicate

	tree := PPCStarCharSetPredicateNode new

		predicate: (PPCharSetPredicate on: [:e | e = $a ]);

		"I have to put something here"

		child: PPCNilNode new;

		yourself.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'aaa1' to: #( $a $a $a) end: 3.

	self assert: context invocationCount = 2.

	self assert: parser parse: 'bba' to: #() end: 0.

	self assert: context invocationCount = 2.

!

testCompileStarMessagePredicate

	tree := PPCStarMessagePredicateNode new

		message: #isLetter;

		"I have to add something here"

		child: PPCNilNode new;

		yourself.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'abc1' to: #( $a $b $c) end: 3.

	self assert: context invocationCount = 2.

	self assert: parser parse: '123a' to: #() end: 0.

	self assert: context invocationCount = 2.

!

testCompileSymbolAction

	tree := PPCSymbolActionNode new

		block: #second;

		child: #letter asParser plus asCompilerTree;

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'foo' to: $o.

	self assert: parser parse: 'bar' to: $a.

	self assert: parser fail: ''.

!

testCompileToken

	tree := PPCTokenNode new

		child: #letter asParser plus asCompilerTree;

		tokenClass: PPToken;

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'abc'.

	self assert: result class = PPToken.

	self assert: result inputValue = 'abc'.

	self assert: parser fail: '1a'.

!

testCompileTokenSequence

	tree := PPCTokenSequenceNode new.

	tree children: { #digit asParser asCompilerNode. #letter asParser asCompilerNode }.

	parser := self compileTree: tree.

	self assert: parser parse: '1a' to: parser.

	self assert: context rememberCount = 0.

	self assert: context lwRememberCount = 1.

	self assert: context restoreCount = 0.

	self assert: context lwRestoreCount = 0.

	self assert: parser parse: '1ab' to: parser end: 2.

	self assert: context lwRememberCount = 1.

	self assert: context lwRestoreCount = 0.

	self assert: parser fail: 'a1'. 	

	self assert: context lwRememberCount = 1.

	self assert: context lwRestoreCount = 0.

	self assert: parser fail: 'aa'. 	

	self assert: context lwRememberCount = 1.

	self assert: context lwRestoreCount = 0.

	self assert: parser fail: '11'. 	

	self assert: context lwRememberCount = 1.

	self assert: context lwRestoreCount = 1.

!

testCompileTokenStarMessagePredicate

	tree := PPCTokenStarMessagePredicateNode new message: #isLetter; child: PPCNilNode new; yourself.

	parser := self compileTree: tree params: {#guards -> false}.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'foo' to: parser.

	self assert: context invocationCount = 2.

	self assert: context lwRememberCount  = 0.

	self assert: context lwRestoreCount  = 0.

	self assert: context rememberCount = 0.

	self assert: parser parse: 'foo123' to: parser end: 3.

! !

!PPCNodeCompilingTest methodsFor:'tests - guard'!

testSequenceTokenGuard

	tree := PPCSequenceNode new

		children: { 

			'foo' asParser trimmingToken asCompilerTree optimizeTree. 

			'bar' asParser trimmingToken asCompilerTree optimizeTree. 

		}

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'foobar'.

	self assert: result first inputValue = 'foo'.

	self assert: result second inputValue = 'bar'.	

	self assert: parser parse: ' foobar'.

	self assert: result first inputValue = 'foo'.

	self assert: result second inputValue = 'bar'.	

	self assert: parser fail: ' foo'.

!

testTrimmingTokenGuard

	tree := PPCChoiceNode new

		children: { 

			'foo' asParser trimmingToken asCompilerTree optimizeTree. 

			'bar' asParser trimmingToken asCompilerTree optimizeTree

		}

		yourself.

	parser := self compileTree: tree.

	self assert: parser parse: 'foo'.

	self assert: result inputValue = 'foo'.	

	self assert: parser parse: 'bar'.

	self assert: result inputValue = 'bar'.	

	self assert: parser parse: ' foo'.

	self assert: result inputValue = 'foo'.	

	self assert: parser parse: ' bar'.	

	self assert: result inputValue = 'bar'.

	self assert: parser fail: 'zorg'.

	self assert: (context invocations noneSatisfy: [ :e | e beginsWith: 'token' ]).

! !

!PPCNodeCompilingTest methodsFor:'tests - inlining'!

testInlineAny

	tree := PPCSequenceNode new

		children: { PPCInlineAnyNode new. $a asParser asCompilerNode }.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 3.

	self assert: parser parse: '.a' to: #($. $a).

!

testInlineCharSetPredicate

	tree := PPCPlusNode new

		child: (PPCInlineCharSetPredicateNode new 

			predicate: (PPCharSetPredicate on: [ :e | e = $a ]);

			yourself);

		yourself.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 2.

	self assert: parser parse: 'a'  to: #($a).

	self assert: parser fail: 'b'.

!

testInlineCharacter

	tree := PPCSequenceNode new

		children: { PPCInlineCharacterNode new character: $b . $a asParser asCompilerNode }.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 3.

	self assert: parser parse: 'ba' to: #($b $a).

!

testInlineLiteral

	tree := PPCSequenceNode new

		children: { PPCInlineLiteralNode new literal: 'foo'. $a asParser asCompilerNode }.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 3.

	self assert: parser parse: 'fooa' to: #('foo' $a).

!

testInlineNil

	tree := PPCSequenceNode new

		children: { PPCInlineNilNode new . $a asParser asCompilerNode }.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 3.

	self assert: parser parse: 'a' to: #(nil $a).

!

testInlineNotLiteral

	tree := PPCSequenceNode new

		children: { PPCInlineNotLiteralNode new literal: 'foo'. $a asParser asCompilerNode }.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 3.

	self assert: parser parse: 'a' to: #(nil $a).

!

testInlinePluggable

   "Sadly, on Smalltalk/X blocks cannot be inlined because

	 the VM does not provide enough information to map

	 it back to source code. Very bad indeed!!"          

	((Smalltalk respondsTo:#isSmalltalkX) and:[ Smalltalk isSmalltalkX ]) ifTrue:[

	    self skipIf: true description: 'Blocks cannot be inlined due to a lack of proper VM support'.

	].

	tree := PPCSequenceNode new

		children: { PPCInlinePluggableNode new block: [ :ctx | ctx next ]. $a asParser asCompilerNode }.

	parser := self compileTree: tree.

	self assert: parser class methodDictionary size = 3.

	self assert: parser parse: 'ba' to: #($b $a).

! !

!PPCNodeCompilingTest class methodsFor:'documentation'!

version_HG

    ^ '$Changeset: <not expanded> $'

! !