"Testsuite.st: Unit tests for other classes in this directory.
Copyright (C) 2006, 2007  Stephen Compall.

This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or
(at your option) any later version.

This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
GNU General Public License for more details.

You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA"

"Commentary

This is an SUnit test suite for No Candy Backstage's base code.

Quick test script, with NoCandy as current namespace:

{Presrc.Tests.TestMessageMacroExpansion.
 Presrc.Tests.TestCodeMindsetInstall} do: [:testClass | | suite |
    suite := testClass buildSuiteFromSelectors.
    suite tests do: [:test | test logPolicy:
	(TestVerboseLog on: test failureLog)].
    suite run]

TODO major features before (after) special Presource-only release:

* hierarchical macro-dictionary -- DONE
* test for real copy in copyInContext:
* few more tests, including compilation/execution
* manual for using major features
* manual for the RB pattern syntax

TODO New methods to test: installIn:

"

"Code"

Namespace current: NoCandy.Presrc.Tests!

MessageMacro subclass: #SendingBlockMacro
	     instanceVariableNames: ''
	     classVariableNames: ''
	     poolDictionaries: ''
	     category: 'Presource-misc macros'
!

SendingBlockMacro comment:
'I am a unary message-macro that converts a symbol, its receiver, into
a block.  This block sends the symbol to its first argument, passing
the remaining block arguments as message arguments.  The number of
arguments is determined with "symbol numArgs".

Examples:
    #+ asMessagingBlock
	-> [:var1 :var2 | var1 + var2]
    #first asMessagingBlock
	-> [:var1 | var1 first]'
!

MessageMacro subclass: #ValueWithAsMacro
	     instanceVariableNames: ''
	     classVariableNames: ''
	     poolDictionaries: ''
	     category: 'Presource-misc macros'
!

ValueWithAsMacro comment:
'I am a pseudo-message on BlockClosures that temporarily sets its
valueWith: argument, a variable, to its as: argument, an expression,
while executing the receiver, an expression that evaluates to a
BlockClosure.

Examples:
    aBlock valueWith: currentState as: State new
	-> [| var1 |
	    var1 := currentState.
	    [currentState := State new.
	     aBlock value] ensure: [currentState := var1]] value

TODO: Define a "places" construct, so you can have accessors and x at:
i constructs.  Or maybe this won''t work so well without a more
elaborate setf-expansion system, which might be more effort than this
is worth.'
!

