Source

newspeak / MirrorTesting.ns3

Newspeak3
'Mirrors-tests'
class MirrorTesting usingPlatform: platform  <Platform> mirrorLib:  m <NewspeakMirrors> testFramework: utf <Minitest> = (|
      "imports"
	private ClassDeclarationMirror = m ClassDeclarationMirror.
	private ClassDeclarationBuilder = m ClassDeclarationBuilder.
	private ClassMirror = m ClassMirror.
	private MixinMirror = m MixinMirror.
	private MessageNotUnderstood = platform blackMarket Exceptions MessageNotUnderstood.

	private TestContext = utf TestContext.

      private Smalltalk = platform blackMarket Smalltalk.

	
	"Module variables"
	private mirrorLib = m.
	|)
(
class ClassDeclarationBuilderTests = TestContext ()
('as yet unclassified'
testClassDeclAddMethod = (
	"add a new method"
	| 
	klass <Class> 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	|
	testBuilder:: ClassDeclarationBuilder reflecting: newClass mixin.
	testBuilder instanceSide methods addFromSource: 'foo: x = (^x * x)'.
	testMirror:: testBuilder install.
	klass:: testMirror reflectee apply: Object.
      assert: [(klass new foo: 3) = 9]. 
)
testClassDeclAddNestedClass = (
	"add a new nested class decl"
	| 
	klass <Class> 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	|
	testBuilder:: ClassDeclarationBuilder reflecting: newClass mixin.
	testBuilder instanceSide nestedClasses addFromSource: 'class Nested = ()(''cat'' foo = (^91))'.
	testMirror:: testBuilder install.
	klass:: testMirror reflectee apply: Object.
	assert: [klass new Nested new foo = 91].
)
testClassDeclChangeHeader = (
	"add a new slot"
	| 
	klass <Class> 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	instance <Object>
	|
	testBuilder:: ClassDeclarationBuilder reflecting: newClass mixin.
	testBuilder headerFromSource: 'EmptyClass = ( | newSlot ::= 91. | )'.
	testMirror:: testBuilder install.
	klass:: testMirror reflectee apply: Object.
	instance:: klass new.
	assert: [instance newSlot = 91].
	instance newSlot: 101.
	assert: [instance newSlot = 101].	
)
testClassDeclModifySlot = (
	"modify the declaration of an existing slot"
	| 
	klass <Class> 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	instance <Object>
	|
	klass:: classFromSource: 'class TestClassDeclModifySlot = ( | x ::= 117.  y = 0. z  | )()'.
	testBuilder:: ClassDeclarationBuilder reflecting: klass mixin.
	testBuilder headerFromSource: 'TestClassDeclModifySlot = ( | x ::= 120. y = 0.  z | )'.
	testMirror:: testBuilder install.
	assert:[testMirror instanceSide slots includesMirrorNamed: #x].
	assert:[testMirror instanceSide slots includesMirrorNamed: #y].
	assert:[testMirror instanceSide slots includesMirrorNamed: #z].
	instance:: klass new.
	assert: [instance x = 120].
	instance x: 101.
	assert: [instance x = 101].	
)
testClassDeclRemoveMethod = (
	"remove an existing method"
	| 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	myKlass <Class>
	|	
	myKlass:: classFromSource: 'class TestClassDeclRemoveMethod = ()(
		''unclassified''
		foo = (^91)
	      bar = (^42)
	)'.
	testBuilder::  ClassDeclarationBuilder reflecting: myKlass mixin. 
	testBuilder instanceSide methods removeMirrorNamed: 'foo'.
	testMirror:: testBuilder install.
	deny:[testMirror instanceSide methods includesMirrorNamed: #foo].
)
testClassDeclRemoveNestedClass = (
	"remove an existing nested class"
| builder <ClassMirrorBuilder>  outerClass <Class> |
	
	outerClass:: classFromSource: 'class TestClassDeclRemoveNestedClass = ()(
		class Nested = ()()
	)'.
	builder:: ClassDeclarationBuilder reflecting: outerClass mixin. 
	builder instanceSide nestedClasses removeMirrorNamed: #Nested.
	builder install. "remove"
	assert:[[outerClass new Nested. false] on: MessageNotUnderstood do:[true]].
	assert:[
		((ClassDeclarationMirror reflecting: outerClass mixin) instanceSide nestedClasses 
			findMirrorNamed: #Nested) = nil
		]."verify"
)
testClassDeclRemoveNonExistantMethod = (
	"remove a non-existing method. The effect should be to do nothing, so our only goal here is to run without error"
	| 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	myKlass <Class>
	|	
	myKlass:: classFromSource: 'class TestClassDeclRemoveMethod = ()(
		''unclassified''
		foo = (^91)
	      bar = (^42)
	)'.
	testBuilder::  ClassDeclarationBuilder reflecting: myKlass mixin. 
	testBuilder instanceSide methods removeMirrorNamed: 'baz'.
)
testClassDeclRemoveNonExistantNestedClass = (
	"remove a non-existing nested class. The effect should be to do nothing, so our only goal here is to run without error"
| builder <ClassMirrorBuilder>  outerClass <Class> |
	
	outerClass:: classFromSource: 'class TestClassDeclRemoveNonExistantNestedClass = ()()'.
	builder::  ClassDeclarationBuilder reflecting: outerClass mixin. 
	builder instanceSide nestedClasses removeMirrorNamed: #Nested.
)
testClassDeclRemoveSlot = (
	"remove an existing slot"
	| 
	klass <Class> 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	instance <Object>
	|
	klass:: classFromSource: 'class TestClassDeclRemoveSlot = ( | x ::= 117.  y = 0. z  | )()'.
	testBuilder:: ClassDeclarationBuilder reflecting: klass mixin.
	testBuilder headerFromSource: 'TestClassDeclRemoveSlot = ( | x ::= 117. y = 0.  | )'.
	testMirror:: testBuilder install.
	deny:[testMirror instanceSide slots includesMirrorNamed: #z].
	assert:[testMirror instanceSide slots includesMirrorNamed: #y].
	assert:[testMirror instanceSide slots includesMirrorNamed: #x].
)
testClassDeclReplaceMethod = (
	"replace an existing method"
	| 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	myKlass <Class>
	|	
	myKlass:: classFromSource: 'class TestClassDeclReplaceMethod = ()(
		''unclassified''
		foo = (^91)
	      bar = (^42)
	)'.
	testBuilder::  ClassDeclarationBuilder reflecting: myKlass mixin. 
	testBuilder instanceSide methods addFromSource: 'foo = (^254 + 1)'.
	testMirror:: testBuilder install.
	assert:[myKlass new foo = 255].
)
testClassDeclReplaceNestedClass = (
	"replace an existing nested class"
| builder <ClassMirrorBuilder>  outerClass <Class> nestedKlass <Class> instance <OuterClass> nestedInstance <OuterClass Nested> |
	
	outerClass:: classFromSource: 'class TestClassDeclReplaceNestedClass = ()(
		class Nested = ()()
	
	)'.
	instance:: outerClass new.
	nestedKlass:: instance Nested.
	nestedInstance:: nestedKlass new.
	builder::  ClassDeclarationBuilder reflecting: outerClass mixin. 
	builder instanceSide nestedClasses addFromSource: 'class Nested = (|a = 0.  b ::= 1. c|)(''cat'' foo = (^27))'.
	builder install. "replace"
	
	assert:[instance Nested new a = 0].
	assert:[instance Nested new b = 1].
	assert:[instance Nested new c isNil].
	assert:[instance Nested new foo = 27].
		
	assert:[nestedKlass new a = 0].
	assert:[nestedKlass new b = 1].
	assert:[nestedKlass new c isNil].
	assert:[nestedKlass new foo = 27].
	
	assert:[nestedInstance a isNil].
	assert:[nestedInstance b isNil].
	assert:[nestedInstance c isNil].
	assert:[nestedInstance foo = 27].
	
	assert:[nestedKlass = instance Nested].
	assert:[nestedInstance class = nestedKlass].

	assert:[outerClass new Nested new a = 0].
	assert:[outerClass new Nested new b = 1].
	assert:[outerClass new Nested new c isNil].
	assert:[outerClass new Nested new foo = 27].
)
testClassDeclReplaceSlot = (
	"replace an existing slot"
	| 
	klass <Class> 
	testBuilder <ClassDeclarationBuilder> 
	testMirror <ClassDeclarationMirror> 
	instance <Object>
	|
	klass:: classFromSource: 'class TestClassDeclReplaceSlot = ( | x ::= 117.  y = 0. z  | )()'.
	testBuilder:: ClassDeclarationBuilder reflecting: klass mixin.
	testBuilder headerFromSource: 'TestClassDeclReplaceSlot = ( | a ::= 120. y = 0.  z | )'.
	testMirror:: testBuilder install.
	deny:[testMirror instanceSide slots includesMirrorNamed: #x].
	assert:[testMirror instanceSide slots includesMirrorNamed: #y].
	assert:[testMirror instanceSide slots includesMirrorNamed: #z].
	assert:[testMirror instanceSide slots includesMirrorNamed: #a].
	instance:: klass new.
	assert: [instance a = 120].
	instance a: 101.
	assert: [instance a = 101].	
)'private'
emptyClassSource ^ <String> = (
	^'class EmptyClass = ()()'
)
newClass ^ <Class> = (
	^(ClassDeclarationBuilder fromSource: emptyClassSource) install reflectee apply: Object
)) : ('test markers'
TEST_CONTEXT = ())
class RuntimeClassTests = (
"Encapsulate test cases that run vis-a-vis a fixed class, klass"|
klass <Class> = makeSampleClass.
|)
(
class ClassMirrorTests = TestContext (| 
	|)
('as yet unclassified'
testMirror = (
	#BOGUS.  "This was a slot but wasn't being initialized.  Problem in Minitest?"
	^ClassMirror reflecting: klass.
)'tests'
testClassMirrorHasInheritedMethods = (
	"See that mirror shows expected inherited methods"
	assert:[testMirror methods includesMirrorNamed: #superMethod].
)
testClassMirrorHasInheritedNestedClasses = (
	"define a class and see that mirror shows expected inherited nested classes"
	assert:[testMirror nestedClasses includesMirrorNamed: #SuperNested1].
	assert:[testMirror nestedClasses includesMirrorNamed: #SuperNestedClass2].
)
testClassMirrorHasInheritedSlots = (
	"define a class and see that mirror shows expected inherited slots"
	assert:[testMirror slots includesMirrorNamed: #anInheritedSlot].
	assert:[testMirror slots includesMirrorNamed: #anotherInheritedSlot].
	assert:[testMirror slots includesMirrorNamed: #andYetAnother].
)
testClassMirrorHasLocalMethods = (
	"define a class and see that mirror shows expected local methods"
	assert:[testMirror methods includesMirrorNamed: #unaryMethod].
	assert:[testMirror methods includesMirrorNamed: #aTernaryMethod:with:and:].
)
testClassMirrorHasLocalNestedClasses = (
	"define a class and see that mirror shows expected local nested classes"
	assert:[testMirror nestedClasses includesMirrorNamed: #Nested1].
	assert:[testMirror nestedClasses includesMirrorNamed: #NestedClass2].
)
testClassMirrorHasLocalSlots = (
	"define a class and see that mirror shows expected local slots"
	assert:[testMirror slots includesMirrorNamed: #aNullSlot].
	assert:[testMirror slots includesMirrorNamed: #anotherNullSlot].
	assert:[testMirror slots includesMirrorNamed: #anImmutableSlot].
	assert:[testMirror slots includesMirrorNamed: #anotherImmutableSlot].
	assert:[testMirror slots includesMirrorNamed: #aMutableSlot].
	assert:[testMirror slots includesMirrorNamed: #andAnother].
)) : ('test markers'
TEST_CONTEXT = ())
class MixinMirrorTests = TestContext (|
	|)
('as yet unclassified'
testMirror = (
	#BOGUS.  "This was a slot but wasn't being initialized.  Problem in Minitest?"
	^MixinMirror reflecting: klass mixin
)'tests'
testMixinMirrorMethods = (
	"See that the mirror shows expected  methods"
	assert:[testMirror methods includesMirrorNamed: #unaryMethod].
	assert:[testMirror methods includesMirrorNamed: #aTernaryMethod:with:and:].
)
testMixinMirrorNestedClasses = (
	"See that mirror shows expected  nested classes"
	assert:[testMirror nestedClasses includesMirrorNamed: #Nested1].
	assert:[testMirror nestedClasses includesMirrorNamed: #NestedClass2].
)
testMixinMirrorSlots = (
	"See that mirror shows expected  slots"
	assert:[testMirror slots includesMirrorNamed: #aNullSlot].
	assert:[testMirror slots includesMirrorNamed: #anotherNullSlot].
	assert:[testMirror slots includesMirrorNamed: #anImmutableSlot].
	assert:[testMirror slots includesMirrorNamed: #anotherImmutableSlot].
	assert:[testMirror slots includesMirrorNamed: #aMutableSlot].
	assert:[testMirror slots includesMirrorNamed: #andAnother].
	
	
	assert:[(testMirror slots findMirrorNamed: #aNullSlot) isMutable].
	assert:[(testMirror slots findMirrorNamed: #anotherNullSlot) isMutable].
	deny:[(testMirror slots findMirrorNamed: #anImmutableSlot) isMutable].
	deny:[(testMirror slots findMirrorNamed: #anotherImmutableSlot) isMutable].
)) : ('test markers'
TEST_CONTEXT = ())'as yet unclassified'
makeSampleClass ^ <Class> = (
	"create a test class"
	| definingKlass <Class> |
	
	definingKlass:: classFromSource: sourceForTestClass.
	^definingKlass mixin apply: superKlass.
)
sourceForSuperClass ^ <String> = (
	^'class SampleSuperClass superFactory: x  = (
	   |
	   anInheritedSlot
	   anotherInheritedSlot andYetAnother
	    |
	   )(
	    class SuperNested1 = ()()
	
	    class SuperNestedClass2 = ()()
	    ''unclassified''
	    superMethod = (^77)
	    )
	'
)
superKlass ^ <Class> = (
	^classFromSource: sourceForSuperClass.
)'private'
sourceForTestClass ^ <String> = (
	^'class SampleClass factory: x = (
	   |
	   aNullSlot
	   aMutableSlot ::= 0.
	   anImmutableSlot = 91.
	   anotherImmutableSlot = 42.
	    anotherNullSlot andAnother
	    |
	   )(
	    class Nested1 = ()()
	
	    class NestedClass2 = ()()
	    ''unclassified''
	    unaryMethod = (^3)
	
	    aTernaryMethod: a with: b and: c = (
	        ^a + b + c
	     )
	    )
	'
)) : ()'as yet unclassified'
classFromSource: src <String> = (

	"produce a top level class from source"
	^(ClassDeclarationBuilder fromSource: src) install reflectee apply: Object
)) : ()