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

"{ NameSpace: Smalltalk }"

PPAbstractParserTest subclass:#PPCCodeGeneratorTest
	instanceVariableNames:'visitor node result compiler parser context arguments'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Tests-Visitors'
!

!PPCCodeGeneratorTest methodsFor:'as yet unclassified'!

context	
	^ context := PPCProfilingContext new
!

setUp
	arguments := PPCArguments default
		profile: true;
		yourself.	
			
	compiler := PPCCompiler new.
	compiler arguments: arguments.

	visitor := PPCCodeGenerator new.
	visitor compiler: compiler.
	visitor arguments: arguments.
!

tearDown
	| class |

	class := (Smalltalk at: #PPGeneratedParser ifAbsent: [nil]).
	class notNil ifTrue:[ 
		class removeFromSystem
	].
! !

!PPCCodeGeneratorTest methodsFor:'generating'!

compileTree: root
		
	| configuration |


	configuration := PPCPluggableConfiguration on: [ :_self | 
		result := (visitor visit: _self ir).

		compiler compileParser.
		compiler compiledParser startSymbol: result methodName.
		parser := compiler compiledParser new.
		_self ir: parser
	].
	parser := configuration compile: root arguments: arguments.
	
! !

!PPCCodeGeneratorTest methodsFor:'testing'!

assert: whatever parse: input
	result := super assert: whatever parse: input.
!

testActionNode
	node := PPCActionNode new
		block: [ :res | res collect: [:each | each asUppercase ]];
		child: #letter asParser plus asCompilerTree;
		yourself.
	
	self compileTree: node.
					
	self assert: parser parse: 'foo' to: { $F . $O . $O}.
	self assert: parser parse: 'bar' to: { $B . $A . $R}.
	self assert: parser fail: ''.
!

testAnyNode
	node := PPCForwardNode new
		child: PPCAnyNode new;
		yourself.
	self compileTree: node.
        
	self assert: parser class methodDictionary size = 2.
        
	self assert: parser parse: 'a' to: $a.
	self assert: parser parse: '_' to: $_.
	self assert: parser parse: Character cr asString to: Character cr.

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

testAnyNode2
	node := PPCForwardNode new
		child: (PPCAnyNode new markForInline; yourself);
		yourself.

	self compileTree: node.
        
	self assert: parser class methodDictionary size = 1.
        
	self assert: parser parse: 'a' to: $a.
	self assert: parser parse: '_' to: $_.
	self assert: parser parse: Character cr asString to: Character cr.

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

testCharSetPredicateNode
	| charNode |
	charNode := PPCCharSetPredicateNode new 
		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);
		yourself.
	node := PPCForwardNode new
		child: charNode;
		yourself.
	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 2.
	
	self assert: parser parse: 'a'  to: $a.
	self assert: parser fail: 'b'.
!

testCharSetPredicateNode2
	| charNode |
	charNode := PPCCharSetPredicateNode new 
		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: charNode;
		yourself.
		
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.

	self assert: parser parse: 'a'  to: $a.
	self assert: context invocationCount = 1.

	self assert: parser fail: 'b'.
!

testCharacterNode
	| charNode |
	charNode := PPCCharacterNode new 
		character: $a; yourself.
	node := PPCForwardNode new
		child: charNode; yourself.
	self compileTree: node.
	
	self assert: result class == PPCMethod.
	
	self assert: parser class methodDictionary size = 2.
	self assert: parser parse: 'a'  to: $a.
	self assert: parser fail: 'b'.
!

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

	self assert: parser parse: '#'
!

testCharacterNode3
	node := PPCCharacterNode new character: Character lf; yourself.
	self compileTree: node.

	self assert: parser parse: String lf.
!

testCharacterNode4
	| charNode |
	charNode := PPCCharacterNode new 
		character: $a; 
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: charNode; yourself.
	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'a'  to: $a.
	self assert: parser fail: 'b'.
!