"A replacement for 'ValueWithAsMacro new', using PatternMacro."
Namespace current
    at: #PatternValueWithAsMacro
    put: (PatternMacro
	      "we pattern out the selector because we use a different
	       selector in testing.  `stateVar's var-only pattern is
	       also used for testPreorderTraversal, so leave it alone"
	      given: 'address@hidden `valueWith: `stateVar `as: address@hidden'
	      use: '[| `oldValue |
		     `oldValue := `stateVar.
		     [`stateVar := address@hidden
		      address@hidden value] ensure: [`stateVar := `oldValue]] value'
	      withExtraVariables: #('`oldValue'))
!

"An identity macro, for testing expansion order"
Namespace current
    at: #IdentityMacro
    put: (PatternMacro given: 'address@hidden identity'
		       use: 'address@hidden')
!

TestCase subclass: #TestMessageMacroExpansion
	 instanceVariableNames: 'codeMindset'
	 classVariableNames: ''
	 poolDictionaries: ''
	 category: 'Presource-tests'
!

TestMessageMacroExpansion comment:
'I test the message-macro expansion mechanism managed by CodeMindset
in Presource.st.'
!

TestCase subclass: #TestCodeMindsetInstall
	 instanceVariableNames: 'baseCM extensionCM'
	 classVariableNames: ''
	 poolDictionaries: ''
	 category: 'Presource-tests'
!

TestCodeMindsetInstall comment:
'I test CodeMindset environment installation and interdependencies.'
!

!SendingBlockMacro methodsFor: 'tree rewriting'!

expandMessage: selector to: receiver withArguments: arguments
    "Answer expansion-see class comment."
    | receiverGensym argsGensyms messageNode |
    receiverGensym := MessageMacro newVariable: 'receiver'.
    argsGensyms := (1 to: receiver value numArgs)
	collect: [:num | MessageMacro newVariable: 'arg'].
    messageNode := STInST.RBMessageNode
	receiver: receiverGensym
	selector: receiver value
	arguments: argsGensyms.

    ^STInST.RBBlockNode
	arguments: (argsGensyms copyReplaceFrom: 1 to: 0
				withObject: receiverGensym)
	body: (STInST.RBSequenceNode
		   statements: (OrderedCollection with: messageNode))
! !

!ValueWithAsMacro methodsFor: 'tree rewriting'!

expandMessage: selector to: receiver withArguments: arguments
    "Answer expansion-see class comment."
    ^STInST.RBMessageNode
	receiver: (STInST.RBBlockNode
		       body: (self bindingSequenceNodeWith: (arguments at: 1)
				   as: (arguments at: 2)
				   during: receiver))
	selector: #value
!

bindingSequenceNodeWith: place as: newValue during: receiverBlockExp
    "Answer a sequence node that 'binds' place to newValue."
    | oldValueVar ensureReceiver placeReset |
    oldValueVar := MessageMacro newVariable: 'oldValue'.
    ensureReceiver := STInST.RBSequenceNode
	statements: (OrderedCollection
			 with: (STInST.RBAssignmentNode
				    variable: place
				    value: newValue)
			 with: (STInST.RBMessageNode
				    receiver: receiverBlockExp
				    selector: #value)).
    placeReset := STInST.RBSequenceNode
	statements: (OrderedCollection
			 with: (STInST.RBAssignmentNode
				    variable: place
				    value: oldValueVar)).
    ^STInST.RBSequenceNode
	temporaries: (OrderedCollection with: oldValueVar)
	statements:
	    (OrderedCollection
		 with: (STInST.RBAssignmentNode
			    variable: oldValueVar
			    value: place)
		 with: (STInST.RBMessageNode
			    receiver: (STInST.RBBlockNode
					   body: ensureReceiver)
			    selector: #ensure:
			    arguments: (OrderedCollection
					    with: (STInST.RBBlockNode
						       body: placeReset))))
! !

!TestMessageMacroExpansion class methodsFor: 'testing expansion results'!

doesPresource: sourceString expandTo: outputString in: codeMindset
    "Answer whether expanding sourceString as Smalltalk using
     codeMindset matches RB pattern outputString."
    ^(STInST.RBParser parseRewriteMethod: 'test ' , outputString)
	match: (codeMindset expandTree:
		    (STInST.RBParser parseMethod: 'test ' , sourceString))
	inContext: STInST.RBSmallDictionary new
! !

!TestMessageMacroExpansion methodsFor: 'initialize-release'!

setUp
    codeMindset := CodeMindset new.
    codeMindset messageMacroDictionary
	at: #sendingBlock
	put: SendingBlockMacro new;
	at: #valueWith:as:
	put: ValueWithAsMacro new;
	at: #patternValueWith:as:
	put: PatternValueWithAsMacro; "not a class"
	at: #identity
	put: IdentityMacro	"also not a class"
! !

!TestMessageMacroExpansion methodsFor: 'unit testing'!

testArgumentedExpansion
    self assertThat: 'aBlock valueWith: currentState as: State new'
	 expandsTo: '[| `var1 |
	    `var1 := currentState.
	    [currentState := State new.
	     aBlock value] ensure: [currentState := `var1]] value'
!

testUnaryExpansion
    self assertThat: '#(1 2 3) fold: #+ sendingBlock'
	 expandsTo: '#(1 2 3) fold: [:`recv :`arg | `recv + `arg]';
	assertThat: '#first sendingBlock'
	expandsTo: '[:`recv | `recv first]';
	assertThat: '#at:put: sendingBlock'
	expandsTo: '[:`recv :`arg1 :`arg2 | `recv at: `arg1 put: `arg2]'.
!

testPatternExpansion
    self assertThat: 'aBlock patternValueWith: currentState as: State new'
	 expandsTo: '[| `var1 |
	    `var1 := currentState.
	    [currentState := State new.
	     aBlock value] ensure: [currentState := `var1]] value'.
