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

"{ NameSpace: Smalltalk }"

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

!PPCNode class methodsFor:'as yet unclassified'!

new
	^ self basicNew initialize
! !

!PPCNode methodsFor:'accessing'!

children
	^ #()
!

markForInline
    "Marks receiver for inlining, i.e., it's parsing code
     should be inlined into parent's code"
    self propertyAt: #inlined put: true

    "Created: / 23-04-2015 / 15:39:01 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

name
	^ name
!

name: anObject
	
	name := anObject
!

prefix
	^ 'anode' 
!

suffix
	^ ''
!

unmarkForInline
    "Forbids inlining of receiver's parsing code"
    self propertyAt: #inlined put: false

    "Created: / 23-04-2015 / 15:39:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!PPCNode methodsFor:'accessing-properties'!

hasProperty: aKey
	"Test if the property aKey is present."
	
	^ properties notNil and: [ properties includesKey: aKey ]
!

properties
	^ properties
!

properties: aDictionary
	properties := aDictionary 
!

propertyAt: aKey 
	^ self propertyAt: [ aKey ] ifAbsent: [ nil ]
!

propertyAt: aKey ifAbsent: aBlock
	"Answer the property value associated with aKey or, if aKey isn't found, answer the result of evaluating aBlock."
	
	^ properties isNil
		ifTrue: [ aBlock value ]
		ifFalse: [ properties at: aKey ifAbsent: aBlock ]
!

propertyAt: aKey put: anObject
	"Set the property at aKey to be anObject. If aKey is not found, create a new entry for aKey and set is value to anObject. Answer anObject."

	^ (properties ifNil: [ properties := Dictionary new: 1 ])
		at: aKey put: anObject
! !

!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
!

firstCharSetCached
	firstCharSet ifNil: [ 
 		firstCharSet := self firstCharSet.
	].
	^ firstCharSet
!

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

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

hash
	"TODO JK: IMO not a good hashing function bacause of children size, 
		but at least it is not recursive, which would be worse :)
	"
	^ self class hash bitXor: (name hash bitXor: self children size hash)
! !

!PPCNode methodsFor:'first follow next'!

firstSet
	^ firstFollowCache at: #firstSet ifAbsentPut: [
		self firstSets at: self
	]
!

firstSet: set
	firstFollowCache at: #firstSet put: set
!

firstSets
	^ self firstSetsSuchThat: [ :e | e isFirstSetTerminal ]
!

firstSets: aFirstDictionary into: aSet suchThat: aBlock
	"PRIVATE: Try to add additional elements to the first-set aSet of the receiver, use the incomplete aFirstDictionary."

	(aBlock value: self) ifFalse: [ 
		self children do: [ :node | aSet addAll: (aFirstDictionary at: node) ]
	]
!

firstSetsSuchThat: block

	| firstSets |
	firstSets := IdentityDictionary new.
	self allParsersDo: [ :each |
		firstSets at: each put: ((block value: each)
			ifTrue: [ IdentitySet with: each ]
			ifFalse: [ IdentitySet new ]).
		each isNullable
			ifTrue: [ (firstSets at: each) add: PPCSentinelNode instance ] ].
		
		
	[	| changed tally |
		changed := false.
		firstSets keysAndValuesDo: [ :node :first |
			tally := first size.
			node firstSets: firstSets into: first suchThat: block.
			changed := changed or: [ tally ~= first size ] ].
		changed ] whileTrue.
	^ firstSets
!

followSet
	^ firstFollowCache at: #followSet ifAbsent: [ self error: 'no follow set cached' ]
!

followSet: aSet
	^ firstFollowCache at: #followSet put: aSet
!

followSetIn: rootNode
	^ rootNode followSets at: self
!

followSetWithTokens
	^ firstFollowCache at: #followSetWithTokens ifAbsent: [ self error: 'no follow with tokens cached' ]
!

followSetWithTokens: aSet
	^ firstFollowCache at: #followSetWithTokens put: aSet
!

followSets
	^ self followSetsSuchThat: [ :e | e isFirstSetTerminal ]