testChoiceNode
	node := PPCChoiceNode new
		children: { #digit asParser asCompilerNode. #letter asParser asCompilerNode };
		yourself.
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 3.
	
	self assert: parser parse: '1' to: $1.
	self assert: parser parse: 'a' to: $a.
	self assert: parser fail: '_'.
!

testChoiceNode2
	| digitNode letterNode |
	digitNode := PPCMessagePredicateNode new
		message: #isDigit;
		markForInline;
		yourself.

	letterNode := PPCMessagePredicateNode new
		message: #isLetter;
		markForInline;
		yourself.


	node := PPCChoiceNode new
		children: { digitNode . letterNode };
		yourself.
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	
	self assert: parser parse: '1' to: $1.
	self assert: parser parse: 'a' to: $a.
	self assert: parser fail: '_'.
!

testForwardNode
	| letterNode forwardNode |
	letterNode := PPCMessagePredicateNode new
		message: #isLetter;
		yourself.
	forwardNode := PPCForwardNode new
		child: letterNode;
		yourself.
	node := PPCForwardNode new
		child: forwardNode;
		yourself.
	
	self compileTree: node.

	self assert: parser class methodDictionary size = 3.
		
	self assert: parser parse: 'a' to: $a.
	self assert: parser parse: 'bc' to: $b end: 1.
	self assert: parser fail: ''.
!

testForwardNode2
	| letterNode forwardNode |
	letterNode := PPCMessagePredicateNode new
		message: #isLetter;
		markForInline;
		yourself.

	forwardNode := PPCForwardNode new
		child: letterNode;
		yourself.
	node := PPCForwardNode new
		child: forwardNode;
		yourself.

	
	self compileTree: node.

	self assert: parser class methodDictionary size = 2.
		
	self assert: parser parse: 'a' to: $a.
	self assert: parser parse: 'bc' to: $b end: 1.
	self assert: parser fail: ''.
!

testForwardNode3
	| letterNode forwardNode |
	letterNode := PPCMessagePredicateNode new
		message: #isLetter;
		yourself.
	forwardNode := PPCForwardNode new
		child: letterNode;
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: forwardNode;
		yourself.

	
	self compileTree: node.

	self assert: parser class methodDictionary size = 2.
		
	self assert: parser parse: 'a' to: $a.
	self assert: parser parse: 'bc' to: $b end: 1.
	self assert: parser fail: ''.
!

testForwardNode4
	| letterNode forwardNode |
	letterNode := PPCMessagePredicateNode new
		message: #isLetter;
		markForInline;
		yourself.

	forwardNode := PPCForwardNode new
		child: letterNode;
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: forwardNode;
		yourself.

	
	self compileTree: node.
		
	self assert: parser class methodDictionary size = 1.
	
	self assert: parser parse: 'a' to: $a.
	self assert: parser parse: 'bc' to: $b end: 1.
	self assert: parser fail: ''.
!

testInlinePluggableNode
   "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'.
	].

	node := PPCSequenceNode new
		children: { 
			PPCPluggableNode new block: [ :ctx | ctx next ]; markForInline; yourself. 
			$a asParser asCompilerNode }.
	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 2.
	self assert: parser parse: 'ba' to: #($b $a).
!

testLiteralNode
	node := PPCLiteralNode new
		literal: 'foo';
		yourself.
	self compileTree: node.
	
	self assert: result class == PPCMethod.
	self assert: result methodName = 'lit_0'.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'foo'  to: 'foo'.
	self assert: parser parse: 'foobar'  to: 'foo' end: 3.
	self assert: parser fail: 'boo'.
!

testLiteralNode2
	node := PPCLiteralNode new
		literal: '''''';
		yourself.
	self compileTree: node.
	
	self assert: parser parse: ''''''  to: ''''''.
!

testLiteralNode3
	| literalNode |
	literalNode := PPCLiteralNode new
		literal: 'foo';
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: literalNode;
		yourself.
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'foo'  to: 'foo'.
	self assert: parser parse: 'foobar'  to: 'foo' end: 3.
	self assert: parser fail: 'boo'.
!

testMessagePredicate
	| messageNode |
	messageNode := PPCMessagePredicateNode new
		message: #isDigit;
		yourself.
	node := PPCForwardNode new
		child: messageNode;
		yourself.
	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 2.
	self assert: parser parse: '1' to: $1 end: 1.
	self assert: context invocationCount = 2.
		
	self assert: parser fail: 'a'.
	self assert: parser fail: ''.
!

testMessagePredicate2
	| messageNode |
	messageNode := PPCMessagePredicateNode new
		message: #isDigit;
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: messageNode;
		yourself.
		
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: '1' to: $1 end: 1.
	self assert: context invocationCount = 1.
		
	self assert: parser fail: 'a'.
	self assert: parser fail: ''.
!

testNilNode
	| nilNode |
	nilNode := PPCNilNode new.
	node := PPCForwardNode new child: nilNode; yourself.
	self compileTree: node.
	
	self assert: result class = PPCMethod.
	
	self assert: parser class methodDictionary size = 2.
	self assert: parser parse: 'a' to: nil end: 0.
	self assert: parser parse: '' to: nil end: 0.
!

testNilNode2
	| nilNode |
	nilNode := PPCNilNode new markForInline; yourself.
	node := PPCForwardNode new child: nilNode; yourself.
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'a' to: nil end: 0.
	self assert: parser parse: '' to: nil end: 0.
!

testNotCharSetPredicateNode
	| charNode |
	charNode := PPCNotCharSetPredicateNode new
		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);
		yourself.
	node := PPCForwardNode new
		child: charNode; yourself.
		
	self compileTree: node.
	
	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.
