amber/st/Compiler-Tests.st

Smalltalk current createPackage: 'Compiler-Tests' properties: #{}!
TestCase subclass: #ImporterTest
	instanceVariableNames: ''
	category: 'Compiler-Tests'!

!ImporterTest methodsFor: 'private'!

chunkString

	^'!!Object methodsFor: ''importer test method''!!

importerTestMethod

	^''success''
!! !!
'
!

bigChunkString

	^'Smalltalk current createPackage: ''Cypress-Definitions'' properties: #{}!!
Object subclass: #CypressSnapshot
	instanceVariableNames: ''definitions''
	package: ''Cypress-Definitions''!!

!!CypressSnapshot methodsFor: ''not yet classified''!!

definitions: aDefinitions

	definitions := aDefinitions
!!

definitions

	^definitions
!! !!

!!CypressSnapshot class methodsFor: ''not yet classified''!!

definitions: aDefinitions

	^(self new) definitions: aDefinitions
!! !!

Object subclass: #CypressPackage
	instanceVariableNames: ''name''
	package: ''Cypress-Definitions''!!

!!CypressPackage methodsFor: ''not yet classified''!!

= other
	^ other species = self species and: [other name sameAs: name]
!!

name
	^ name
!!

name: aString
	name := aString
!!

snapshot
	| package definitions name  |
	package := Package named: self name.
	definitions := OrderedCollection new.
	package sortedClasses do: [:cls |
        	definitions add: cls asCypressClassDefinition.
                cls methodDictionary values do: [:method |
			(method category match: ''^\*'') ifFalse: [ 
				definitions add: method asCypressMethodDefinition ]].
                cls class methodDictionary values do: [:method |
			(method category match: ''^\*'') ifFalse: [ 
				definitions add: method asCypressMethodDefinition ]]].
	name := package name.
	Smalltalk current classes, (Smalltalk current classes collect: [:each | each class]) do: [:each |
		each methodDictionary values do: [:method |
			method category = (''*'', name) ifTrue: [
				definitions add: method asCypressMethodDefinition ]]].
	^ CypressSnapshot definitions: definitions
!!

printString
	^super printString, ''('', name, '')''
!! !!

Object subclass: #CypressDefinition
	instanceVariableNames: ''''
	package: ''Cypress-Definitions''!!

!!CypressDefinition methodsFor: ''not yet classified''!!

= aDefinition
	^(aDefinition isKindOf: CypressDefinition) and: [self isRevisionOf: aDefinition]
!!

isRevisionOf: aDefinition
	^ (aDefinition isKindOf: CypressDefinition) and: [aDefinition description = self description]
!!

description
	self subclassResponsibility
!!

isSameRevisionAs: aDefinition
	^ self = aDefinition
!! !!

Object subclass: #CypressPatch
	instanceVariableNames: ''operations''
	package: ''Cypress-Definitions''!!

!!CypressPatch methodsFor: ''not yet classified''!!

fromBase: baseSnapshot toTarget: targetSnapshot
	| base target |	
	operations := OrderedCollection new.
	base := CypressDefinitionIndex definitions: baseSnapshot definitions.
	target := CypressDefinitionIndex definitions: targetSnapshot definitions.
	
	target definitions do:
		[:t |
		base
			definitionLike: t
			ifPresent: [:b | (b isSameRevisionAs: t) ifFalse: [operations add: (CypressModification of: b to: t)]]
			ifAbsent: [operations add: (CypressAddition of: t)]].
		
	base definitions do:
		[:b |
		target
			definitionLike: b
			ifPresent: [:t | ]
			ifAbsent: [operations add: (CypressRemoval of: b)]]
!!

operations

	^operations
!! !!

!!CypressPatch class methodsFor: ''not yet classified''!!

fromBase: baseSnapshot toTarget: targetSnapshot
	^ (self new)
		fromBase: baseSnapshot
		toTarget: targetSnapshot
!! !!

Object subclass: #CypressDefinitionIndex
	instanceVariableNames: ''definitionMap''
	package: ''Cypress-Definitions''!!

!!CypressDefinitionIndex methodsFor: ''not yet classified''!!

add: aDefinition
	^ self definitionMap at: aDefinition description put: aDefinition
!!

addAll: aCollection
	aCollection do: [:ea | self add: ea]
!!

definitionLike: aDefinition ifPresent: foundBlock ifAbsent: errorBlock
	| definition |
	definition := self definitionMap at: aDefinition description ifAbsent: [].
	^ definition
		ifNil: errorBlock
		ifNotNil: [foundBlock value: definition]
!!

definitions
	^self definitionMap values
!!

definitionMap
	definitionMap ifNil: [ definitionMap := Dictionary new ].
	^ definitionMap
!!

remove: aDefinition
	self definitionMap removeKey: aDefinition description ifAbsent: []
!! !!

!!CypressDefinitionIndex class methodsFor: ''not yet classified''!!

definitions: aCollection
	^ self new addAll: aCollection
!! !!

Object subclass: #CypressPatchOperation
	instanceVariableNames: ''''
	package: ''Cypress-Definitions''!!

CypressDefinition subclass: #CypressClassDefinition
	instanceVariableNames: ''name superclassName category comment instVarNames classInstVarNames''
	package: ''Cypress-Definitions''!!

!!CypressClassDefinition methodsFor: ''not yet classified''!!

