Namespace current: NoCandy.Presrc!

Object subclass: #BindWithFunction
       instanceVariableNames: 'template bindParts streamVar vars
    initializers statements constantOut inlineStreamStringSends'
       classVariableNames: ''
       poolDictionaries: ''
       category: 'Presource-message macros'
!

BindWithFunction comment:
'I parse a single template and build a sequence node that invokes
bindWith for it.'
!

MessageMacro subclass: #StringBindWithMacro
	     instanceVariableNames: 'bindWithClass inlineStreamStringSends'
	     classVariableNames: 'NoStreamStringOverrides'
	     poolDictionaries: ''
	     category: 'Presource-message macros'
!

StringBindWithMacro comment:
'I open-code sends to literal strings of #bindWithArguments: according
to CharacterArray''s #bindWithArguments: protocol.

    bindWithClass
	I only open-code for literal "strings" of this class.
    inlineStreamStringSends
	Whether to eliminate sends to #storeString, #displayString,
	and #printString in the indexable binding parts; e.g. this can
	change the behavior of ''%1'' % {x storeString} if x has an
	override for #storeString such that it delivers a different
	result than ((WriteStream on: String new) store: x; contents).
    NoStreamStringOverrides
	The public default value of inlineStreamStringSends.  True by
	default because overriding any methods such that
	inlineStreamStringSends must be false is a terrible idea.'
!

!BindWithFunction class methodsFor: 'instance creation'!

formatTemplate: template withArguments: bindParts on: ostream inlineStreamStringSends: inlineFlag
    ^super new template: template readStream
	       bindParts: bindParts streamVar: ostream
	       inlineStreamStringSends: inlineFlag;
	reinitialize; yourself
! !

!BindWithFunction methodsFor: 'private'!

template: aStream bindParts: aList streamVar: aVariable inlineStreamStringSends: aBoolean
    template := aStream.
    bindParts := aList.
    streamVar := aVariable.
    inlineStreamStringSends := aBoolean.
!

reinitialize
    vars := Array new: bindParts size.
    initializers := Array new: bindParts size.
    statements := OrderedCollection new: 2 * bindParts size.
    constantOut := WriteStream on: (template species new: template size).
! !

!BindWithFunction methodsFor: 'building node parts'!

isStreamStringSend: aNode
    "Answer whether aNode is a stream-string send that can be
     eliminated in a stream-building process."
    ^{[inlineStreamStringSends].
      [aNode isMessage].
      [#(#displayString #printString #storeString)
	   includes: aNode selector]}
	allSatisfy: #value sendingBlock
!    

streamStringOutputSelector: aSelector
    "Answer a 1-arg selector for the unary aSelector, e.g.

     #printString -> #printOn:"
    ^##(LookupTable from: {#printString -> #printOn:.
			   #displayString -> #displayOn:.
			   #storeString -> #storeOn:})
	at: aSelector
!

bindForm: n
    "Answer the nth bound variable, initializing it if needed."
    ^(vars at: n) ifNil:
	[| var bindPart |
	 var := Presrc.MessageMacro newVariable: 'formatTmp'.
	 bindPart := bindParts at: n.
	 "remove sends at init time, must also remove at display time"
	 (self isStreamStringSend: bindPart)
	     ifTrue: [bindPart := bindPart receiver].
	 initializers at: n put:
	     (STInST.RBAssignmentNode variable: var
				      value: bindPart).
	 vars at: n put: var]
!

mustBeBoolean: n
    "Signal an error if bindPart n can't be boolean."
    (self isStreamStringSend: (bindParts at: n))
	ifTrue: [self error: 'expected boolean at %%%1' % {n}].
!

displayConstant
    constantOut position = 0 ifFalse:
	[statements add:
	     (STInST.RBMessageNode
		  receiver: (STInST.RBLiteralNode value: constantOut contents)
		  selector: #displayOn:
		  arguments: {streamVar})].
    constantOut reset.
!