!

testPreorderTraversal
    "This test may have to change if the semantics of PatternMacro's
     forgo-on-no-pattern-match feature change.  Currently, it just
     forgoes expansion without any error.  This test assumes
     trampolining behavior in testExpanderTrampolines."
    self assertThat: 'aBlock patternValueWith: currentState identity
			     as: State new'
	 expandsTo: 'aBlock patternValueWith: currentState
			    as: State new'
	 description: 'Outer expressions expand before inner ones'.
!

testExpanderTrampolines
    "Trampolining should happen iff expansion is not forgone by the
     MessageMacro."
    self assertThat: 'aBlock identity identity'
	 expandsTo: 'aBlock';
	assertThat: 'aBlock patternValueWith: currentState first
			    as: State new'
	expandsTo: 'aBlock patternValueWith: currentState first
			   as: State new'.
! !

!TestMessageMacroExpansion methodsFor: 'expansion testing'!

doesPresource: aPresourceString expandTo: aPattern
    "Answer whether aPresourceString, parsed as an expression and
    expanded using codeMindset, matches against aPattern when
    expanded."
    ^self class doesPresource: aPresourceString
		expandTo: aPattern
		in: codeMindset
!

assertThat: aPresourceString expandsTo: aPattern
    ^self assertThat: aPresourceString 
	  expandsTo: aPattern
	  description: ((WriteStream on: (String new: 50))
			    print: aPresourceString;
			    nextPutAll: ' expands to ';
			    print: aPattern;
			    contents)
!

assertThat: aPresourceString expandsTo: aPattern description: description
    ^self assert: (self doesPresource: aPresourceString expandTo: aPattern)
	  description: description
! !

!TestCodeMindsetInstall methodsFor: 'checking common relationships'!

