"{ Package: 'stx:goodies/ring' }"

"{ NameSpace: Smalltalk }"

RGElementDefinition subclass:#RGMethodDefinition

	instanceVariableNames:'protocol sourceCode stamp package'

	classVariableNames:''

	poolDictionaries:''

	category:'Ring-Core-Kernel'

!

RGMethodDefinition comment:'RGMethodDefinition is a concrete representation of methods. It can be used to build browser for methods that are not in the image. It is polymorphic with CompiledMethod. 

* We can ask a RGMethodDefinition for its selector using the selector message.

Example:

	(Point>>#dist:) asRingDefinition selector

		-> #dist

We can also ask the ring object representation of its class or the Smalltalk class actually implementing the corresponding compiledMethod. 

* To access the ring class definition name, use parentName

	aRGMethodDefinition parentName

Example:

	(Point>>#dist:) asRingDefinition parentName

		->  #Point

* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent

	aRGMethodDefinition parent

Example:

	aRGMethodDefinition(Point>>#dist:) parent

		->  aRGClassDefinition(Point)

* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realParent

	aRGMethodDefinition realParent

Example:

	(Point>>#dist:) asRingDefinition realParent

		->  Point

Now a RingEntityDefinition offers two APIs: one that is generic and works for all the source code entities and this is the one we just 

presented: parent, parentName and realParent. Having such interface is important to build generic tools that could manipulate 

any entities in a polymorphic way (yes no isKindOf: everywhere).

In addition, a ring method definition offers a specific interface that should only be used when you know that you are solely manipulate

specific entity such as class element: method definition, class comment, and variables. 

Here is the equivalence table

	realParent 				realClass

	parent					ringClass

	parentName			className

* The message class returns the class of the object :).

Example:

	(Point>>#dist:) asRingDefinition class

		->  RingMethodDefinition

* The message className returns the name of the ring class defining the reingMethodDefinition.

Example:

	(Point>>#dist:) asRingDefinition className

		->  #Point		

* If you have a complete model where classes and methods are ring definition, to access the ring class definition , use parent

	aRGMethodDefinition ringClass

Example:

	aRGMethodDefinition(Point>>#dist:) ringClass

		->  aRGClassDefinition(Point)

* If you want to access the smalltalk class that contains the compiledMethod that is represented by a ringMethodDefinition, use realClass

	aRGMethodDefinition realClass

Example:

	(Point>>#dist:) asRingDefinition realClass

		->  Point

'

!

!RGMethodDefinition class methodsFor:'instance creation'!

class: aRGBehaviorDefinition selector: aString

    "Create a ring method definition from a ring class and a selector"

    ^(self class: aRGBehaviorDefinition)

        selector: aString asSymbol;

        yourself

!

className: aString selector: aSelector isMetaSide: aBoolean

    ^ (self class: (RGClassDefinition named: aString) selector: aSelector) isMetaSide: aBoolean; yourself

!

realClass: aClass selector: aString

    "Creates a ring method definition from a Smalltalk class and a selector <compiledMethod>"

    ^(aClass >> aString asSymbol) asActiveRingDefinition

    "Modified (format): / 29-08-2015 / 10:25:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!RGMethodDefinition class methodsFor:'categories'!

unclassifiedProtocolName

    "Return the string labeling the unclassified protocol."

    ^ 'as yet unclassified'

! !

!RGMethodDefinition class methodsFor:'elements-annotations'!

isExtensionKey 

    ^#isExtension

! !

!RGMethodDefinition methodsFor:'accessing'!

ast

!

compiledMethod

    "Retrieves the compiled method of this definition if exists"

    | rClass |

    (rClass := self realClass) notNil

        ifTrue: [ (rClass includesSelector: self selector)

            ifTrue: [ ^rClass >> self selector ] ].

    ^nil

!

fullName

    "Keeps a unique description for the receiver. As annotation to avoid converting each time is invoked"

    ^self annotationNamed: self class fullNameKey

        ifAbsentPut: [ (self parentName, '>>', self selector) asSymbol ]

!

isExtension

    "The receiver is an extension when is defined in a different package to the one of its parent.

    Ring allows to set this property. If not assigned tries to find its value "

    ^self 

        annotationNamed: self class isExtensionKey

        ifAbsent: [  

            (self parent notNil and:[ self package notNil ]) ifTrue: [ 

                | value |

                value :=  self parent package ~= self package.

                self annotationNamed: self class isExtensionKey put: value.

                value 

            ] ifFalse: [ 

                self isActive ifTrue:[ 

                    | cm |

                    cm := self compiledMethod.

                    cm isExtension.

                ] ifFalse:[ 

                    false

                ].

            ]

        ]

    "Modified: / 29-08-2015 / 10:23:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

isExtension: aBoolean

    "Explicitily set that the receiver is an extension"

    self annotationNamed: self class isExtensionKey put: aBoolean 

!

origin

    "Return the real oring of this method."

    | mthd |

    ^ (mthd := self compiledMethod)

        ifNil: [ self methodClass ]

        ifNotNil: [ mthd origin ]

!

package

    "Retrieves the package in which this class is contained, if exists"

    ^package

!

package: aRGPackage

    package:= aRGPackage

!

protocol

    self isActive 

        ifTrue: [ ^ self compiledMethod ifNil: [ protocol ] ifNotNil: [ self compiledMethod category ]].

    self isHistorical

        ifTrue: [ ^ self protocolAtPointer ifNil: [ | cm | (cm := self compiledMethod) ifNil: [ protocol ] ifNotNil:[ cm category ] ] ].

    ^ protocol

    "Modified: / 29-08-2015 / 08:20:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

protocol: anObject

    protocol := anObject

!

selector

    "Retrieves the name of the method"

!

selector: aSymbol

    "The name of a method is known as #selector"

    name := aSymbol

!

sourceCode

    self isActive 

        ifTrue: [ ^ self compiledMethod ifNil:[ sourceCode ] ifNotNil: [ self compiledMethod sourceCode ]].

    ^ sourceCode

    "Modified: / 29-08-2015 / 08:03:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

sourceCode: anObject

    sourceCode := anObject

!

stamp

    self isActive 

        ifTrue: [ ^ self compiledMethod timeStamp ].

    ^ stamp

    "Modified: / 29-08-2015 / 08:03:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

stamp: anObject

    "stores an author alias and a timestamp"

    stamp := anObject

! !

!RGMethodDefinition methodsFor:'backward compatibility'!

category

    ^ self protocol

!

messages

    ^ self method messages

!

method

    ^self compiledMethod

!

methodClass

    "Return the class to which the receiver belongs to."

    ^ self realClass

!

symbolic

    ^ self method symbolic

! !

!RGMethodDefinition methodsFor:'comparing'!

<= aRGMethodDefinition

    "Sort method definitions according to: 1. class name - 2. class comment - 3. method selector - 4. timestamp"

    self parentName < aRGMethodDefinition parentName ifTrue: [^true].

    self parentName > aRGMethodDefinition parentName ifTrue: [^false].

    self flag: 'This ugly test is needed right now because the old system is used to represent 

    class comment as method with Comment selector. And to mix comment and methods'.

    aRGMethodDefinition isComment ifTrue: [^false].

    ^(self selector < aRGMethodDefinition selector) 

 		  or: [ (self selector == aRGMethodDefinition selector) and: [

    			  self timeStamp <= aRGMethodDefinition timeStamp ]]

!

= aRGMethodDefinition

    "This method look for equality of the key properties of the receiver"

    ^(super = aRGMethodDefinition)

        and: [ self selector == aRGMethodDefinition selector]

!

hash

    ^super hash bitXor: self selector hash

! !

!RGMethodDefinition methodsFor:'managing container'!

addInContainer: aRGContainer

    aRGContainer addMethod: self

!

isIncludedInContainer: aRGContainer

    ^aRGContainer includesMethod: self

!

removeFromContainer: aRGContainer

    aRGContainer removeMethod: self

! !

!RGMethodDefinition methodsFor:'metrics'!

numberOfLinesOfCode

    ^ self annotationNamed: #numberOfLinesOfCode ifAbsentPut: [ self sourceCode lineCount ]

! !

!RGMethodDefinition methodsFor:'operations'!

recompile

    self method recompile

! !

!RGMethodDefinition methodsFor:'printing'!

printOn: aStream 

    self parentName ifNotNil: [

        aStream nextPutAll: self parentName;

                  nextPutAll: '>>' ].

    aStream print: self selector

! !

!RGMethodDefinition methodsFor:'source pointers'!

getPreambleFrom: aFileStream at: position

    ^ SourceFiles getPreambleFrom: aFileStream at: position

!

protocolAtPointer

    "A RGMethodDefinition that was set as historical will retrieve the protocol using the sourcePointer"

    self shouldNotImplement. "/ No source pointers in Smalltalk/X    

"/    ^ self sourcePointer notNil

"/        ifTrue: [ SourceFiles protocolAt: self sourcePointer ]

"/        ifFalse:[ nil ]

    "Modified: / 29-08-2015 / 08:02:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

sourceCodeAtPointer

    "A RGMethodDefinition that was set as historical will retrieve the sourceCode using the sourcePointer"

    self shouldNotImplement. "/ No source pointers in Smalltalk/X

"/    ^ self sourcePointer notNil

"/        ifTrue: [ SourceFiles sourceCodeAt: self sourcePointer ]

"/        ifFalse:[ nil ]

    "Modified: / 29-08-2015 / 08:02:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

sourcePointer

    "Retrieves the sourcePointer for this definition if exists"

    self shouldNotImplement. "/ No source pointers in Smalltalk/X    

"/    ^self annotationNamed:  self class sourcePointerKey

    "Modified: / 29-08-2015 / 08:02:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

sourcePointer: aNumber

    self shouldNotImplement. "/ No source pointers in Smalltalk/X

"/    self annotationNamed:  self class sourcePointerKey put: aNumber

    "Modified: / 29-08-2015 / 08:02:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

stampAtPointer  

    "A RGMethodDefinition that was set as historical will retrieve the stamp using the sourcePointer"

    self shouldNotImplement. "/ No source pointers in Smalltalk/X

"/    ^ self sourcePointer notNil

"/        ifTrue: [ SourceFiles timeStampAt: self sourcePointer ]

"/        ifFalse:[ nil ]

    "Modified: / 29-08-2015 / 08:03:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!RGMethodDefinition methodsFor:'stamp values'!

author 

    ^self 

        annotationNamed: self class authorKey

        ifAbsentPut: [ self class parseAuthorAliasFrom: self stamp ]

!

author: aString 

    self annotationNamed: self class authorKey put: aString 

!

timeStamp 

    ^self annotationNamed: self class timeStampKey 

        ifAbsentPut: [ self class 

                            parseTimestampFrom: self stamp 

                            default: (DateAndTime epoch) ]

!

timeStamp: aTimestamp 

    self annotationNamed: self class timeStampKey put: aTimestamp 

! !

!RGMethodDefinition methodsFor:'testing'!

hasStamp

    ^stamp isEmptyOrNil not

!

isAbstract

    ^ self compiledMethod isAbstract

!

isDefined

    "Answer whether the receiver exists in the environment"

    | rClass |

    self selector isDoIt ifTrue:[ ^false ].

    rClass := self realClass.

    ^rClass notNil and: [ rClass includesSelector: self selector ]

!

isFromTrait

    "Return true for methods that have been included from Traits"

    ^ self origin isTrait and: [ self origin ~= self methodClass ]

!

isLocalSelector

    "Answer whether the receiver exists in the environment as a local implementation"

    | rClass |

    rClass:= self realClass.

    ^rClass notNil and: [ rClass includesLocalSelector: self selector ]

!

isMethod

    ^true

!

isOverridden

    ^ self compiledMethod isOverridden

!