name: aClassName superclassName: aSuperclassName category: aCategory instVarNames: anInstanceVariableNames classInstVarNames: aClassInstanceVariableNames comment: aComment

	name := aClassName.
	superclassName := aSuperclassName.
	category := aCategory.
	instVarNames := anInstanceVariableNames.
	classInstVarNames := aClassInstanceVariableNames.
	comment := aComment
!!

= aDefinition
	^(super = aDefinition)
		and: [superclassName = aDefinition superclassName
		and: [category = aDefinition category
		and: [instVarNames = aDefinition instVarNames
		and: [classInstVarNames = aDefinition classInstVarNames
		and: [comment = aDefinition comment]]]]]
!!

superclassName

	^superclassName
!!

name

	^name
!!

category

	^category
!!

comment

	^comment
!!

description

	^ Array with: name
!!

instVarNames

	^instVarNames
!!

classInstVarNames

	^classInstVarNames
!! !!

!!CypressClassDefinition class methodsFor: ''not yet classified''!!

name: aClassName 
superclassName: aSuperclassName
category: aCategory
instVarNames: anInstanceVariableNames
classInstVarNames: aClassInstanceVariableNames
comment: aComment

	^(self new) 
		name: aClassName 
		superclassName: aSuperclassName
		category: aCategory
		instVarNames: anInstanceVariableNames
		classInstVarNames: aClassInstanceVariableNames
		comment: aComment
!! !!

CypressDefinition subclass: #CypressMethodDefinition
	instanceVariableNames: ''classIsMeta source category selector className''
	package: ''Cypress-Definitions''!!

!!CypressMethodDefinition methodsFor: ''not yet classified''!!

className: aName classIsMeta: isMetaclass selector: aSelector category: aCategory source: aSource

	className := aName.
	classIsMeta := isMetaclass.
	selector := aSelector.
	category := aCategory.
	source := aSource.
!!

= aDefinition
    ^ super = aDefinition
        and: [ aDefinition source = self source
                and: [ aDefinition category = self category ] ]
!!

source

	^source
!!

category

	^category
!!

description
	^ Array	
		with: className
		with: selector
		with: classIsMeta
!! !!

!!CypressMethodDefinition class methodsFor: ''not yet classified''!!

className: aName
classIsMeta: isMetaclass
selector: aSelector
category: aCategory
source: aSource

	^(self new)
		className: aName
		classIsMeta: isMetaclass
		selector: aSelector
		category: aCategory
		source: aSource
!! !!

CypressPatchOperation subclass: #CypressAddition
	instanceVariableNames: ''definition''
	package: ''Cypress-Definitions''!!

!!CypressAddition methodsFor: ''not yet classified''!!

definition: aDefinition

	definition := aDefinition
!! !!

!!CypressAddition class methodsFor: ''not yet classified''!!

of: aDefinition
	^ self new definition: aDefinition
!! !!

CypressPatchOperation subclass: #CypressModification
	instanceVariableNames: ''obsoletion modification''
	package: ''Cypress-Definitions''!!

!!CypressModification methodsFor: ''not yet classified''!!

base: base target: target

	obsoletion := base.
	modification := target.
!! !!

!!CypressModification class methodsFor: ''not yet classified''!!

of: base to: target
	^ self new base: base target: target
!! !!

CypressPatchOperation subclass: #CypressRemoval
	instanceVariableNames: ''definition''
	package: ''Cypress-Definitions''!!

!!CypressRemoval methodsFor: ''not yet classified''!!

definition: aDefinition

	definition := aDefinition
!! !!

!!CypressRemoval class methodsFor: ''not yet classified''!!

of: aDefinition
	^ self new definition: aDefinition
!! !!

!!Object methodsFor: ''*Cypress-Definitions''!!

species

	^self class
!! !!

!!Class methodsFor: ''*Cypress-Definitions''!!

asCypressClassDefinition
	^CypressClassDefinition
		name: self name
		superclassName: self superclass name
		category: self category 
		instVarNames: self instanceVariableNames
		classInstVarNames: self class instanceVariableNames
		comment: self comment
!! !!

!!CompiledMethod methodsFor: ''*Cypress-Definitions''!!

asCypressMethodDefinition

	^CypressMethodDefinition 
        	className: self methodClass name
		classIsMeta: self methodClass isMetaclass
		selector: self selector
		category: self category
		source: self source
!! !!

!!CharacterArray methodsFor: ''*Cypress-Definitions''!!

sameAs: aString

	^self asUppercase = aString asUppercase
!! !!

'
! !

!ImporterTest methodsFor: 'running'!

setUp

	super setUp.
	self cleanUp
!

tearDown

	super tearDown.
	self cleanUp
!

cleanUp

	(Object methodDictionary includesKey: #importerTestMethod)
		ifTrue: [ Object removeCompiledMethod: (Object methodAt: #importerTestMethod)].
! !

!ImporterTest methodsFor: 'tests'!

testBigChunkString
	"importer does not correctly add extension methods.

	 After loading in AmberProjectImporter, the following import fails...get a MNU from `CypressPackage new species`:

    		AmberProjectImporter
			importSTPackage: 'Cypress-Definitions' 
			prefix: 'tests/'.

		CypressPackage new species. 

	WARNING this guy isn't cleaned up automatically"

	Importer new import: self bigChunkString readStream.
	CypressPackage new species.
!

testChunkString

	Importer new import: self chunkString readStream.
	self assert: (Object methodDictionary includesKey: 'importerTestMethod').
	self assert: (Object new importerTestMethod = 'success').
! !

!Object methodsFor: '*Compiler-Tests'!

importerLoadMethod

	^'success'
! !