setUp
    baseCM := CodeMindset new.
    extensionCM := CodeMindset new.
    baseCM messageMacroDictionary
	at: #identity put: IdentityMacro;
	at: #valueWith:as: put: PatternValueWithAsMacro.
    extensionCM messageMacroDictionary
	at: #identity
	put: (PatternMacro given: 'address@hidden identity'
			   use: 'address@hidden ifNotNil: [:`var | `var]'
			   withExtraVariables: #('`var')).
!

checkBase: aBaseCM andExtension: anExtensionCM
    "Assert some common properties of aBaseCM and anExtensionCM; see
     source for details on what those are."
    self assert: (TestMessageMacroExpansion
		      doesPresource: 'x identity'
		      expandTo: 'x ifNotNil: [:`var | `var]'
		      in: anExtensionCM)
	 description: 'self is first in CM precedence list'.
    self deny: (TestMessageMacroExpansion
		    doesPresource: 'aBlock valueWith: q as: r'
		    expandTo: '`aBlock valueWith: `q as: `r'
		    in: anExtensionCM)
	 description: 'over-CMs can apply under-CMs'' expansions'.
    self assert: (TestMessageMacroExpansion
		      doesPresource: 'x identity'
		      expandTo: 'x'
		      in: aBaseCM)
	 description: 'over-CMs don''t affect expansion in under-CMs'.
!

checkBaseAndExtension
    "Assert some common properties of baseCM and extensionCM; see
     source for details on what those are."
    ^self checkBase: baseCM andExtension: extensionCM
!

!TestCodeMindsetInstall methodsFor: 'temporary namespaces'!

addSubspaceWithMindset: aCodeMindset in: aNamespace
    "Answer a new subspace of aNamespace with aCodeMindset installed
     as its current CodeMindset."
    | nsNameIdx nsName newNamespace |
    "find a unique name for the test namespace"
    nsNameIdx := 0.
    [nsNameIdx := 1 + nsNameIdx.
     nsName := ((WriteStream on: String new)
		    nextPutAll: 'TestNS'; display: nsNameIdx;
		    contents) asSymbol.
     "includes, not defines, is right here, as I don't want to wipe
      out functionality for *any* code in aNamespace"
     aNamespace includesKey: nsName] whileTrue.
    "create the NS and install aCodeMindset in it"
    newNamespace := aNamespace addSubspace: nsName.
    [aCodeMindset installIn: newNamespace]
	ifCurtailed: [self deleteNamespace: newNamespace].
    ^newNamespace
!

prepareNamespaceWith: aCodeMindset
    "Answer a new namespace under NoCandy.Presrc.Tests with
     aCodeMindset set as its current environment CodeMindset."
    ^self addSubspaceWithMindset: aCodeMindset
	  in: thisContext methodClass environment
!

deleteNamespace: aNamespace
    "Make the namespace hierarchy forget about aNamespace.  This
     method is now a testbed for including the functionality in GST
     kernel"
    ^aNamespace superspace removeSubspace: aNamespace name
! !

!TestCodeMindsetInstall methodsFor: 'testing deps w/o environment'!

testOverMindsets
    | extension extensionMMD |
    extension := CodeMindset nullOverMindsets: {baseCM}.
    extensionMMD := extension messageMacroDictionary.
    extensionCM messageMacroDictionary
	associationsDo: [:a | extensionMMD add: a].
    extensionCM := extension.
    self checkBaseAndExtension.
!

testSingleInstall
    extensionCM installMindset: baseCM.
    self checkBaseAndExtension.
!

testMultiInstall
    | m3 |
    extensionCM installMindset: baseCM.
    m3 := CodeMindset nullOverMindsets: {baseCM}.
    extensionCM installMindset: m3.
    m3 messageMacroDictionary
	at: #identity put: (PatternMacro given: 'address@hidden identity'
					 use: 'address@hidden value').
    self checkBaseAndExtension.
    self assert: (TestMessageMacroExpansion
		      doesPresource: 'fq identity'
		      expandTo: '[fq] value'
		      in: m3)
	 description: 'CM within hierarchy holds its position'.
!

testCircularDeps
    self assert:
	([extensionCM installMindset: baseCM.
	  baseCM installMindset: extensionCM.
	  self checkBaseAndExtension.
	  false]
	     on: SystemExceptions.InvalidValue
	     do: [:e | (e value == baseCM) | (e value == extensionCM)
			   ifTrue: [true] ifFalse: [e pass]])
	 description: 'circular dependency detected'.
! !

!TestCodeMindsetInstall methodsFor: 'testing environment installs'!

testPackagedInstall
    | environment environmentCM extensionEnv extensionEnvCM |
    environment := self prepareNamespaceWith: baseCM.
    [environmentCM := environment at: CodeMindset defaultName.
     self assert: (TestMessageMacroExpansion
		       doesPresource: 'qq identity'
		       expandTo: 'qq'
		       in: environmentCM)
	  description: 'simple installation works'.
     extensionEnv := self addSubspaceWithMindset: extensionCM
			  in: environment.
     extensionEnvCM := extensionEnv at: CodeMindset defaultName.
     self assert: (TestMessageMacroExpansion
		       doesPresource: 'qq identity'
		       expandTo: 'qq ifNotNil: [:`v | `v]'
		       in: extensionEnvCM)
	  description: 'environment hereAt: #MyCodeMindset is primary'.
     self checkBase: environmentCM andExtension: extensionEnvCM.]
	"clean up temp namespaces"
	ensure: [self deleteNamespace: environment].
!

testCombiningInstall
    | environment newXtn |
    environment := self prepareNamespaceWith: extensionCM.
    [newXtn := environment at: CodeMindset defaultName.
     baseCM installIn: environment.
     self checkBase: baseCM andExtension: newXtn.]
	ensure: [self deleteNamespace: environment].
! !

"Testsuite.st ends here"