parseConditional
    | trueString falseString n bindPart |
    trueString := template upTo: $|.
    falseString := template upTo: $>.
    bindPart := bindParts at: (n := template next digitValue).
    self mustBeBoolean: n.
    bindPart isLiteral
	ifTrue: [(bindPart value ifTrue: [trueString] ifFalse: [falseString])
		     displayOn: constantOut]
	ifFalse: [| pMap |
		  self displayConstant.
		  pMap := LookupTable from:
		      {'address@hidden' -> (self bindForm: n).
		       'address@hidden' -> (STInST.RBLiteralNode value: trueString).
		       'address@hidden' -> (STInST.RBLiteralNode value: falseString).
		       '`stream' -> streamVar}.
		  statements add:
		      ((Presrc.CodeTemplate fromExpr:
			    '(address@hidden ifTrue: address@hidden
				     ifFalse: address@hidden) displayOn: `stream')
			   expand: pMap)].
!

parseDisplay: n
    | dispSelector bindPart |
    bindPart := bindParts at: n.
    dispSelector := #displayOn:.
    (self isStreamStringSend: bindPart)
	ifTrue: [dispSelector := self streamStringOutputSelector:
		     bindPart selector.
		 bindPart := bindPart receiver].
    bindPart isLiteral
	ifTrue: [bindPart value perform: dispSelector with: constantOut]
	ifFalse: [| message |
		  self displayConstant.
		  message := STInST.RBMessageNode
		      receiver: (self bindForm: n)
		      selector: dispSelector
		      arguments: {streamVar}.
		  statements add: message].
!

sequenceNode
    | start percent |
    "compile the template"
    [constantOut nextPutAll: (template upTo: $%).
     template atEnd] whileFalse:
	[| control |
	 control := template next.
	 {control = ($<) ->[self parseConditional].
	  control = $% -> [constantOut nextPut: control].
	  control isAlphaNumeric -> [self parseDisplay: control digitValue].
	  true -> [self error: 'invalid format control %%%1' % {control}]}
	     condSelect].
    self displayConstant.

    "to preserve evaluation semantics, add back any missing
     non-literal bindParts during initialization"
    "TODO this doesn't work right with #printString sends et al"
    initializers keysAndValuesDo: [:n :assign |
	(assign isNil and: [(bindParts at: n) isLiteral not])
	    ifTrue: [initializers at: n put: (bindParts at: n)]].

    ^(Presrc.CodeTemplate fromExpr:
	  '| address@hidden | address@hidden address@hidden')
	expand: (LookupTable from:
		     {'address@hidden' -> (vars copyWithout: nil).
		      'address@hidden' -> (initializers copyWithout: nil).
		      'address@hidden' -> statements})
! !

!StringBindWithMacro class methodsFor: 'instance creation'!

new
    "Answer a new instance initialized in the default manner."
    ^self onStringClass: Smalltalk.CharacterArray
!

onStringClass: aBehavior
    "Answer a new message macro that assumes receivers of kind
     aBehavior can have their %-calls open-coded."
    ^super new bindWithClass: aBehavior
	       inlineStreamStringSends: NoStreamStringOverrides; 
	yourself
! !

!StringBindWithMacro class methodsFor: 'private'!

initialize
    super initialize.
    (self isMemberOf: thisContext method methodClass) ifTrue:
	[NoStreamStringOverrides := true].
! !

!StringBindWithMacro methodsFor: 'private'!

bindWithClass: aBehavior inlineStreamStringSends: aBoolean
    bindWithClass := aBehavior.
    inlineStreamStringSends := aBoolean.
!

formatTemplate: template withArguments: bindParts on: ostream
    "Answer a sequence node that applies #bindWithArguments: to
     template (a string) and bindParts forms, putting the resulting
     characters on ostream, which should be a variable of some kind."
    ^(BindWithFunction formatTemplate: template
		       withArguments: bindParts on: ostream
		       inlineStreamStringSends: inlineStreamStringSends)
	sequenceNode
!

formatTemplate: template withArguments: bindParts
    | compilation bindings streamVar |
    "One possibility might be to detect a #nextPutAll: or #display:
     send to a variable in my message's parent, making that the stream
     instead.  That would unfortunately change error behavior, but
     it's an interesting possibility nonetheless."
    streamVar := Presrc.MessageMacro newVariable.
    compilation := self formatTemplate: template
			withArguments: bindParts on: streamVar.
    bindings := LookupTable from:
	{'`stream' -> streamVar.
	 'address@hidden' -> compilation temporaries.
	 'address@hidden' -> (STInST.RBLiteralNode value: WriteStream).
	 'address@hidden' -> (STInST.RBLiteralNode value: template species).
	 '`size' -> (STInST.RBLiteralNode value: template size + 20).
	 'address@hidden' -> compilation statements}.
    ^(Presrc.CodeTemplate fromExpr:
	  '[| `stream address@hidden |
	    `stream := address@hidden on: (address@hidden new: `size).
	    address@hidden
	    `stream contents] value') expand: bindings
! !

!StringBindWithMacro methodsFor: 'expanding parse trees'!

expandMessage: percent to: stringNode withArguments: argList
    | template |
    ({[stringNode isLiteral].
      [(template := stringNode value) isKindOf: bindWithClass].
      [argList size = 1].
      [argList first isLiteral
	   or: [argList first isKindOf: STInST.RBArrayConstructorNode]]}
	 allSatisfy: #value sendingBlock)
	ifFalse: [self forgoExpansion].

    "if trivially constant, partial-evaluate"
    ^argList first isLiteral
	"TODO pretty sure I have to wrap this in a literal node"
	ifTrue: [template % argList first value]
	ifFalse: [self formatTemplate: template
		       withArguments: argList first body statements]
! !

StringBindWithMacro initialize!