!

followSets: aFollowDictionary firstSets: aFirstDictionary into: aSet suchThat: aBlock
	"PRIVATE: Try to add additional elements to the follow-set aSet of the receiver, use the incomplete aFollowDictionary and the complete aFirstDictionary."
	
	self children do: [ :node | (aFollowDictionary at: node) addAll: aSet ]
!

followSetsSuchThat: aBlock
	"Answer a dictionary with all the parsers reachable from the receiver as key and their follow-set as value. The follow-set of a parser is the list of terminal parsers that can appear immediately to the right of that parser."
	
	| current previous continue firstSets followSets |
	current := previous := 0.
	firstSets := self firstSetsSuchThat: aBlock.
	followSets := IdentityDictionary new.
	self allNodesDo: [ :each | followSets at: each put: IdentitySet new ].
	(followSets at: self) add: PPCSentinelNode instance.
	[	followSets keysAndValuesDo: [ :node :follow |
			node 
				followSets: followSets
				firstSets: firstSets
				into: follow
				suchThat: aBlock ].
		current := followSets
			inject: 0
			into: [ :result :each | result + each size ].
		continue := previous < current.
		previous := current.
		continue ] whileTrue.
	^ followSets
!

nextSetIn: rootNode
	^ rootNode nextSets at: self
!

nextSets
		| nextSets |
	
	nextSets := IdentityDictionary new.
	self allNodesDo: [ :each | nextSets at: each put: IdentitySet new ].
	
	(nextSets at: self) add: PPCSentinelNode instance.
	
	[ 	| changed |
		changed := false.
	
		nextSets keysAndValuesDo: [:node :next |
			changed := (node 
				nextSets: nextSets
				into: next) or: [ changed ].
		].
		changed ] whileTrue.
	
	^ nextSets
!

nextSets: aNextDictionary into: aSet
	"return true/false, if something has changed or not...."
	| childSet change tally |
	
	change := false.
	
	self children do: [:each | 
		childSet := aNextDictionary at: each.
		tally := childSet size.
		childSet addAll: aSet.
		change := change or: [ tally ~= childSet size ].
	].

	^ change
	
! !

!PPCNode methodsFor:'gt'!

gtTreeViewIn: composite
	<gtInspectorPresentationOrder: 40>

	composite tree
			title: 'Tree';
			children: [:n | n children ];
			format: [:n| String streamContents: [:s | n printOn: s. n printHashOn: s] ];
			shouldExpandToLevel: 6
! !

!PPCNode methodsFor:'initialization'!

initialize
	super initialize.
	firstFollowCache := IdentityDictionary new.
! !

!PPCNode methodsFor:'optimizing'!

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

optimizeTree
	^ self optimizeTree: #(#token #inline #rewrite #merge)
!

optimizeTree: params
	| retval | 

	"Default optimization sequence"
	retval := self.
	
	(params includes: #rewrite) ifTrue: [ retval := PPCOptimizingVisitor new visit: retval ].
	(params includes: #token) ifTrue: [ retval := PPCTokenDetector new visit: retval ].
	(params includes: #rewrite) ifTrue: [ retval := PPCOptimizingVisitor new visit: retval ].
	(params includes: #inline) ifTrue: [ retval := PPCInliningVisitor new visit: retval ].
	(params includes: #merge) ifTrue: [ retval := PPCMergingVisitor new visit: retval ].
	^ retval
! !

!PPCNode methodsFor:'printing'!

printHashOn: aStream
	aStream print: 'Hash:', self hash asString
!

printIdOn: aStream
	aStream print: 'ID:', self identityHash asString
!

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

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

!PPCNode methodsFor:'testing'!

isMarkedForInline
    ^ self propertyAt: #inlined ifAbsent: [ false ].

    "Created: / 23-04-2015 / 15:40:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!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 ]
! !

!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 |
	self halt: 'doprecate?'.
	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
! !

!PPCNode methodsFor:'visiting'!

accept: visitor
	visitor visitNode: self
! !