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

"{ NameSpace: Smalltalk }"

PPCompositeParser subclass:#PPCLRPParser

	instanceVariableNames:'program variable smalltalkBlock bra ket identifier machine body

		event transition epsilon wildcard state onentry running onexit

		comment lineTerminator statebody spawn integer errorNode success

		failed lastError styler timeoutIdentifier timeoutInteger

		endOfComment'

	classVariableNames:''

	poolDictionaries:''

	category:'PetitCompiler-Extras-Tests-LRP'

!

!PPCLRPParser class methodsFor:'accessing'!

ignoredNames

    ^super ignoredNames , #(styler failed lastError)

! !

!PPCLRPParser methodsFor:'accessing'!

error

    ^super error

    "Modified: / 30-07-2015 / 17:12:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

failed

    ^failed

!

lastError

    ^lastError

!

start

    ^program end

!

styler: aSHStyler

    styler := aSHStyler.

!

success

    ^success

! !

!PPCLRPParser methodsFor:'block creation'!

createSTBlockFrom: aBlockNode withVariables: aDictionary

    |compiled retval keys|

    keys := OrderedCollection new: aDictionary size.

    aDictionary associations do: [:asoc|

        keys add: asoc key.

    ].

    compiled := (self methodizeBlock: aBlockNode withArguments: keys) compiledMethod.

    retval := compiled valueWithReceiver: Object new arguments: {aDictionary}.

    ^retval.

!

methodizeBlock: parsedBlock withArguments: anArray

    |method retval inspoint|

    method := 'captureV: PPCLRPScopeVariables'.

    retval := PPSmalltalkParser new method parse: method , '^[1]'.

    inspoint := retval body statements first.

    parsedBlock scope: inspoint value scope.

    parsedBlock parent: inspoint.

    inspoint value: parsedBlock.

    retval source: retval asString.

    anArray do: [:aVarName|

        retval := retval rewritePPCLRPVarNamedWrite: aVarName.

        retval := retval rewritePPCLRPVarNamedRead: aVarName.

    ].

    ^retval

! !

!PPCLRPParser methodsFor:'error handing'!

failWithValue: anObject

    failed := true.

    lastError := anObject.

! !

!PPCLRPParser methodsFor:'grammar'!

body

    ^(variable / event / state / transition / timeoutIdentifier / timeoutInteger / epsilon / wildcard / comment / errorNode) star

!

errorNode

    ^(bra,  (bra/ket)negate star , ket) 

        ==> [ :tokens |  

                PPCLRPErrorNode new start: tokens first start stop: tokens last stop; yourself.

            ]

!

event

    ^ (bra, 'event' asParser trim, identifier, smalltalkBlock,  ket)  

        ==> [:tokens | | ident |

                ident := (tokens at: 3).

                (PPCLRPEvent named: ident inputValue 

                     trigger: (tokens  at: 4))

                start: tokens first start stop: tokens last stop;

                nameRange: (ident start to: ident stop);

                yourself.

            ]

!

