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

ApplicationModel subclass:#TestTester
	instanceVariableNames:'currentSource testCaseClassListApp testCaseMethodListApp
		testeeClassListApp testeeMethodListApp selectedTesteeClasses
		selectedTesteeMethods selectedTestCaseClasses
		selectedTestCaseMethods testeeMethodListHolder
		testCaseSourceHolder mutatedMethodSourceHolder
		originalMethodSourceHolder testCaseClassGeneratorHolder
		selectedTesteeMethod selectedTestCaseClass infoLabelHolder
		diffTextView numberOfTriedMutations maxTestExecutionTime'
	classVariableNames:''
	poolDictionaries:''
	category:'SUnit-UI'
!

Object subclass:#Mutator
	instanceVariableNames:'blockToCall treeTop'
	classVariableNames:''
	poolDictionaries:''
	privateIn:TestTester
!

Error subclass:#TestSuiteIncompleteError
	instanceVariableNames:''
	classVariableNames:''
	poolDictionaries:''
	privateIn:TestTester
!

Error subclass:#TimeoutError
	instanceVariableNames:''
	classVariableNames:''
	poolDictionaries:''
	privateIn:TestTester
!


!TestTester class methodsFor:'interface specs'!

windowSpec
    "This resource specification was automatically generated
     by the UIPainter of ST/X."

    "Do not manually edit this!! If it is corrupted,
     the UIPainter may not be able to read the specification."

    "
     UIPainter new openOnClass:TestTester andSelector:#windowSpec
     TestTester new openInterface:#windowSpec
     TestTester open
    "

    <resource: #canvas>

    ^ 
     #(FullSpec
        name: windowSpec
        window: 
       (WindowSpec
          label: 'TestTester'
          name: 'TestTester'
          min: (Point 10 10)
          max: (Point 1024 768)
          bounds: (Rectangle 0 0 554 504)
          menu: mainMenu
        )
        component: 
       (SpecCollection
          collection: (
           (MenuPanelSpec
              name: 'ToolBar1'
              layout: (LayoutFrame 0 0.0 0 0 0 1.0 36 0)
              menu: toolbarMenu
              textDefault: true
            )
           (ViewSpec
              name: 'Box4'
              layout: (LayoutFrame 0 0 36 0 0 1 -26 1)
              component: 
             (SpecCollection
                collection: (
                 (ViewSpec
                    name: 'TestedMethodSelectionBox'
                    layout: (LayoutFrame 0 0 0 0 0 0.4 0 0.5)
                    component: 
                   (SpecCollection
                      collection: (
                       (LabelSpec
                          label: 'Tested Method'
                          name: 'Label4'
                          layout: (LayoutFrame 0 0.0 0 0 0 1.0 22 0)
                          translateLabel: true
                        )
                       (SubCanvasSpec
                          name: 'TestedMethodClassList'
                          layout: (LayoutFrame 0 0 22 0 0 0.5 0 1)
                          hasHorizontalScrollBar: false
                          hasVerticalScrollBar: false
                          majorKey: #'Tools::ClassList'
                          subAspectHolders: 
                         (Array
                            
                           (SubChannelInfoSpec
                              subAspect: selectedClasses
                              aspect: selectedTesteeClasses
                            )
                          )
                          createNewApplication: true
                          createNewBuilder: true
                          postBuildCallback: postBuildTestedClassList:
                        )
                       (SubCanvasSpec
                          name: 'TestedMethodMethodList'
                          layout: (LayoutFrame 0 0.5 22 0 0 1 0 1)
                          hasHorizontalScrollBar: false
                          hasVerticalScrollBar: false
                          majorKey: #'Tools::MethodList'
                          subAspectHolders: 
                         (Array
                            
                           (SubChannelInfoSpec
                              subAspect: inGeneratorHolder
                              aspect: testeeMethodListHolder
                            ) 
                           (SubChannelInfoSpec
                              subAspect: selectedMethods
                              aspect: selectedTesteeMethods
                            )
                          )
                          createNewApplication: true
                          createNewBuilder: true
                          postBuildCallback: postBuildTestedMethodList:
                        )
                       )
                     
                    )
                  )
                 (LabelSpec
                    label: 'Original'
                    name: 'Label5'
                    layout: (LayoutFrame 0 0.4 0 0 0 0.7 22 0)
                    translateLabel: true
                  )
                 (TextEditorSpec
                    name: 'OriginalMethodEditor'
                    layout: (LayoutFrame 0 0.4 22 0 0 0.7 0 0.5)
                    model: originalMethodSourceHolder
                    hasHorizontalScrollBar: true
                    hasVerticalScrollBar: true
                    hasKeyboardFocusInitially: false
                  )
                 (LabelSpec
                    label: 'Mutation'
                    name: 'Label6'
                    layout: (LayoutFrame 0 0.7 0 0 0 1 22 0)
                    translateLabel: true
                  )
                 (TextEditorSpec
                    name: 'MutatedMethodEditor'
                    layout: (LayoutFrame 0 0.7 22 0 0 1 0 0.5)
                    model: mutatedMethodSourceHolder
                    hasHorizontalScrollBar: true
                    hasVerticalScrollBar: true
                    hasKeyboardFocusInitially: false
                  )
                 (ViewSpec
                    name: 'TestSuiteSelectionBox'
                    layout: (LayoutFrame 0 0 0 0.5 0 0.4 0 1)
                    component: 
                   (SpecCollection
                      collection: (
                       (LabelSpec
                          label: 'TestCase'
                          name: 'Label3'
                          layout: (LayoutFrame 0 0.0 0 0 0 1.0 22 0)
                          translateLabel: true
                        )
                       (SubCanvasSpec
                          name: 'TestCaseClassList'
                          layout: (LayoutFrame 0 0 22 0 0 1 0 1)
                          hasHorizontalScrollBar: false
                          hasVerticalScrollBar: false
                          majorKey: #'Tools::ClassList'
                          subAspectHolders: 
                         (Array
                            
                           (SubChannelInfoSpec
                              subAspect: inGeneratorHolder
                              aspect: testCaseClassGeneratorHolder
                            ) 
                           (SubChannelInfoSpec
                              subAspect: selectedClasses
                              aspect: selectedTestCaseClasses
                            )
                          )
                          createNewApplication: true
                          createNewBuilder: true
                          postBuildCallback: postBuildTestCaseClassList:
                        )
                       )
                     
                    )
                  )
                 (LabelSpec
                    name: 'Label7'
                    layout: (LayoutFrame 0 0.5 0 0.5 0 1 22 0.5)
                    translateLabel: true
                  )
                 (TextEditorSpec
                    name: 'TextCaseEditor1'
                    layout: (LayoutFrame 0 0.4 22 0.5 0 1 0 1)
                    model: testCaseSourceHolder
                    hasHorizontalScrollBar: true
                    hasVerticalScrollBar: true
                    hasKeyboardFocusInitially: false
                  )
                 (ArbitraryComponentSpec
                    name: 'ArbitraryComponent1'
                    layout: (LayoutFrame 0 0.4 0 0 0 1 0 0.5)
                    hasHorizontalScrollBar: true
                    hasVerticalScrollBar: true
                    miniScrollerHorizontal: true
                    component: DiffTextView
                    postBuildCallback: postBuildDiffTextView:
                  )
                 )
               
              )
            )
           (ViewSpec
              name: 'Box2'
              layout: (LayoutFrame 0 0 -26 1 0 1 0 1)
              level: 1
              component: 
             (SpecCollection
                collection: (
                 (LabelSpec
                    label: 'InfoLabel'
                    name: 'Label2'
                    layout: (LayoutFrame 0 0 -26 1 -1 1 0 1)
                    level: -1
                    translateLabel: true
                    labelChannel: infoLabelHolder
                    adjust: left
                  )
                 )
               
              )
            )
           )
         
        )
      )
