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

"{ NameSpace: Smalltalk }"

PPCNodeVisitor subclass:#PEGFsaGenerator
	instanceVariableNames:''
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-FSA'
!

!PEGFsaGenerator methodsFor:'hooks'!

afterAccept: node retval: retval
    retval checkSanity.
    ^ super afterAccept: node retval: retval
!

cache: node value: retval
    (self assert: (retval isKindOf: PEGFsa)).

    (cache includesKey: node) ifTrue: [
        self assert: (retval isIsomorphicTo: (cache at: node)).
    ].

    "I put copy of the FSA because FSA can be modified (e.g. concatenated to other FSA)"
    cache at: node put: retval copy.
!

openDetected: node
    "
        This should be called when there is a recursive definition of a token.
        The forward node caches the fsa stub with startState in order to reference it
    "
    ^ (self cachedValue: node)
! !

!PEGFsaGenerator methodsFor:'support'!

connect: fsa with: anotherFsa
    | finals |
    finals := fsa finalStates reject: [:s | s isFsaFailure ].

    self assert: (finals allSatisfy: [ :s | s priority = 0 ]).
    self assert: (finals allSatisfy: [:f | fsa states includes: f]).
    
    finals do: [ :final |
        | toAdopt |
        toAdopt := anotherFsa.
        toAdopt decreasePriority.
        final final: false.	

        fsa adopt: toAdopt.
        fsa addTransitionFrom: final to: toAdopt startState.
    ].
!

connectOverlapping: fsa with: anotherFsa
    | finals |
    finals := fsa finalStates reject: [:s | s isFsaFailure ].

    self assert: (finals allSatisfy: [ :s | s priority = 0 ]).
    self assert: (finals allSatisfy: [:f | fsa states includes: f]).
    
    finals do: [ :final |
        | toAdopt |
        toAdopt := anotherFsa copy.
        toAdopt decreasePriority.
        final final: false.	

        fsa adopt: toAdopt.
        fsa addTransitionFrom: final to: toAdopt startState.
    ].
!

sequenceOf: fsa and: anotherFsa
    | newFsa start   |

    newFsa := PEGFsa new.
    start := PEGFsaState new name: 'start'; yourself.
    newFsa addState: start.
    newFsa startState: start.
    newFsa adopt: fsa.
    newFsa addTransitionFrom: start to: fsa startState.

    (newFsa finalStates size == 1) ifTrue: [  
        self connect: newFsa with: anotherFsa.
    ] ifFalse: [ 
    (newFsa finalStates allSatisfy: [ :s | s transitions isEmpty ]) ifTrue: [  
        self connect: newFsa with: anotherFsa.
    ] ifFalse: [ 
        self connectOverlapping: newFsa with: anotherFsa.
    ]].
    
    newFsa determinize.
    ^ newFsa
! !

!PEGFsaGenerator methodsFor:'visiting'!

visitAnyNode: node
    | stop start fsa classification |
    start := PEGFsaState new.
    stop := PEGFsaState new.
    
    classification := Array new: 255 withAll: true.
    
    fsa := PEGFsa new
        addState: start;
        addState: stop;
        
        startState: start;
        finalState: stop;
        yourself.
    
    fsa addTransitionFrom: start to: stop onCharacterSet: (classification).
    
    ^ fsa
!

visitCharSetPredicateNode: node
    | stop start fsa |
    start := PEGFsaState new.
    stop := PEGFsaState new.
    
    fsa := PEGFsa new
        addState: start;
        addState: stop;
        
        startState: start;
        finalState: stop;
        yourself.
    
    fsa addTransitionFrom: start to: stop onCharacterSet: (node predicate classification).
        
    ^ fsa
!

visitCharacterNode: node
    | stop start |
    start := PEGFsaState new.
    stop := PEGFsaState new.
    stop name: node character storeString.
    
    ^ PEGFsa new
        addState: start;
        addState: stop;
        
        startState: start;
        finalState: stop;

        addTransitionFrom: start to: stop on: node character;
        yourself
!

visitChoiceNode: node
    | priority childrenFsa fsa start |
    childrenFsa := node children collect: [ :child | child accept: self ].
    self assert: (childrenFsa allSatisfy: [ :child | child isDeterministic  ]).

    fsa := PEGFsa new.
    start := PEGFsaState new.
    
    fsa addState: start.
    fsa startState: start.

    priority := 0.
    childrenFsa do: [ :childFsa |
        childFsa decreasePriorityBy: priority.
        fsa adopt: childFsa.
        fsa addTransitionFrom: start to: childFsa startState.
        priority := priority + 1.
        
        fsa determinizeChoice.
    ].

    ^ fsa
!