!

testNotCharSetPredicateNode2
	| charNode |
	charNode := PPCNotCharSetPredicateNode new
		predicate: (PPCharSetPredicate on: [ :e | e = $a ]);
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: charNode; yourself.

	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'b' to: nil end: 0.
	self assert: context invocationCount = 1.
		
	self assert: parser fail: 'a'.
	self assert: parser parse: '' to: nil end: 0.
!

testNotLiteralNode
	| literalNode |
	literalNode := PPCNotLiteralNode new
		literal: 'foo';
		yourself.
	node := PPCForwardNode new
		child: literalNode; yourself.

	self compileTree: node.
	
	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.
!

testNotLiteralNode2
	| literalNode |
	literalNode := PPCNotLiteralNode new
		literal: 'foo';
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: literalNode; yourself.

	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'bar' to: nil end: 0.
	self assert: context invocationCount = 1.
		
	self assert: parser fail: 'foo'.
	self assert: parser parse: '' to: nil end: 0.
!

testNotMessagePredicateNode
	| messageNode |
	messageNode := PPCNotMessagePredicateNode new
		message: #isDigit;
		yourself.
	node := PPCForwardNode new
		child: messageNode;
		yourself.
				
		
	self compileTree: node.
	
	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.
!

testNotMessagePredicateNode2
	| messageNode |
	messageNode := PPCNotMessagePredicateNode new
		message: #isDigit;
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: messageNode;
		yourself.		
		
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'a' to: nil end: 0.
	self assert: context invocationCount = 1.
		
	self assert: parser fail: '1'.
	self assert: parser parse: '' to: nil end: 0.
!

testNotNode
	node := PPCNotNode new
		child: #digit asParser asCompilerNode;
		yourself.
	
	self compileTree: node.
	
	self assert: parser parse: 'a' to: nil end: 0.
	self assert: parser fail: '1'.
	self assert: parser parse: '' to: nil end: 0.
!

testOptionalNode
	node := PPCOptionalNode new
		child: ($a asParser asCompilerNode);
		yourself.
	self compileTree: node.
	
	self assert: parser parse: 'b' to: nil end: 0.
	self assert: parser parse: 'a' to: $a.
	self assert: parser parse: '' to: nil end: 0.
!

testPluggableNode
	node := PPCPluggableNode new
		block: [:ctx | ctx next ];
		yourself.
	self compileTree: node.
		
	self assert: parser parse: 'foo' to: $f end: 1.
	self assert: parser parse: 'bar' to: $b end: 1.
	self assert: parser parse: '' to: nil.
!

testPlusNode
	node := PPCPlusNode new
		child: ($a asParser asCompilerNode);
		yourself.
	
	self compileTree: node.
	self assert: result class = PPCMethod.
	
	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'.
!