! !

!TestTester class methodsFor:'menu specs'!

mainMenu
    "This resource specification was automatically generated
     by the MenuEditor of ST/X."

    "Do not manually edit this!! If it is corrupted,
     the MenuEditor may not be able to read the specification."

    "
     MenuEditor new openOnClass:TestTester andSelector:#mainMenu
     (Menu new fromLiteralArrayEncoding:(TestTester mainMenu)) startUp
    "

    <resource: #menu>

    ^ 
     #(Menu
        (
         (MenuItem
            label: 'File'
            translateLabel: true
            submenu: 
           (Menu
              (
               (MenuItem
                  label: 'Exit'
                  itemValue: closeRequest
                  translateLabel: true
                )
               )
              nil
              nil
            )
          )
         (MenuItem
            label: 'Help'
            translateLabel: true
            startGroup: right
            submenu: 
           (Menu
              (
               (MenuItem
                  label: 'Documentation'
                  itemValue: openDocumentation
                  translateLabel: true
                )
               (MenuItem
                  label: '-'
                )
               (MenuItem
                  label: 'About this Application...'
                  itemValue: openAboutThisApplication
                  translateLabel: true
                )
               )
              nil
              nil
            )
          )
         )
        nil
        nil
      )
!

toolbarMenu
    "This resource specification was automatically generated
     by the MenuEditor of ST/X."

    "Do not manually edit this!! If it is corrupted,
     the MenuEditor may not be able to read the specification."

    "
     MenuEditor new openOnClass:TestTester andSelector:#toolbarMenu
     (Menu new fromLiteralArrayEncoding:(TestTester toolbarMenu)) startUp
    "

    <resource: #menu>

    ^ 
     #(Menu
        (
         (MenuItem
            label: 'RunCheck'
            itemValue: menuRunCheck
            translateLabel: true
            isButton: true
            labelImage: (ResourceRetriever ToolbarIconLibrary make22x22Icon)
          )
         )
        nil
        nil
      )
! !

!TestTester methodsFor:'aspects'!

infoLabelHolder
    infoLabelHolder isNil ifTrue:[
        infoLabelHolder := ValueHolder new.
    ].
    ^ infoLabelHolder

    "Created: / 25-04-2010 / 21:01:00 / cg"
!

mutatedMethodSourceHolder
    mutatedMethodSourceHolder isNil ifTrue:[
        mutatedMethodSourceHolder := ValueHolder new.
    ].
    ^ mutatedMethodSourceHolder

    "Created: / 25-04-2010 / 15:53:44 / cg"
!

originalMethodSourceHolder
    originalMethodSourceHolder isNil ifTrue:[
        originalMethodSourceHolder := ValueHolder new.
    ].
    ^ originalMethodSourceHolder

    "Created: / 25-04-2010 / 15:53:58 / cg"
!

selectedTestCaseClasses
    selectedTestCaseClasses isNil ifTrue:[
        selectedTestCaseClasses := ValueHolder new.
        selectedTestCaseClasses onChangeSend:#selectedTestCaseClassesChanged to:self.
    ].
    ^ selectedTestCaseClasses

    "Created: / 25-04-2010 / 16:23:56 / cg"
!

selectedTesteeClasses
    selectedTesteeClasses isNil ifTrue:[
        selectedTesteeClasses := ValueHolder new.
        selectedTesteeClasses onChangeSend:#selectedTesteeClassesChanged to:self.
    ].
    ^ selectedTesteeClasses

    "Created: / 25-04-2010 / 14:00:14 / cg"
!

selectedTesteeMethods
    selectedTesteeMethods isNil ifTrue:[
        selectedTesteeMethods := ValueHolder new.
        selectedTesteeMethods onChangeSend:#selectedTesteeMethodsChanged to:self.
    ].
    ^ selectedTesteeMethods

    "Created: / 25-04-2010 / 15:50:10 / cg"
!

testCaseClassGeneratorHolder
    testCaseClassGeneratorHolder isNil ifTrue:[
        testCaseClassGeneratorHolder := ValueHolder new.
    ].
    ^ testCaseClassGeneratorHolder

    "Created: / 25-04-2010 / 16:01:28 / cg"
!

testCaseSourceHolder
    testCaseSourceHolder isNil ifTrue:[
        testCaseSourceHolder := ValueHolder new.
    ].
    ^ testCaseSourceHolder

    "Created: / 25-04-2010 / 15:53:07 / cg"
!

testeeMethodListHolder
    testeeMethodListHolder isNil ifTrue:[
        testeeMethodListHolder := ValueHolder new.
    ].
    ^ testeeMethodListHolder

    "Created: / 25-04-2010 / 14:05:25 / cg"
! !

!TestTester methodsFor:'initialization'!

postBuildDiffTextView:aView
    diffTextView := aView

    "Created: / 26-04-2010 / 10:36:42 / cg"
!

postBuildTestCaseClassList:aSubCanvas
    |classGenerator|

    classGenerator := 
        Iterator 
            on:[:whatToDo |
                TestCase allSubclasses 
                    select:[:cls | cls isAbstract not]
                    thenDo:[:cls |
                        whatToDo
                            value:cls
                    ].
            ].

    self testCaseClassGeneratorHolder value:classGenerator

    "Modified: / 25-04-2010 / 16:04:44 / cg"
!

postBuildTestCaseMethodList:aSubCanvas
    testCaseMethodListApp := aSubCanvas

    "Created: / 25-04-2010 / 13:51:42 / cg"
!

postBuildTestedClassList:aSubCanvas
    testeeClassListApp := aSubCanvas

    "Modified: / 25-04-2010 / 13:50:41 / cg"
!

postBuildTestedMethodList:aSubCanvas
    testeeMethodListApp := aSubCanvas

    "Created: / 25-04-2010 / 13:50:58 / cg"
!

postBuildWith:aBuilder
    "/ testCaseClassListApp inGeneratorHolder:[ Smalltalk allClasses ]

    "Created: / 25-04-2010 / 13:47:59 / cg"
! !

!TestTester methodsFor:'menu actions'!

menuRunCheck
    selectedTestCaseClass isNil ifTrue:[
        Dialog information:'No TestCase class selected'.
        ^ self.
    ].

    (AbortOperationRequest , TestSuiteIncompleteError) handle:[:ex |
        ex signal == TestSuiteIncompleteError ifTrue:[
            self mutatedMethodSourceHolder value:ex parameter.
        ].
        self infoLabelHolder value:ex errorString.
    ] do:[
        self withWaitCursorDo:[
            self infoLabelHolder value:'Running Suite...'.
            self 
                testMethod:(selectedTesteeMethod)
                usingTest:selectedTestCaseClass.
            self infoLabelHolder value:nil.
        ].
        self mutatedMethodSourceHolder value:nil.
    ].
    self updateDiffTextView.

    "Modified: / 27-04-2010 / 09:46:09 / cg"
!

openAboutThisApplication
    "This method was generated by the Browser/CodeGeneratorTool.
     It will be invoked when the menu-item 'help-about' is selected."

    "/ could open a customized aboutBox here ...
    super openAboutThisApplication
!

openDocumentation
    "This method was generated by the Browser/CodeGeneratorTool.
     It will be invoked when the menu-item 'help-documentation' is selected."

    "/ change below as required ...

    "/ to open an HTML viewer on some document (under 'doc/online/<language>/' ):
    self openDocumentationFile:'TOP.html'.

    "/ add application-specific help files under the 'doc/online/<language>/help/appName'
    "/ directory, and open a viewer with:
    "/ self openDocumentationFile:'help/<MyApplication>/TOP.html'.
! !

!TestTester methodsFor:'misc'!

showAllClassesInNameSpaceOrganisation
    ^ true

    "Created: / 25-04-2010 / 13:56:24 / cg"
! !

!TestTester methodsFor:'testing methods'!