visitEndOfFileNode: node
    | stop start fsa transition |
    start := PEGFsaState new.
    stop := PEGFsaState new.
    stop name: 'EOF'.
    
    fsa := PEGFsa new
        addState: start;
        addState: stop;
        
        startState: start;
        finalState: stop;

        yourself.
        
    transition := PEGFsaEOFTransition new
        predicate: [ :cp | cp == 0 ];
        destination: stop;
        yourself.
        
    start addTransition: transition.
    ^ fsa
!

visitForwardNode: node
    | fsa childFsa startState startStubState |

    fsa	 := PEGFsa new.
    startStubState := PEGFsaUncopiableState new.
    startState := PEGFsaState new.

    fsa addState: startStubState.
    fsa startState: startStubState.


    "  cache the incomplete fsa in order to allow for
        recursive back references... 
    "	
    self cache: node value: fsa.

    childFsa := self visit: node child.
    
    cache removeKey: node.
    
    fsa adopt: childFsa.
    fsa replace: startStubState with: startState.


    fsa addTransitionFrom: startState to: childFsa startState.
    fsa startState: startState.

    fsa name: self name.
    ^ fsa
!

visitLiteralNode: node
    | states fsa |

    states := OrderedCollection new.
    (node literal size + 1) timesRepeat: [
        states add: PEGFsaState new
    ].

    fsa := PEGFsa new.
    states do: [ :state | fsa addState: state ].	
    fsa	 startState: states first;
         finalState: states last;
         yourself.
        
    (1 to: (states size - 1)) do: [ :index |
        fsa addTransitionFrom: (states at: index)
         	 to: (states at: index + 1)
             on: (node literal at: index).
        "set the name"
        (states at: (index + 1)) name: (node literal at: index). 
    ].

    fsa name: node literal.
    ^ fsa
!

visitMessagePredicateNode: node
    ^ self visitPredicateNode: node
!

visitNode: node
    self error: 'node not supported'
!

visitNotCharacterNode: node
    self assert: (node child isKindOf: PPCCharacterNode).
    
    ^ self visitNotNode: node
!

visitNotNode: node
    | fsa finalState |
    fsa := node child accept: self.
    finalState := PEGFsaState new
        name: '!!', fsa name asString;
        yourself.
    
    fsa finalStates do: [ :fs |
        fs failure: true.
    ].
    
    fsa finalState: fsa startState.
    
    ^ fsa
!

visitOptionalNode: node
    | fsa   |

    fsa := node child accept: self.
    fsa finalState: fsa startState.

    ^ fsa
!

visitPlusNode: node
    | fsa |

"	finalState := PEGFsaState new."
    fsa := node child accept: self.
"	fsa addState: finalState."
    
    fsa finalStates do: [ :state |
        fsa addTransitionFrom: state to: (fsa startState).
"		fsa addTransitionFrom: state to: finalState priority: fsa minPriority."
"		state hasPriority ifFalse: [ state priority: 0 ].
        state final: false.
"	].

"	fsa finalState: finalState.	"
    
    ^ fsa
!

visitPredicateNode: node
    | stop start fsa classification |
    start := PEGFsaState new.
    stop := PEGFsaState new.
    
    classification := (1 to: 255) collect: [:codePoint | node predicate value: (Character codePoint: codePoint) ].
    
    fsa := PEGFsa new
        addState: start;
        addState: stop;
        
        startState: start;
        finalState: stop;
        yourself.
    
    fsa addTransitionFrom: start to: stop onCharacterSet: (classification).
    
    ^ fsa
!

visitSequenceNode: node
    | fsa childrenFsa previousFsa  |
    childrenFsa := node children collect: [ :child | self visit: child ].
    self assert: (childrenFsa allSatisfy: [ :child | child isDeterministic  ]).

    previousFsa := childrenFsa first.
    childrenFsa allButFirst do: [ :nextFsa | 
        fsa := self sequenceOf: previousFsa and: nextFsa.
        previousFsa := fsa.
    ].
    
    ^ fsa
!

visitStarNode: node
    | fsa  |

"	finalState := PEGFsaState new.
"	fsa := node child accept: self.
"	fsa addState: finalState.
"	
    fsa finalStates do: [ :state |
        fsa addTransitionFrom: state to: (fsa startState).
"		state hasPriority ifFalse: [ state priority: 0 ].
        state final: false.
"	].

"	fsa addTransitionFrom: fsa startState to: finalState priority: -1."	
    fsa finalState: fsa startState.

    ^ fsa
!

visitTokenNode: node
    ^ self visit: node child
!

visitTrimmingTokenCharacterNode: node
    "I do not care about trimming (so far), it should be handled by TokenCodeGenerator"
    ^ self visit: node child
!

visitTrimmingTokenNode: node
    "I do not care about trimming (so far), it should be handled by TokenCodeGenerator"
    ^ self visit: node child
! !