integer 

    ^(#digit asParser) plus  token trim

!

machine

    ^(bra , 'machine' asParser trim , identifier , body , ket) 

        ==> [:tokens | | ident bod stop |

                ident := (tokens at: 3).

                bod := (tokens at: 4).

                bod isEmpty

                    ifTrue: [ stop := tokens last stop - 1 ]

                 		ifFalse: [ stop := (bod at: 1) start - 1 ].

                (PPCLRPMachine name: ident inputValue body: bod)

                    start: (tokens first start) stop: (tokens last stop);

                    nameRange: (ident start to: stop);

                    yourself.

            ]

!

onentry

    ^ (bra, 'onentry' asParser trim, (smalltalkBlock/spawn) ,  ket ) 

        ==> [:tokens | 

                (PPCLRPOnEntry block: (tokens at: 3))

                start: (tokens first start) stop: (tokens last stop);

                keywordEnd: (tokens at: 3) start -1;

                yourself.

            ]

!

onexit

    ^ (bra, 'onexit' asParser trim, (smalltalkBlock/spawn),  ket)  

        ==> [:tokens | 

                (PPCLRPOnExit block: (tokens at: 3))

                start: (tokens first start) stop: (tokens last stop);

                keywordEnd: (tokens at: 3) start -1;

                yourself.

            ]

!

program

    ^ (variable / machine / comment / spawn / errorNode) star

!

running

    ^ (bra, 'running' asParser trim, (smalltalkBlock/spawn),  ket)  

        ==> [:tokens | 

                (PPCLRPRunning block: (tokens at: 3))

                start: (tokens first start) stop: (tokens last stop);

                keywordEnd: (tokens at: 3) start -1;

                yourself.

            ]

!

spawn

    ^(bra , 'spawn' asParser trim , identifier , identifier , ket) 

        ==> [ :tokens |  

                (PPCLRPSpawn

                    machine: (tokens at: 3) inputValue

                    state: (tokens at: 4) inputValue)

                start: (tokens first start) stop: (tokens last stop);

                nameRange: ((tokens at: 3) start to: (tokens at: 4) stop)

                yourself.

            ]

!

state

    ^(bra , 'state' asParser trim , identifier , statebody , ket) 

        ==> [ :tokens | | ident |

                ident := (tokens at: 3).

                (PPCLRPState name: ident inputValue

                    body: (tokens at: 4))

                start: (tokens first start) stop: (tokens last stop);

                nameRange: (ident start to: ident stop);

                yourself.

            ]

!

statebody

    ^(onentry / running / onexit / machine / comment / errorNode) star

!

variable

    ^ (bra , 'var' asParser trim , identifier , ':=' asParser trim , smalltalkBlock , ket) 

        ==> [ :tokens | |ident|

            ident := (tokens at: 3).

            (PPCLRPVariable name: ident inputValue value: (tokens at: 5))

                start: (tokens first start) stop: (tokens last stop);

                nameRange: (ident start to: ident stop);

                yourself.

        ]

! !

!PPCLRPParser methodsFor:'grammar-comments'!

comment

    ^ ($; asParser, (endOfComment negate star),  endOfComment) token trim 

    ==> [ :token |  |text|

            text := token inputValue.

                (PPCLRPComment text: (text copyFrom: 1 to: text size -1) trim)

                start: (token start) stop: (token stop);

                yourself.

        ]

!

endOfComment

    ^ #eof asParser / lineTerminator

!

lineTerminator

    ^ (Character lf asParser) / (Character cr asParser , (Character lf asParser ) optional )

! !

!PPCLRPParser methodsFor:'grammar-common'!

bra

    ^ $( asParser token trim

!

identifier 

    ^(#letter asParser , (#word asParser /  $_ asParser) star) token trim

!

ket

    ^ $) asParser token trim

!

smalltalkBlock

    ^PPSmalltalkParser new productionAt: #block

! !

!PPCLRPParser methodsFor:'grammar-transitions'!

epsilon

    ^ (bra, 'eps' asParser trim, identifier, '->' asParser trim, identifier,  identifier optional, ket) 

        ==> [ :tokens |  | trans name |

                name := (tokens at: 6).

                name ifNil: [name := '' ] ifNotNil: [ name := name inputValue ].

                trans := 

                    (PPCLRPEpsilonTransition

                        from: (tokens at: 3) inputValue

                        to: (tokens at: 5) inputValue

                        name: name).

                self setTransitionRangesIn: trans for: tokens withArrowAt: 3. 

                trans

        ]

!

timeoutIdentifier

    ^ (bra, 'ontime' asParser trim, identifier , identifier, '->' asParser trim, identifier,  identifier optional, ket)

        ==> [:tokens | self transitionActionHandlerFor: PPCLRPTimeoutTransition tokens: tokens ].

    "Modified: / 30-07-2015 / 17:14:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

timeoutInteger

    ^ (bra, 'ontime' asParser trim,  integer, identifier, '->' asParser trim, identifier,  identifier optional, ket)

        ==> [ :tokens | | trans name |

        name := (tokens at: 7).

        name ifNil: [name := '' ] ifNotNil: [ name := name inputValue ].

        trans :=

            (PPCLRPTimeoutTransition

                on: (Integer readFrom: (tokens at: 3) inputValue)

                from: (tokens at: 4) inputValue

                to: (tokens at: 6) inputValue

                name: name).

        self setTransitionRangesIn: trans for: tokens withArrowAt: 4.

        trans.

    ]

!

transition

    ^ (bra, 'on' asParser trim, identifier, identifier, '->' asParser trim, identifier,  identifier optional , ket) 

        ==> [ :tokens | self transitionActionHandlerFor: PPCLRPTransition tokens: tokens ]

    "Modified: / 30-07-2015 / 17:15:13 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

wildcard

    ^ (bra, 'on' asParser trim, identifier,  '*->' asParser trim, identifier,  identifier optional, ket) 

        ==> [ :tokens |  | trans name |

                name := (tokens at: 6).

                name ifNil: [name := '' ] ifNotNil: [ name := name inputValue ].

                trans :=

                    (PPCLRPWildcardTransition

                        on: (tokens at: 3) inputValue

                        to: (tokens at: 5) inputValue

                        name: name ).

                self setTransitionRangesIn: trans for: tokens withArrowAt: 3. 

                trans

            ]

! !

!PPCLRPParser methodsFor:'parsing'!

parse: aText styleOn: aViewOrMorph

    |parsedProgram|

    parsedProgram := self parsePPCLRP: aText.

    self styler view: aViewOrMorph; parser: self; nodes: parsedProgram; style: aText.

    ^parsedProgram.

!

parsePPCLRP: aString

    |parsedProgram |

    failed := false.

    parsedProgram := self parse: aString.

    parsedProgram isPetitFailure ifTrue:[

        parsedProgram := 

            {PPCLRPErrorNode new 

                start: 1;

                stop: aString size; 

                yourself.

            }

    ].

    "visit pattern?"

    parsedProgram do:[:aNode|

        (aNode onErrorNode: [:anErrorNode| ] parser: self)

    ].

    ^parsedProgram.

! !

!PPCLRPParser methodsFor:'transitions'!

setTransitionRangesIn: aTransition for: aTokenArray withArrowAt: index

    | ident |

    ident := (aTokenArray at: index + 3).

    ident

        ifNil: [ aTransition nameRange: (1 to: 1) ]

        ifNotNil: [ aTransition nameRange: (ident start to: ident stop) ].

    aTransition

        start: (aTokenArray first start) stop: (aTokenArray last stop);

        arrowRange:

                    ((aTokenArray at: index) stop + 1

                        to: (aTokenArray at: index + 2) start -1);

        keywordEnd: (aTokenArray at: 3) start -1

!

transitionActionHandlerFor: class tokens: tokens

    | trans name|

    name := (tokens  at: 7).

    name isNil ifTrue:[ name := '' ] ifFalse:[ name := name inputValue ].

    trans :=

        (class

            on: (tokens at: 3) inputValue

            from: (tokens at: 4) inputValue

            to: (tokens at: 6) inputValue

            name: name).

    self setTransitionRangesIn: trans for: tokens withArrowAt: 4.

    ^ trans.

    "Created: / 30-07-2015 / 17:12:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !