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

Object subclass:#PPCNode
	instanceVariableNames:'contextFree name'
	classVariableNames:''
	poolDictionaries:''
	category:'PetitCompiler-Nodes'
!

!PPCNode methodsFor:'accessing'!

children
	^ #()
!

name: anObject
	
	name := anObject
!

prefix
	self subclassResponsibility 
!

suffix
	^ ''
! !

!PPCNode methodsFor:'analysis'!

acceptsEpsilon
	"return true, if parser can accept epsilon without failure"
	^ self subclassResponsibility
!

acceptsEpsilonOpenSet: set
	"private helper for acceptsEmpsilon that makes sure to avoid cycles (using open set)"
	self children isEmpty ifTrue: [ ^ self acceptsEpsilon ].
	
	self shouldBeImplemented .
!

allNodes
	| result |
	result := OrderedCollection new.
	self allParsersDo: [ :parser | result add: parser ].
	^ result
!

allNodesDo: aBlock
	"Iterate over all the parse nodes of the receiver."

	self allNodesDo: aBlock seen: IdentitySet new
!

allNodesDo: aBlock seen: aSet
	"Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."

	(aSet includes: self)
		ifTrue: [ ^ self ].
	aSet add: self.
	aBlock value: self.
	self children
		do: [ :each | each allNodesDo: aBlock seen: aSet ]
!

check
	"nothing to do"
	^ nil
!

firstSetSuchThat: block
	^ self firstSetSuchThat: block into: (OrderedCollection new) openSet: IdentitySet new.
!

firstSetSuchThat: block into: aCollection openSet: aSet
	(aSet includes: self) ifTrue: [ ^ aCollection ].
	aSet add: self.
	
	(block value: self) ifTrue: [aCollection add: self. ^ aCollection ].
	self children do: [ :child | 
		child firstSetSuchThat: block into: aCollection openSet: aSet 
	].
	^ aCollection
!

isContextFree
	^ contextFree ifNil: [ contextFree := self allNodes allSatisfy: [ :n | n isContextFreePrim  ] ]
!

isContextFreePrim
	^ true
!

isFirstSetTerminal
	"Answer true if the receiver is a terminal or leaf parser, that means it does not delegate to any other parser."

	^ self isTerminal
!

isNullable
	"Answer true if the receiver is a nullable parser, e.g. it can successfully parse nothing."
	
	^ false
!

isTerminal
	"Answer true if the receiver is a terminal or leaf parser, that means it does not delegate to any other parser."

	^ self children isEmpty
! !

!PPCNode methodsFor:'as yet unclassified'!

firstSet
	^ self firstSetSuchThat: [ :e | e isFirstSetTerminal ]
!

name
	^ name
! !

!PPCNode methodsFor:'comparison'!

= anotherNode
	(self == anotherNode) ifTrue: [ ^ true ].
	(anotherNode class = self class) ifFalse: [ ^ false ].
	
	(anotherNode name = name) ifFalse: [ ^ false ].
	^ anotherNode children = self children.
! !

!PPCNode methodsFor:'compiling'!

compileWith: compiler
	|  |
	^ self compileWith: compiler effect: #none
!

compileWith: compiler effect: effect
	| id |
	id := (compiler idFor: self prefixed: (self prefix) suffixed: (self suffix) effect: effect).
	(compiler checkCache: id) ifNotNil: [ ^ compiler ].

	^ self compileWith: compiler effect: effect id: id.
!

compileWith: compiler effect: effect id: id
	self subclassResponsibility 
! !

!PPCNode methodsFor:'gt'!

gtTreeViewIn: composite
	<gtInspectorPresentationOrder: 40>

	composite tree
			title: 'Tree';
			children: [:n | n children ];
			format: [:n| n name ifNil: [ n asString ] ifNotNil: [n name] ];
			shouldExpandToLevel: 6
! !

!PPCNode methodsFor:'optimizing'!

asFast
	^ self
!

asInlined
	^ self
!

checkTree
	| message |
	self allNodes do: [ :node | (message := node check) ifNotNil: [ self error: message ]  ].
!

defaultOptimizationParameters
	| parameters |
	parameters := IdentityDictionary new.
	parameters at: #inline put: true.
	parameters at: #rewrite put: true.

	^ parameters
!

doOptimizationLoop: params status: changeStatus
        | mapping optimized root |
        mapping := IdentityDictionary new.
        self allNodes do: [ :node |
                optimized := (node optimize: params status: changeStatus).
                (optimized ~= node) ifTrue: [  
                        mapping at: node put: optimized.
                ].
        ].
        
        root := mapping at: self ifAbsent: [ self ].
        [  | changed |
                changed := false.
                root allNodes do: [ :node |
                        node children do: [ :child | 
                                mapping at: child ifPresent: [:newChild | 
                                        node replace: child with: newChild.
                                        changed := true.
                                        changeStatus change]
                ]].
                changed 
        ] whileTrue.
        ^ root

    "Modified: / 26-10-2014 / 01:14:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

inline: changeStatus
	"nothing to do"
!

inline: params status: changeStatus
	(params at: #inline) ifTrue: [ 
		^ self inline: changeStatus
	]
!

optimize: params status: changeStatus
	" nothing to do "
!

optimizeTree
	^ self optimizeTree: #()
!

optimizeTree: params
	|  node newNode parameters status |
	
	parameters := self defaultOptimizationParameters.
	
	params do: [ :p | parameters at: p key put: p value ].
	
	node := self.
	[ 
		status := PPCOptimizationResult new.
		newNode := node doOptimizationLoop: parameters status: status.
		status isChange.
	] whileTrue: [ node := newNode ].
	^ node
!

rewrite: changeStatus
	"nothing to do"
!

rewrite: params status: changeStatus
	(params at: #rewrite) ifTrue: [  
		^ self rewrite: changeStatus.
	].
! !

!PPCNode methodsFor:'printing'!

printNameOn: aStream
	self name isNil
		ifTrue: [ aStream print: self hash ]
		ifFalse: [ aStream nextPutAll: self name. aStream nextPut: $-. aStream print: self hash. ]
!

printOn: aStream
	super printOn: aStream.
	aStream nextPut: $(.
	self printNameOn: aStream.
	aStream nextPut: $)
! !

!PPCNode methodsFor:'todel'!

allParsersDo: aBlock
	"Iterate over all the parse nodes of the receiver."

	self allParsersDo: aBlock seen: IdentitySet new
!

allParsersDo: aBlock seen: aSet
	"Iterate over all the parse nodes of the receiver, do not visit and follow the ones contained in aSet."

	(aSet includes: self)
		ifTrue: [ ^ self ].
	aSet add: self.
	aBlock value: self.
	self children
		do: [ :each | each allParsersDo: aBlock seen: aSet ]
!

firstSets: aFirstDictionary into: aSet
	self children do: [ :child | aSet addAll: (aFirstDictionary at: child) ]
! !

!PPCNode methodsFor:'transformation'!

asCompilerNode
	^ self
!

replace: node with: anotherNode
!

transform: aBlock
	"Answer a copy of all parsers reachable from the receiver transformed using aBlock."

	| mapping root |
	mapping := IdentityDictionary new.
	self allParsersDo: [ :each |
		mapping
			at: each
			put: (aBlock value: each copy) ].
	root := mapping at: self.
	[	| changed |
		changed := false.
		root allParsersDo: [ :each |
			each children do: [ :old |
				mapping at: old ifPresent: [ :new |
					each replace: old with: new.
					changed := true ] ] ].
		changed ] whileTrue.
	^ root
! !