testPlusNode2
	node := PPCPlusNode new
		child: (#letter asParser asCompilerNode markForInline);
		yourself.
	
	self compileTree: node.
	self assert: result class = PPCMethod.
	
	self assert: parser parse: 'abc' to: #($a $b $c) end: 3.
	self assert: parser parse: 'ab1' to: #( $a $b ) end: 2.
	self assert: parser fail: '1'.
!

testPredicateNode
	| predicateNode |
	predicateNode := PPCPredicateNode new
		predicate: (PPCharSetPredicate on: [ :e | e isDigit ]);
		yourself.
	node := PPCForwardNode new
		child: predicateNode;
		yourself.
	self compileTree: node.	
	
	self assert: parser class methodDictionary size = 2.
	self assert: parser parse: '1' to: $1 end: 1.
	self assert: context invocationCount = 2.
		
	self assert: parser fail: 'a'.
	self assert: parser fail: ''.
!

testPredicateNode2
	|  predicateNode |
	predicateNode := PPCPredicateNode new
		predicate: (PPCharSetPredicate on: [ :e | e isDigit ]);
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: predicateNode;
		yourself.

	self compileTree: node.	
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: '1' to: $1 end: 1.
	self assert: context invocationCount = 1.
		
	self assert: parser fail: 'a'.
	self assert: parser fail: ''.
!

testSequenceNode
	node := PPCSequenceNode new
		children: { $a asParser asCompilerNode . 
						$b asParser asCompilerNode . 
						$c asParser asCompilerNode  };
		yourself.
	self compileTree: node.
	
	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'.
!

testStarAnyNode
	node := PPCStarAnyNode new 
		child: PPCNilNode new; 
		yourself.
	self compileTree: node.
	
	self assert: parser parse: 'abc' to: #($a $b $c).
	self assert: parser parse: 'a' to: #($a).
	self assert: parser parse: '' to: #().
!

testStarCharSetPredicateNode
	node := PPCStarCharSetPredicateNode new
		predicate: (PPCharSetPredicate on: [:e | e = $a ]);
		child: PPCSentinelNode new;
		yourself.
	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'aaa1' to: #( $a $a $a) end: 3.
	self assert: context invocationCount = 1.
	self assert: parser parse: 'bba' to: #() end: 0.
	self assert: context invocationCount = 1.
	
!

testStarMessagePredicateNode
	node := PPCStarMessagePredicateNode new
		message: #isLetter;
		child: PPCSentinelNode new;
		yourself.
	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'abc1' to: #( $a $b $c) end: 3.
	self assert: context invocationCount = 1.
	
	self assert: parser parse: '123a' to: #() end: 0.
	self assert: context invocationCount = 1.
	
!

testStarNode
	node := PPCStarNode new
		child: ($a asParser asCompilerNode);
		yourself.
	
	self compileTree: node.
	
	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.
!

testSymbolActionNode
	node := PPCSymbolActionNode new
		block: #second;
		child: #letter asParser plus asCompilerTree;
		yourself.
	
	self compileTree: node.
		
	self assert: parser parse: 'foo' to: $o.
	self assert: parser parse: 'bar' to: $a.
	self assert: parser fail: ''.
!

testTokenNode
	node := PPCTokenNode new
		child: #letter asParser plus asCompilerTree;
		tokenClass: PPToken;
		yourself.
	
	self compileTree: node.
	
	self assert: parser parse: 'abc'.
	self assert: result class = PPToken.
	self assert: result inputValue = 'abc'.

	self assert: parser fail: '1a'.
!

testTokenSequenceNode
	| letterNode |
	letterNode := PPCMessagePredicateNode new
		message: #isLetter;
		yourself.	
	
	node := PPCTokenSequenceNode new
		children: { letterNode };
		yourself.
	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 2.
	self assert: parser parse: 'a'.
	self assert: parser fail: '1'.
!

testTokenSequenceNode2
	| letterNode |
	letterNode := PPCMessagePredicateNode new
		message: #isLetter;
		markForInline;
		yourself.	
	
	node := PPCTokenSequenceNode new
		children: { letterNode };
		yourself.
	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	self assert: parser parse: 'a'.
	self assert: parser fail: '1'.
!

testTokenStarMessagePredicateNode
	
	node := PPCTokenStarMessagePredicateNode new 
		message: #isLetter; 
		child: PPCSentinelNode new; 
		yourself.

	arguments guards: false.	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	
	self assert: parser parse: 'foo' to: parser.
	self assert: context invocationCount = 1.
	self assert: context lwRememberCount  = 0.
	self assert: context lwRestoreCount  = 0.
	self assert: context rememberCount = 0.
	
	self assert: parser parse: 'foo123' to: parser end: 3.
!

testTokenStarSeparatorNode
	
	| starNode |
	starNode := PPCTokenStarSeparatorNode new 
		message: #isSeparator; 
		child: PPCSentinelNode new; 
		yourself.
	node := PPCForwardNode new
		child: starNode;
		yourself.
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 2.
	
	self assert: parser parse: '   a' to: parser end: 3.
	self assert: context invocationCount = 2.
	
!

testTokenStarSeparatorNode2
	
	| starNode |
	starNode := PPCTokenStarSeparatorNode new 
		message: #isSeparator; 
		child: PPCSentinelNode new; 
		markForInline;
		yourself.
	node := PPCForwardNode new
		child: starNode;
		yourself.	
	self compileTree: node.
	
	self assert: parser class methodDictionary size = 1.
	
	self assert: parser parse: '   a' to: context end: 3.
	self assert: context invocationCount = 1.
	
!

testTrimNode
	node := PPCTrimNode new
		child: #letter asParser asCompilerNode;
		yourself.
	
	self compileTree: node.
	
	self assert: parser parse: ' a '.
	self assert: parser fail: ' 1 '.
!

testTrimmingTokenNode
	node := PPCTrimmingTokenNode new
		child: #letter asParser plus asCompilerTree;
		tokenClass: PPToken;
		whitespace: #space asParser star asCompilerTree;
		yourself.
	
	self compileTree: node.
	
	self assert: parser parse: 'abc'.
	self assert: result class = PPToken.
	self assert: result inputValue = 'abc'.

	self assert: parser parse: ' abc '.
	self assert: result class = PPToken.
	self assert: result inputValue = 'abc'.


	self assert: parser fail: '1a'.
!

testUnknownNode
	node := PPCUnknownNode new
		parser: [:ctx | ctx next ] asParser;
		yourself.
	self compileTree: node.
		
	self assert: parser parse: 'foo' to: $f end: 1.
	self assert: parser parse: 'bar' to: $b end: 1.
	self assert: parser parse: '' to: nil.
! !