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

"{ NameSpace: Smalltalk }"

PPAbstractParserTest subclass:#PPCCodeGeneratorTest

	instanceVariableNames:'visitor node result compiler parser context configuration

		arguments'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Tests-Visitors'

!

!PPCCodeGeneratorTest methodsFor:'as yet unclassified'!

context	

    ^ context := PPCProfilingContext new

!

setUp

    arguments := PPCArguments default

        profile: true;

        codeGenerator: PPCCodeGenerator.

    configuration := PPCPluggableConfiguration on: [ :_self | 

        _self cacheFirstFollow.

        _self generate.

    ].

    configuration arguments: arguments.

    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

    parser := configuration compile: root.

! !

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

!

testActionNode2

    node := PPCPlusNode new

                child:  

                    (PPCActionNode new

                        block: [ :res | res asUppercase ];

                        child: #letter asParser asCompilerTree;

                        yourself);

                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: ''.

    "Created: / 15-06-2015 / 13:57:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testActionNode3

    node := ((#letter asParser , #letter asParser) 

            ==> [:nodes | String with:(nodes first) with:(nodes second) ]) asCompilerTree.

    node child markForInline.

    self compileTree:node.

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

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

    self assert:parser fail:''.

    "Created: / 16-06-2015 / 06:53:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testActionNode4

    node := ((#letter asParser , #letter asParser) 

            ==> [:nodes | String with:(nodes first) with:(nodes second) ]) asCompilerTree.

    node child markForInline.

    self compileTree:node.

    self assert:parser fail:'a'.

    "Created: / 16-06-2015 / 06:53:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

testActionNode5

    node := ((#letter asParser , #letter asParser optional) 

            ==> [:nodes | String with:(nodes first) with:((nodes second) isNil ifTrue:[$?] ifFalse:[nodes second]) ]) asCompilerTree.

    node child markForInline.

    self compileTree:node.

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

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

    "Created: / 16-06-2015 / 06:53:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

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: 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'.

!

testCharacterNode5

    | charNode |

    charNode := PPCCharacterNode new 

        character: $'; 

        markForInline;

        yourself.

    node := PPCForwardNode new

        child: charNode; yourself.

    self compileTree: node.

    self assert: parser class methodDictionary size = 1.

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

    self assert: parser fail: 'a'.

!

testCharacterNode6

    | charNode |

    charNode := PPCCharacterNode new 

        character: $"; 

        markForInline;

        yourself.

    node := PPCForwardNode new

        child: charNode; yourself.

    self compileTree: node.

    self assert: parser class methodDictionary size = 1.

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

    self assert: parser fail: 'a'.

!

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: '_'.

!

testEndOfInputNode

    | letterNode  |

    letterNode := PPCMessagePredicateNode new

        message: #isLetter;

        yourself.

    node := PPCEndOfInputNode new

        child: letterNode;

        yourself.

    self compileTree: node.

    self assert: parser class methodDictionary size = 2.

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

    self assert: parser fail: 'bc' end: 1.

    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: parser class methodDictionary size = 1.

    self assert: (parser class methodDictionary includesKey: #lit_0).

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

!

testMappedActionNode1