testMethod:aMethod using:selector fromTest:aTestCaseClass
    "motivation:
        assuming that aTestCase is a good test for aMethod,
        any change in aMethod should be rewarded by a failing testRun."

    ^ self
        testMethod:aMethod 
        usingTest:aTestCaseClass 
        selectors:(aTestCaseClass testSelectors)

    "Modified: / 24-04-2010 / 14:03:57 / cg"
!

testMethod:aMethod usingSuite:aTestSuite 
    |tree newSource methodClass methodSelector|

    numberOfTriedMutations := 0.
    maxTestExecutionTime := nil.

    methodClass := aMethod mclass.
    methodSelector := aMethod selector.

    self mutatedMethodSourceHolder value:nil.

    AssertionFailedError handle:[:ex |
        TestSuiteIncompleteError
            raiseWith:aMethod source
            errorString:'Test failed for original'.
    ] do:[
        self infoLabelHolder value:'Running Suite on original code...'.
        self runSuiteExpectingSuccess:aTestSuite.
    ].
    tree := RBParser parseMethod:(aMethod source) onError:[:str :pos | nil ].
    tree isNil ifTrue:[
        self error:'cannot parse method'.
    ].
    tree source:nil.

    "/ just to make sure: check if compiled method behaves the same
    newSource := tree formattedCode.
    self withCode:newSource installedAs:methodSelector inClass:methodClass do:[:newMethod |
        AssertionFailedError handle:[:ex |
            TestSuiteIncompleteError
                raiseWith:aMethod source
                errorString:'Test failed for original'.
        ] do:[
            self infoLabelHolder value:'Running Suite on original code again...'.
            self runSuiteExpectingSuccess:aTestSuite.
        ]
    ].

    self originalMethodSourceHolder value:newSource.
    self mutatedMethodSourceHolder value:newSource.
    self updateDiffTextView.

    "/ start to fiddle with the code; the tests MUST detect each !!
    self mutationsOf:tree do:[:modifiedTree |
        newSource := modifiedTree formattedCode.
        self mutatedMethodSourceHolder value:newSource.
        self updateDiffTextView.

        self withCode:newSource installedAs:methodSelector inClass:methodClass do:[:newMethod |
            AssertionFailedError handle:[:ex |
                TestSuiteIncompleteError 
                    raiseWith:newSource
                    errorString:ex errorString.
            ] do:[
                numberOfTriedMutations := numberOfTriedMutations + 1.
                self infoLabelHolder value:('Running Suite on mutation %1...' bindWith:numberOfTriedMutations).
                self runSuiteExpectingFailure:aTestSuite.
            ]
        ].
    ].

    "
     self new
        testMethod:(Integer >> #factorial)
        usingTest:RegressionTests::IntegerTest
        selector:#testFactorial
    "

    "Created: / 24-04-2010 / 14:06:07 / cg"
    "Modified: / 27-04-2010 / 09:41:14 / cg"
!

testMethod:aMethod usingTest:aTestCaseClass
    "motivation:
        assuming that aTestCase is a good test for aMethod,
        any change in aMethod should be rewarded by a failing testRun."

    ^ self
        testMethod:aMethod 
        usingTest:aTestCaseClass 
        selectors:(aTestCaseClass testSelectors)

    "
     self new 
        testMethod:(Integer >> #factorial)
        usingTest:RegressionTests::IntegerTest
    "

    "Created: / 25-04-2010 / 16:29:22 / cg"
!

testMethod:aMethod usingTest:aTestCaseClass selector:selector
    "motivation:
        assuming that aTestCase is a good test for aMethod,
        any change in aMethod should be rewarded by a failing testRun."

    ^ self
        testMethod:aMethod 
        usingTest:aTestCaseClass 
        selectors:(Array with:selector)

    "
     self new 
        testMethod:(Integer >> #factorial)
        usingTest:RegressionTests::IntegerTest
        selector:#testFactorial
    "

    "Created: / 24-04-2010 / 13:59:18 / cg"
!

testMethod:aMethod usingTest:aTestCaseClass selectors:collectionOfSelectors
    "motivation:
        assuming that aTestCase is a good test for aMethod,
        any change in aMethod should be rewarded by a failing testRun."

    |suite|

    suite := TestSuite new.
    collectionOfSelectors do:[:selector |
        suite 
            addTest: (aTestCaseClass selector: selector).
    ].
    ^ self testMethod:aMethod usingSuite:suite

    "
     self new 
        testMethod:(Integer >> #factorial)
        usingTest:RegressionTests::IntegerTest
        selector:#testFactorial
    "

    "Created: / 24-04-2010 / 14:03:09 / cg"
! !

!TestTester methodsFor:'testing-helpers'!

mutationsOf:aTree do:aBlock
    (Mutator new) mutationsOf:aTree do:aBlock
    "/ aTree acceptVisitor:(Mutator forBlock:aBlock).

    "
     self new
        testMethod:(Integer >> #factorial)
        usingTest:RegressionTests::IntegerTest
        selector:#testFactorial
    "

    "Created: / 24-04-2010 / 16:22:51 / cg"
    "Modified: / 24-04-2010 / 18:12:48 / cg"
!

runSuite:aTestSuite 
    |t timedOut result|

    timedOut := false.

    t := Time millisecondsToRun:[
        maxTestExecutionTime isNil ifTrue:[
            result := aTestSuite run.
        ] ifFalse:[
            [
                result := aTestSuite run.
            ] valueWithWatchDog:[ timedOut := true ] afterMilliseconds:(maxTestExecutionTime * 5).
        ].
    ].
    timedOut ifTrue:[ TimeoutError raiseErrorString:'Timeout - code possibly ran into endless loop ?'].
    maxTestExecutionTime := (maxTestExecutionTime ? t) max:t.
    ^ result

    "Created: / 27-04-2010 / 01:37:42 / cg"
    "Modified: / 27-04-2010 / 09:31:56 / cg"
!

runSuiteExpectingFailure:aTestSuite 
    |result|

    TimeoutError handle:[:ex |
        Transcript showCR:ex description.
        ^ self
    ] do:[
        result := self runSuite:aTestSuite.
    ].

    self
        assert:result runCount > 0;
        "/ assert:(result passedCount = 0) message:'test should not have passed';
        assert:((result failureCount + result errorCount) > 0) 
            message:'Some test should have failed'.

    "Created: / 24-04-2010 / 16:17:47 / cg"
    "Modified: / 27-04-2010 / 09:46:27 / cg"
!

runSuiteExpectingSuccess:aTestSuite 
    |result|

    result := self runSuite:aTestSuite.
    result errorCount > 0 ifTrue:[self halt].

    self
        assert:result runCount > 0;
        assert:(result passedCount > 0) message:'All tests should have passed';
        assert:(result failureCount = 0) message:'No test should have failed';
        assert:(result errorCount = 0) message:'No test should have errors'.

    "Modified: / 27-04-2010 / 09:46:40 / cg"
!

withCode:newSource installedAs:selector inClass:aClass do:aBlock
    |oldMethod newMethod|

    oldMethod := aClass compiledMethodAt:selector.
    newMethod := Compiler compile:newSource forClass:aClass install:false.

    [
        "/ install new method
        aClass basicAddSelector:selector withMethod:newMethod.
        aBlock value:newMethod
    ] ensure:[
        "/ restore original method
        aClass basicAddSelector:selector withMethod:oldMethod.
    ].

    "Created: / 24-04-2010 / 16:26:00 / cg"
! !

!TestTester methodsFor:'user actions'!

selectedTestCaseClassesChanged
    selectedTestCaseClass := selectedTestCaseClasses value firstIfEmpty:nil.

    "Created: / 25-04-2010 / 16:25:18 / cg"
!

selectedTesteeClassesChanged
    |methodGenerator|

    methodGenerator := 
        Iterator 
            on:[:whatToDo |
                |methodClass|

                methodClass := self selectedTesteeClasses value first.
                methodClass methodDictionary
                    keysAndValuesDo:[:methodSelector :method |
                        whatToDo
                            value:methodClass
                            value:method category
                            value:methodSelector
                            value:method.
                    ].
            ].

    self testeeMethodListHolder value:methodGenerator

    "Modified: / 25-04-2010 / 15:48:04 / cg"
!

selectedTesteeMethodsChanged
    |methods method source|

    methods := self selectedTesteeMethods value.
    methods notEmpty ifTrue:[
        method := methods first.
        source := method source.
    ].
    selectedTesteeMethod ~~ method ifTrue:[
        (self originalMethodSourceHolder value) ~= source ifTrue:[
            selectedTesteeMethod := method.
"/ self halt.
            self originalMethodSourceHolder value:source.
            self mutatedMethodSourceHolder value:nil.

            self updateDiffTextView.
        ].
    ].

    "Created: / 25-04-2010 / 15:51:03 / cg"
    "Modified: / 27-04-2010 / 09:54:19 / cg"
!

updateDiffTextView
    diffTextView 
        text1:(self originalMethodSourceHolder value ? '')
        text2:(self mutatedMethodSourceHolder value ? '').
    self windowGroup repairDamage.

    "Created: / 26-04-2010 / 10:38:39 / cg"
    "Modified: / 26-04-2010 / 12:19:26 / cg"
! !

!TestTester::Mutator class methodsFor:'instance creation'!

forBlock:aBlock
    ^ self new blockToCall:aBlock

    "Created: / 24-04-2010 / 16:55:24 / cg"
! !

!TestTester::Mutator methodsFor:'accessing'!

blockToCall:something
    blockToCall := something.
! !

!TestTester::Mutator methodsFor:'mutating'!

mutationsOf:aTree do:aBlock
    blockToCall := aBlock.
    treeTop := aTree.
    aTree acceptVisitor:self.

    "Created: / 24-04-2010 / 17:12:19 / cg"
    "Modified: / 24-04-2010 / 19:02:24 / cg"
! !

!TestTester::Mutator methodsFor:'visiting'!

acceptAssignmentNode:anAssignmentNode
    |oldExpr|

    oldExpr := anAssignmentNode value.
    [
        (self class new) mutationsOf:oldExpr do:[:newExpr |
            anAssignmentNode value:newExpr.
            blockToCall value:treeTop.
        ].
    ] ensure:[
        anAssignmentNode value:oldExpr
    ].

    "Created: / 27-04-2010 / 00:32:14 / cg"
!

acceptBlockNode:aBlockNode
    self acceptMethodOrBlockNode:aBlockNode

    "Modified: / 24-04-2010 / 19:06:49 / cg"
!

acceptLiteralNode:aLiteralNode
    |oldValue|

    oldValue := aLiteralNode value.
    oldValue isInteger ifTrue:[
        [
            Transcript showCR:('Replacing value %1 with: %2' bindWith:oldValue with:oldValue+1).
            aLiteralNode token value:oldValue + 1.
            blockToCall value:treeTop.
            Transcript showCR:('Replacing value %1 with: %2' bindWith:oldValue with:oldValue-1).
            aLiteralNode token value:oldValue - 1.
            blockToCall value:treeTop.
            ((oldValue ~= 1) and:[oldValue ~= -1 and:[oldValue ~= 0]]) ifTrue:[
                Transcript showCR:('Replacing value %1 with: %2' bindWith:oldValue with:0).
                aLiteralNode token value:0.
                blockToCall value:treeTop.                
            ].
        ] ensure:[
            aLiteralNode token value:oldValue.
        ].
        ^ self.
    ].
    oldValue isFloat ifTrue:[
        self halt.
        ^ self.
    ].
    oldValue isSymbol ifTrue:[
        ^ self.
    ].
    oldValue isString ifTrue:[
        ^ self.
    ].
    oldValue isArray ifTrue:[
        ^ self.
    ].
    oldValue isByteArray ifTrue:[
        self halt.
        ^ self.
    ].
self halt.

    "Created: / 25-04-2010 / 21:32:12 / cg"
    "Modified: / 27-04-2010 / 09:45:18 / cg"
!

acceptMessageNode:aMessageNode
    |selector arguments|

    selector := aMessageNode selector.

    ( #( ifTrue: ifFalse: ifTrue:ifFalse: ifFalse:ifTrue:) includes:selector) ifTrue:[
        self tryWithNegatedCondition:aMessageNode.
    ].

    arguments := aMessageNode arguments.
    1 to:arguments size do:[:idx |
        |oldArg|

        oldArg := arguments at:idx.
        [
            (self class new) mutationsOf:oldArg do:[:newArg |
                arguments at:idx put:newArg.
                blockToCall value:treeTop.
            ].
        ] ensure:[
            arguments at:idx put:oldArg
        ].
    ].

    "Modified: / 24-04-2010 / 19:07:22 / cg"
!

acceptMethodNode:aMethodNode
    self acceptMethodOrBlockNode:aMethodNode

    "Modified: / 24-04-2010 / 19:06:44 / cg"
!

acceptMethodOrBlockNode:aMethodOrBlockNode
    |oldBody|

    oldBody := aMethodOrBlockNode body.
    oldBody notNil ifTrue:[
        [
            (self class new) mutationsOf:oldBody do:[:newBody |
                aMethodOrBlockNode body:newBody.
                blockToCall value:treeTop.
            ].
        ] ensure:[
            aMethodOrBlockNode body:oldBody
        ].
    ].

    "Created: / 24-04-2010 / 19:06:33 / cg"
!

acceptReturnNode:aReturnNode
    |oldExpr|

    oldExpr := aReturnNode value.
    [
        (self class new) mutationsOf:oldExpr do:[:newExpr |
            aReturnNode value:newExpr.
            blockToCall value:treeTop.
        ].
    ] ensure:[
        aReturnNode value:oldExpr
    ].

    "Modified: / 25-04-2010 / 21:30:13 / cg"
!

acceptSequenceNode:aSequenceNode
    |statements|

    statements := aSequenceNode statements.

    1 to:statements size do:[:idx |
        |oldStat|

        oldStat := statements at:idx.
        [
            (self class new) mutationsOf:oldStat do:[:newStat |
                statements at:idx put:newStat.
                blockToCall value:treeTop.
            ].
        ] ensure:[
            statements at:idx put:oldStat
        ].
    ].
"/    |oldBody|
"/
"/    oldBody := aMethodNode body.
"/    oldBody notNil ifTrue:[
"/        [
"/            (self class new) mutationsOf:oldBody do:[:newBody |
"/self halt.
"/            ].
"/        ] ensure:[
"/            aMethodNode body:oldBody
"/        ].
"/    ].
"/
"/    "Created: / 24-04-2010 / 16:56:12 / cg"
"/

    "Created: / 24-04-2010 / 18:23:35 / cg"
!

acceptVariableNode:aVariableNode

    "Created: / 25-04-2010 / 21:35:26 / cg"
!

tryWithNegatedCondition:aMessageNode
    |sel repl|

    sel := aMessageNode selector.
    repl := (Dictionary new 
                at: #ifTrue: put: #ifFalse: ;
                at: #ifFalse: put: #ifTrue: ;
                at: #ifTrue:ifFalse: put: #ifFalse:ifTrue: ;
                at: #ifFalse:ifTrue: put: #ifTrue:ifFalse: ;
                yourself)
                    at:sel.

    [
        aMessageNode selector:repl.
        blockToCall value:treeTop.
    ] ensure:[
        aMessageNode selector:sel.
    ].

    "Modified: / 24-04-2010 / 19:03:44 / cg"
! !

!TestTester class methodsFor:'documentation'!

version_CVS
    ^ '$Header: /cvs/stx/stx/goodies/sunit/TestTester.st,v 1.4 2010-04-27 08:48:09 cg Exp $'
! !