SystemOrganization addCategory: #'Helvetia-Core'!
SystemOrganization addCategory: #'Helvetia-Core-Pattern'!
SystemOrganization addCategory: #'Helvetia-Core-Actions'!
SystemOrganization addCategory: #'Helvetia-Core-Visitors'!
SystemOrganization addCategory: #'Helvetia-Core-Highlighting'!
SystemOrganization addCategory: #'Helvetia-Core-Completion'!
SystemOrganization addCategory: #'Helvetia-Core-Tests'!

!MultiDisplayScanner methodsFor: '*helvetia-core-scanning' stamp: 'lr 3/19/2008 11:32'!
gutterIcon: aForm 
	aForm 
		displayOn: bitBlt destForm
		at: (rightMargin - aForm width) @ (lineHeight - aForm height // 2 + destY)
		clippingBox: bitBlt clipRect
		rule: Form blend
		fillColor: nil! !

!MultiDisplayScanner methodsFor: '*helvetia-core-scanning' stamp: 'lr 3/31/2009 14:52'!
highlight: anAttribute
	| width |
	(lastIndex isNil or: [ runStopIndex isNil ])
		ifTrue: [ ^ self ].
	width := (font ifNil: [ textStyle fontAt: 1 ]) 
		widthOfString: text string from: lastIndex to: runStopIndex.
	anAttribute draw: (destX @ lineY extent: width @ lineHeight) on: bitBlt! !

ECController subclass: #CHCompletionController
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Completion'!

!CHCompletionController methodsFor: 'menu morph' stamp: 'lr 4/2/2009 15:35'!
openMenuFor: aParagraphEditor 
	| theMenu |
	context := CHCompletionContext
		controller: self
		class: model selectedClassOrMetaClass 
		source: aParagraphEditor text string
		position: aParagraphEditor caret - 1.
	editor := aParagraphEditor.
	theMenu := ECMenuMorph
		controller: self
		position: (aParagraphEditor selectionPosition: context completionToken).
	theMenu isClosed
		ifFalse: [ menuMorph := theMenu ]! !

!Color methodsFor: '*helvetia-core-converting' stamp: 'lr 6/16/2008 12:05'!
acceptDsl: aVisitor
	(TextColor color: self) acceptDsl: aVisitor! !

!RBCascadeNode methodsFor: '*helvetia-core-accessing' stamp: 'lr 4/2/2009 15:40'!
receiver: aNode
	self messages reverseDo: [ :each | each receiver: aNode ]! !

ECModel subclass: #CHCompletionModel
	instanceVariableNames: 'original'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Completion'!

!CHCompletionModel class methodsFor: 'instance creation' stamp: 'lr 11/21/2008 13:33'!
class: aClass original: aModel
	^ (self new setOriginal: aModel) setClass: aClass! !

!CHCompletionModel methodsFor: 'adding' stamp: 'lr 11/21/2008 14:50'!
add: anEntry
	entries addLast: anEntry! !

!CHCompletionModel methodsFor: 'adding' stamp: 'lr 11/21/2008 14:50'!
addAll: aCollection
	entries addAll: aCollection! !

!CHCompletionModel methodsFor: 'initialization' stamp: 'lr 11/21/2008 14:48'!
initializeSelectors
	original initializeSelectors! !

!CHCompletionModel methodsFor: 'actions' stamp: 'lr 11/21/2008 14:43'!
narrowString
	^ narrowString! !

!CHCompletionModel methodsFor: 'actions' stamp: 'lr 4/2/2009 15:32'!
narrowWith: aString
	| morph |
	morph := self textMorph
		ifNil: [ ^ false ].
	narrowString := aString.
	aString isEmpty ifFalse: [
		CHCompleter new
			initializeOn: self class: clazz morph: morph;
			start ]! !

!CHCompletionModel methodsFor: 'accessing' stamp: 'lr 11/21/2008 14:42'!
original
	^ original! !

!CHCompletionModel methodsFor: 'initialization' stamp: 'lr 11/21/2008 12:27'!
setOriginal: aModel
	original := aModel! !

!CHCompletionModel methodsFor: 'accessing' stamp: 'lr 11/21/2008 13:37'!
textMorph
	"Answer the text morph of the receiver, or nil if none."
	
	| context |
	context := thisContext.
	[ context isNil or: [ context receiver isKindOf: TextMorph ] ]
		whileFalse: [ context := context sender ].
	^ context isNil
		ifFalse: [ context receiver ]! !

!Behavior methodsFor: '*helvetia-core' stamp: 'lr 12/2/2008 19:17'!
recompile
	self selectors do: [ :each | self recompile: each from: self ]! !

!Behavior methodsFor: '*helvetia-core' stamp: 'lr 12/2/2008 19:17'!
recompileAll
	self withAllSubclassesDo: [ :each | each recompile ]! !

ECContext subclass: #CHCompletionContext
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Completion'!

!CHCompletionContext methodsFor: 'accessing' stamp: 'lr 4/2/2009 15:35'!
createModel
	^ CHCompletionModel class: theClass original: super createModel! !

!BlockContext methodsFor: '*helvetia-core-visitor' stamp: 'lr 11/21/2008 15:48'!
acceptDsl: aVisitor
	^ self valueWithPossibleArgument: aVisitor! !

!CharacterScanner methodsFor: '*helvetia-core-scanning' stamp: 'lr 9/12/2007 16:01'!
gutterIcon: aForm 
	! !

!CharacterScanner methodsFor: '*helvetia-core-scanning' stamp: 'lr 3/31/2009 11:31'!
highlight: anAttribute! !

TestCase subclass: #CHAstVisitorTest
	instanceVariableNames: ''
	classVariableNames: 'DSLTreePattern'
	poolDictionaries: ''
	category: 'Helvetia-Core-Tests'!

!CHAstVisitorTest methodsFor: 'testing' stamp: 'lr 8/5/2008 11:38'!
testClass
	self visit: [ :context | self assert: context theClass = self class ]! !

!CHAstVisitorTest methodsFor: 'testing-condition' stamp: 'lr 4/2/2009 15:25'!
testConditionBasic
	self visit: CHConditionPattern new! !

!CHAstVisitorTest methodsFor: 'testing-condition' stamp: 'lr 4/2/2009 15:25'!
testConditionElse
	| m1 |
	m1 := false.
	self visit: (CHConditionPattern new
		else: [ :visitor | m1 := true ];
		yourself).
	self assert: m1! !

!CHAstVisitorTest methodsFor: 'testing-condition' stamp: 'lr 4/2/2009 15:25'!
testConditionFalseTrue
	| m1 m2 m3 |
	m1 := m2 := m3 := false.
	self visit: (CHConditionPattern new
		if: [ :visitor | false ] then: [ :visitor | m1 := true ];
		if: [ :visitor | true ] then: [ :visitor | m2 := true ];
		else: [ :visitor | m3 := true ];
		yourself).
	self deny: m1; assert: m2; deny: m3! !

!CHAstVisitorTest methodsFor: 'testing-condition' stamp: 'lr 4/2/2009 15:25'!
testConditionOverlapping
	| m1 m2 m3 |
	m1 := m2 := m3 := false.
	self visit: (CHConditionPattern new
		if: [ :visitor | true ] then: [ :visitor | m1 := true ];
		if: [ :visitor | true ] then: [ :visitor | m1 := true ];
		else: [ :visitor | m1 := true ];
		yourself).
	self assert: m1; deny: m2; deny: m3! !

!CHAstVisitorTest methodsFor: 'testing-condition' stamp: 'lr 4/2/2009 15:25'!
testConditionSimple
	| m1 m2 |
	m1 := m2 := false.
	self visit: (CHConditionPattern new
		if: [ :visitor | false ] then: [ :visitor | m1 := true ];
		else: [ :visitor | m2 := true ];
		yourself).
	self deny: m1; assert: m2! !

!CHAstVisitorTest methodsFor: 'testing-match' stamp: 'lr 4/2/2009 15:26'!
testMatchBasic
	self visit: (CHMatchPattern new 
		expression: '\|\s*([a-z]+)\s*\|';
		yourself)! !

!CHAstVisitorTest methodsFor: 'testing-match' stamp: 'lr 4/2/2009 15:26'!
testMatchGroups
	| m1 m2 |
	m1 := m2 := nil.
	self visit: (CHMatchPattern new
		expression: '\|\s*([a-z]+)\s*\|';
		at: 1 do: [ :c | m1 := c scopedString ];
		at: 2 do: [ :c | m2 := c scopedString ];
		yourself).
	self assert: m1 = '| visitor |'.
	self assert: m2 = 'visitor'.! !

!CHAstVisitorTest methodsFor: 'testing-match' stamp: 'lr 4/2/2009 15:26'!
testMatchMultiple
	| m |
	m := OrderedCollection new.
	self visit: (CHMatchPattern new
		expression: 'an?([A-Z][a-z]+)';
		at: 2 do: [ :c | m add: c scopedString ];
		yourself).
	self assert: m size = 5.
	self assert: m first = 'Rule'.
	self assert: m second = 'String'.
	self assert: m last = 'Rule'! !

!CHAstVisitorTest methodsFor: 'testing-match' stamp: 'lr 4/2/2009 15:26'!
testMatchNested
	| m |
	m := nil.
	self visit: (CHMatchPattern new
		expression: '\|(.*)\|';
		at: 2 do: (CHMatchPattern new
			expression: '\s*([a-z]+)\s*';
			at: 2 do: [ :c | m := c scopedString ];
			yourself);
		yourself).
	self assert: m = 'visitor'! !

!CHAstVisitorTest methodsFor: 'testing-match' stamp: 'lr 4/2/2009 15:26'!
testMatchOverlapping
	| m |
	m := OrderedCollection new.
	self visit: (CHMatchPattern new
		expression: 'visitor.*';
		at: 1 do: [ :c | m add: c scopedString ];
		yourself).
	self assert: m size = 3.
	self assert: m first = 'visitor |'.
	self assert: m last = 'visitor visit: aRule'! !

!CHAstVisitorTest methodsFor: 'testing' stamp: 'lr 8/5/2008 11:28'!
testPragma
	self visit: [ :context |
		self assert: (context pragmas size) = 1.
		self assert: (context pragmaNamed: #pragma:)
			arguments first = 1 ]! !

!CHAstVisitorTest methodsFor: 'testing-range' stamp: 'lr 4/2/2009 15:27'!
testRangeActions
	| outer begin inner end |
	outer := begin := inner := end := nil.
	self visit: (CHRangePattern new 
		begin: '\|\s+' do: [ :c | begin := c scopedText ];
		end: '\s+\|' do: [ :c | end := c scopedText ];
		inner: [ :c | inner := c scopedText ];
		outer: [ :c | outer := c scopedText ];
		yourself).
	self assert: outer = '| visitor |'.
	self assert: begin = '| '.
	self assert: inner = 'visitor'.
	self assert: end = ' |'
	! !

!CHAstVisitorTest methodsFor: 'testing-range' stamp: 'lr 4/2/2009 15:27'!
testRangeBasic
	self visit: (CHRangePattern new 
		begin: '\|'; end: '\|';
		yourself)! !

!CHAstVisitorTest methodsFor: 'testing-range' stamp: 'lr 4/2/2009 15:27'!
testRangeMultiple
	| m |
	m := OrderedCollection new.
	self visit: (CHRangePattern new 
		begin: 'visitor'; 
		end: '\w+' do: [ :c | m add: c scopedText ];
		yourself).
	self assert: m size = 3.
	self assert: m first =  'pragma'.
	self assert: m second = 'DSLAstVisitor'.
	self assert: m last = 'visit'! !

!CHAstVisitorTest methodsFor: 'testing-range' stamp: 'lr 4/2/2009 15:27'!
testRangeNested
	| outer begin inner end |
	outer := begin := inner := end := nil.
	self visit: (CHRangePattern new 
		begin: '\|'; end: '\|';
		outer: (CHRangePattern new
			begin: '\s+' do: [ :c | begin := c scopedText ]; 
			end: '\s+' do: [ :c | end := c scopedText ];
			inner: [ :c | inner := c scopedText ];
			outer: [ :c | outer := c scopedText ];
			yourself);
		yourself).
	self assert: outer = ' visitor '.
	self assert: begin = ' '.
	self assert: inner = 'visitor'.
	self assert: end = ' '.
	! !

!CHAstVisitorTest methodsFor: 'testing-range' stamp: 'lr 4/2/2009 15:27'!
testRangeOverlapping
	| m |
	m := OrderedCollection new.
	self visit: (CHRangePattern new 
		begin: 'visitor'; end: 'class';
		inner: [ :c | m add: c scopedText ];
		yourself).
	self assert: m size = 2.
	self assert: m first =  ' |
	<pragma: 1>
	visitor := DSLAstVisitor
		'.
	self assert: m last = ' visit: aRule'! !

!CHAstVisitorTest methodsFor: 'testing' stamp: 'lr 11/18/2008 13:47'!
testSelectorInvalidBody
	| selector |
	self 
		visit: [ :context | selector := context selector ]
		using: 'asString ^'.
	self assert: selector = #asString.
	
	self 
		visit: [ :context | selector := context selector ]
		using: '+ a ^'.
	self assert: selector = #+.
	
	self 
		visit: [ :context | selector := context selector ]
		using: 'between: a and: b ^'.
	self assert: selector = #between:and:! !

!CHAstVisitorTest methodsFor: 'testing' stamp: 'lr 11/18/2008 13:47'!
testSelectorInvalidSelector
	| selector |
	self 
		visit: [ :context | selector := context selector ]
		using: ''.
	self assert: selector isNil.

	self 
		visit: [ :context | selector := context selector ]
		using: '+ ^ a'.
	self assert: selector isNil.

	self 
		visit: [ :context | selector := context selector ]
		using: 'between: a and:'.
	self assert: selector isNil! !

!CHAstVisitorTest methodsFor: 'testing' stamp: 'lr 11/18/2008 13:47'!
testSelectorValid
	| selector |
	self visit: [ :context | selector := context selector ].
	self assert: selector = #visit:using:.

	self 
		visit: [ :context | selector := context selector ]
		using: 'asString ^ b'.
	self assert: selector = #asString.

	self 
		visit: [ :context | selector := context selector ]
		using: '+ a ^ b'.
	self assert: selector = #+.

	self 
		visit: [ :context | selector := context selector ]
		using: 'between: a and: b ^ c'.
	self assert: selector = #between:and:! !

!CHAstVisitorTest methodsFor: 'testing' stamp: 'lr 11/18/2008 13:47'!
testText
	self visit: [ :context | self assert: context text = (self class sourceCodeAt: #visit:using:) ]! !

!CHAstVisitorTest methodsFor: 'testing' stamp: 'lr 8/5/2008 11:39'!
testTree
	self visit: [ :context | self assert: (context tree isKindOf: RBProgramNode) ]! !

!CHAstVisitorTest methodsFor: 'testing-tree' stamp: 'lr 4/2/2009 15:29'!
testTreeBasic
	self visit: (CHTreePattern new
		expression: '`receiver `@message: `@arguments';
		yourself)! !

!CHAstVisitorTest methodsFor: 'testing-tree' stamp: 'lr 4/2/2009 15:29'!
testTreeGroups
	| m1 m2 m3 |
	m1 := m2 := m3 := nil.
	self visit: (CHTreePattern new
		expression: '`var := `@.expr' do: [ :c | m1 := c scopedString ];
		at: '`var' do: [ :c | m2 := c scopedString ];
		at: '`@.expr' do: [ :c | m3 := c scopedString ];
		yourself).
	self assert: m1 = 'visitor := DSLAstVisitor
		class: self class
		source: aString'.
	self assert: m2 = 'visitor'.
	self assert: m3 = 'DSLAstVisitor
		class: self class
		source: aString'! !

!CHAstVisitorTest methodsFor: 'testing-tree' stamp: 'lr 4/2/2009 15:29'!
testTreeMethod
	| context |
	self visit: (CHTreePattern new
		method: '`@method: `@arguments | `@temps | `@.statements'
		do: [ :c | context := c copy ]).
	self assert: context notNil.
	self assert: (context @ '`@method:') = 'visit:using:'.
	self assert: (context @ '`@arguments') size = 2.
	self assert: (context @ '`@arguments') first isVariable.
	self assert: (context @ '`@arguments') first name = 'aRule'.
	self assert: (context @ '`@arguments') last isVariable.
	self assert: (context @ '`@arguments') last name = 'aString'.
	self assert: (context @ '`@temps') isCollection.
	self assert: (context @ '`@temps') size = 1.
	self assert: (context @ '`@temps') first isVariable.
	self assert: (context @ '`@temps') first name = 'visitor'.
	self assert: (context @ '`@.statements') isCollection.
	self assert: (context @ '`@.statements') size = 2! !

!CHAstVisitorTest methodsFor: 'testing-tree' stamp: 'lr 4/2/2009 15:29'!
testTreeMultiple
	| strings classes |
	strings := OrderedCollection new.
	classes := OrderedCollection new.
	self visit: (CHTreePattern new
		expression: '`.stmt' do: [ :c | 
			strings add: c scopedString.
			classes add: c scopedTree class name ];
		yourself).
	self assert: strings asArray = #( 'visitor := DSLAstVisitor
		class: self class
		source: aString' 'visitor visit: aRule' ).
	self assert: classes asArray = #( RBAssignmentNode RBMessageNode )! !

!CHAstVisitorTest methodsFor: 'testing-tree' stamp: 'lr 4/2/2009 15:29'!
testTreeNested1
	| m1 |
	m1 := OrderedCollection new.
	self visit: (CHTreePattern new
		expression: '`var := `@.expr' do: (CHTreePattern new
			expression: '`.expr' do: [ :c | m1 add: c scopedString ];
			yourself);
		yourself).
	self assert: m1 asArray = #( 'visitor := DSLAstVisitor
		class: self class
		source: aString' )! !

!CHAstVisitorTest methodsFor: 'testing-tree' stamp: 'lr 4/2/2009 15:29'!
testTreeNested2
	| m1 m2 |
	m1 := OrderedCollection new.
	m2 := OrderedCollection new.
	self visit: (CHTreePattern new
		expression: '`.stmt' do: (Array
			with: [ :c | m1 add: c scopedString ]
			with: (DSLTreePattern new
				expression: '`.stmt' do: [ :c | m2 add: c scopedString ];
				yourself));
		yourself).
	self assert: m1 size = 2.
	self assert: m1 asArray = m2 asArray! !

!CHAstVisitorTest methodsFor: 'testing-tree' stamp: 'lr 4/2/2009 15:30'!
testTreeOverlapping
	| strings selectors |
	strings := OrderedCollection new.
	selectors := OrderedCollection new.
	self visit: (CHTreePattern new
		expression: '``receiver `@message: ``@arguments' do: [ :c |
			strings add: c scopedString.
			selectors add: c scopedTree selector ];
		yourself).
	self assert: strings asArray = #( 'DSLAstVisitor
		class: self class
		source: aString' 'self class' 'visitor visit: aRule' ).
	self assert: selectors asArray = #( class:source: class visit: )! !

!CHAstVisitorTest methodsFor: 'testing-tree' stamp: 'lr 4/2/2009 15:29'!
testTreeVerification
	| strings selectors |
	strings := OrderedCollection new.
	selectors := OrderedCollection new.
	self visit: (CHTreePattern new
		verification: [ :node | node selector = #class ];
		expression: '``receiver `@message: ``@arguments' do: [ :c |
			strings add: c scopedString.
			selectors add: c scopedTree selector ];
		yourself).
	self assert: strings asArray = #( 'self class' ).
	self assert: selectors asArray = #( class )! !

!CHAstVisitorTest methodsFor: 'testing' stamp: 'lr 4/2/2009 15:24'!
testVisitor
	| visitor |
	self visit: [ :context | visitor := context ].
	self assert: (visitor isKindOf: CHAstVisitor)! !

!CHAstVisitorTest methodsFor: 'utilities' stamp: 'lr 11/18/2008 13:41'!
visit: aRule
	self visit: aRule using: (self class sourceCodeAt: #visit:using:)! !

!CHAstVisitorTest methodsFor: 'utilities' stamp: 'lr 4/2/2009 15:24'!
visit: aRule using: aString
	"Do not change this method, it does not only trigger the processing of aRule, but is also the target source-code for running the tests."

	| visitor |
	<pragma: 1>
	visitor := CHAstVisitor
		class: self class
		source: aString.
	visitor visit: aRule! !

TestCase subclass: #CHParseVisitorTest
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Tests'!

!CHParseVisitorTest methodsFor: 'testing' stamp: 'lr 10/23/2008 10:55'!
testSelector
	| selector |
	self visit: [ :context | selector := context selector ] source: 'negated ---'.
	self assert: selector = #negated.
	
	self visit: [ :context | selector := context selector ] source: 'at: a ---'.
	self assert: selector = #at:.

	self visit: [ :context | selector := context selector ] source: 'at: a put: b ---'.
	self assert: selector = #at:put:.
	
	self visit: [ :context | selector := context selector ] source: '+ a ---'.
	self assert: selector = #+.
	
	self visit: [ :context | selector := context selector ] source: '---'.
	self assert: selector isNil! !

!CHParseVisitorTest methodsFor: 'utilities' stamp: 'lr 4/2/2009 15:32'!
visit: aRule source: aString
	| visitor |
	visitor := CHParser
		class: self class
		stream: aString readStream
		doIt: false.
	visitor visit: aRule! !

TestCase subclass: #CHSliceTest
	instanceVariableNames: 'arraySlice stringSlice'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Tests'!

!CHSliceTest methodsFor: 'running' stamp: 'lr 3/19/2008 15:39'!
setUp
	arraySlice := #( 1 2 3 4 5 ) sliceFrom: 2 to: 4.
	stringSlice := 'abcde' sliceFrom: 2 to: 4! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 8/6/2007 08:28'!
testAt
	self assert: (arraySlice at: 1) = 2.
	self assert: (arraySlice at: 3) = 4.
	
	self assert: (stringSlice at: 1) = $b.
	self assert: (stringSlice at: 3) = $d! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 3/27/2008 09:33'!
testAtOutOfBounds
	self should: [ arraySlice at: -1 ] raise: Error.
	self should: [ arraySlice at: 0 ] raise: Error.
	self should: [ arraySlice at: 4 ] raise: Error.
	self should: [ arraySlice at: 5 ] raise: Error.
	
	self should: [ stringSlice at: -1 ] raise: Error.
	self should: [ stringSlice at: 0 ] raise: Error.
	self should: [ stringSlice at: 4 ] raise: Error.
	self should: [ stringSlice at: 5 ] raise: Error! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 3/17/2008 13:59'!
testAtPut
	self should: [ arraySlice at: 1 put: 2 ] raise: Error! !

!CHSliceTest methodsFor: 'testing-derived' stamp: 'lr 3/19/2008 13:44'!
testCollect
	self assert: (arraySlice collect: [ :each | each * each ]) = #( 4 9 16 ).
	self assert: (stringSlice collect: [ :each | each asUppercase ]) = 'BCD'! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 9/11/2007 09:40'!
testCollection
	self assert: arraySlice collection = #( 1 2 3 4 5 ).
	self assert: stringSlice collection = 'abcde'! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 4/2/2009 15:05'!
testCopy
	self assert: arraySlice copy class = CHSlice.
	self assert: arraySlice copy = arraySlice.
	
	self assert: stringSlice copy class = CHSlice.
	self assert: stringSlice copy = stringSlice! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 8/6/2007 08:35'!
testDo
	| result |
	result := OrderedCollection new.
	arraySlice do: [ :each | result add: each ].
	self assert: result asArray = #( 2 3 4 ).
	
	result := OrderedCollection new.
	stringSlice do: [ :each | result add: each ].
	self assert: result asArray = #( $b $c $d )
	! !

!CHSliceTest methodsFor: 'testing-derived' stamp: 'lr 10/12/2007 09:54'!
testFirst
	self assert: arraySlice first = 2.
	self assert: stringSlice first = $b! !

!CHSliceTest methodsFor: 'testing-derived' stamp: 'lr 3/17/2008 14:21'!
testIncludes
	self deny: (arraySlice includes: 1).
	self assert: (arraySlice includes: 2).
	self assert: (arraySlice includes: 3).
	self assert: (arraySlice includes: 4).
	self deny: (arraySlice includes: 5).
	
	self deny: (stringSlice includes: $a).
	self assert: (stringSlice includes: $b).
	self assert: (stringSlice includes: $c).
	self assert: (stringSlice includes: $d).
	self deny: (stringSlice includes: $e)! !

!CHSliceTest methodsFor: 'testing-derived' stamp: 'lr 3/17/2008 14:21'!
testIndexOf
	self assert: (arraySlice indexOf: 1) = 0.
	self assert: (arraySlice indexOf: 2) = 1.
	self assert: (arraySlice indexOf: 3) = 2.
	self assert: (arraySlice indexOf: 4) = 3.
	self assert: (arraySlice indexOf: 5) = 0.
	
	self assert: (stringSlice indexOf: $a) = 0.
	self assert: (stringSlice indexOf: $b) = 1.
	self assert: (stringSlice indexOf: $c) = 2.
	self assert: (stringSlice indexOf: $d) = 3.
	self assert: (stringSlice indexOf: $e) = 0! !

!CHSliceTest methodsFor: 'testing-derived' stamp: 'lr 8/6/2007 08:32'!
testLast
	self assert: arraySlice last = 4.
	self assert: stringSlice last = $d! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 3/19/2008 10:03'!
testReadStream
	| stream |
	stream := arraySlice readStream.
	self assert: stream position = 0.
	self assert: stream next = 2.
	self assert: stream position = 1.
	self assert: stream next = 3.
	self assert: stream position = 2.
	self assert: stream next = 4.
	self assert: stream position = 3.
	self assert: stream atEnd.

	self assert: (stream reset; next) = 2.
	self assert: (stream upTo: 5) = #( 3 4 ).	

	stream := stringSlice readStream.
	self assert: stream position = 0.
	self assert: stream next = $b.
	self assert: stream position = 1.
	self assert: stream next = $c.
	self assert: stream position = 2.
	self assert: stream next = $d.
	self assert: stream position = 3.
	self assert: stream atEnd.
	
	self assert: (stream reset; upToEnd) = 'bcd'.
	self assert: (stream reset; next: 4) = 'bcd'! !

!CHSliceTest methodsFor: 'testing-derived' stamp: 'lr 3/19/2008 10:20'!
testReject
	self assert: (arraySlice reject: [ :each | each = 3 ]) = #( 2 4 ).
	self assert: (stringSlice reject: [ :each | each = $c ]) = 'bd'! !

!CHSliceTest methodsFor: 'testing-derived' stamp: 'lr 8/6/2007 08:40'!
testReversed
	self assert: arraySlice reversed = #( 4 3 2 ).
	self assert: stringSlice reversed = 'dcb'! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 8/6/2007 08:30'!
testSize
	self assert: arraySlice size = 3.
	self assert: stringSlice size = 3! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 4/2/2009 15:05'!
testSliceFromTo
	| result |
	result := arraySlice sliceFrom: 1 to: 2.
	self assert: result class = CHSlice.
	self assert: result value = #( 2 3 ).
	self assert: result start = 2.
	self assert: result stop = 3.
	
	result := stringSlice sliceFrom: 2 to: 3.
	self assert: result class = CHSlice.
	self assert: result value = 'cd'.
	self assert: result start = 3.
	self assert: result stop = 4! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 8/6/2007 08:33'!
testSpecies
	self assert: arraySlice species = Array.
	self assert: stringSlice species = ByteString! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 10/24/2008 10:52'!
testStart
	self assert: arraySlice start = 2.
	self assert: stringSlice start = 2! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 10/24/2008 10:51'!
testStop
	self assert: arraySlice stop = 4.
	self assert: stringSlice stop = 4! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 5/19/2008 10:46'!
testValue
	self assert: arraySlice value = #( 2 3 4 ).
	self assert: stringSlice value = 'bcd'! !

!CHSliceTest methodsFor: 'testing' stamp: 'lr 3/17/2008 13:59'!
testWriteStream
	self should: [ arraySlice writeStream ] raise: Error! !

ArrayedCollection subclass: #CHSlice
	instanceVariableNames: 'collection start stop'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core'!

!CHSlice class methodsFor: 'instance creation' stamp: 'lr 10/24/2008 09:36'!
on: aSequenzeableCollection start: aStartInteger stop: aStopInteger 
	^ self basicNew 
		initializeOn: aSequenzeableCollection
		start: aStartInteger
		stop: aStopInteger! !

!CHSlice methodsFor: 'converting' stamp: 'lr 5/15/2008 16:06'!
asInteger
	^ self asString asInteger! !

!CHSlice methodsFor: 'converting' stamp: 'lr 5/15/2008 16:05'!
asNumber
	^ self asString asNumber! !

!CHSlice methodsFor: 'converting' stamp: 'lr 5/19/2008 10:44'!
asString
	^ String withAll: self! !

!CHSlice methodsFor: 'converting' stamp: 'lr 5/15/2008 16:05'!
asSymbol
	^ self asString asSymbol! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 9/7/2007 15:29'!
at: anInteger
	^ collection at: (self indexAt: anInteger)! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 6/13/2007 10:31'!
at: anInteger put: anObject
	self shouldNotImplement! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 9/11/2007 09:39'!
collection
	"Answer the full underlying collection."
	
	^ collection! !

!CHSlice methodsFor: 'enumerating' stamp: 'lr 10/24/2008 09:39'!
do: aBlock
	"Iterate over the elements of the receiver."
	
	start to: stop do: [ :index | aBlock value: (collection at: index) ]! !

!CHSlice methodsFor: 'private' stamp: 'lr 10/24/2008 09:34'!
indexAt: anInteger 
	| index |
	^ (anInteger < 1 or: [ (index := start + anInteger - 1) > stop ]) 
		ifTrue: [ self errorOutOfBounds ]
		ifFalse: [ index ]! !

!CHSlice methodsFor: 'initialization' stamp: 'lr 10/24/2008 09:37'!
initializeOn: aSequenzeableCollection start: aStartInteger stop: aStopInteger 
	collection := aSequenzeableCollection.
	start := aStartInteger.
	stop := aStopInteger! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 10/24/2008 09:35'!
interval
	"Answer the interval in the underlying collection."
	
	^ start to: stop! !

!CHSlice methodsFor: 'printing' stamp: 'lr 5/19/2008 10:47'!
printOn: aStream
	aStream print: self value! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 3/19/2008 10:01'!
readStream
	"Answer a read-stream on the receiver."

	^ ReadStream on: self copy! !

!CHSlice methodsFor: 'copying' stamp: 'lr 10/24/2008 09:38'!
shallowCopy
	<primitive: 148>
	self primitiveFailed! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 10/24/2008 09:36'!
size
	"Answer the size of the receiving collection."
	
	^ stop - start + 1! !

!CHSlice methodsFor: 'copying' stamp: 'lr 9/7/2007 15:32'!
sliceFrom: aFromInteger to: aToInteger
	^ collection sliceFrom: (self indexAt: aFromInteger) to: (self indexAt: aToInteger)! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 6/13/2007 10:42'!
species
	^ collection species! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 10/24/2008 09:51'!
start
	"Answer the start index within the underlying colleciton."
	
	^ start! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 10/24/2008 09:35'!
stop
	"Answer the stop index within the underlying colleciton."
	
	^ stop! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 10/24/2008 09:38'!
value
	"Answer the value of the receiver."
	
	^ collection copyFrom: start to: stop! !

!CHSlice methodsFor: 'accessing' stamp: 'lr 3/17/2008 13:58'!
writeStream
	self shouldNotImplement! !

!Text methodsFor: '*helvetia-core-copying' stamp: 'lr 3/27/2009 18:12'!
asSymbol
	^ self asString asSymbol! !

!Text methodsFor: '*helvetia-core-copying' stamp: 'lr 10/24/2008 09:31'!
removeAttributesFrom: aStartInteger to: aStopInteger
	self 
		replaceFrom: aStartInteger to: aStopInteger 
		with: (string copyFrom: aStartInteger to: aStopInteger)! !

!OBMorphicIcons methodsFor: '*helvetia-core-icons' stamp: 'lr 9/12/2007 15:41'!
error
	^ (ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606214937 488184354 606348324 606348324 555490848 538975772 556016676 606348322 469770015 522133248 471999524 606348307 100663296 0 118694948 606348304 17040645 84215044 34612260 606348309 304292643 589505315 303375396 606348304 285412364 202116099 286270500 606348307 252184584 134744072 252912676 606348311 336071435 185273096 236397604 606348324 403507457 16845326 405021732 606348324 605491984 370152215 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606348324 606348324)
	offset: 0@0)
	colorsFromArray: #(#(0.948 0.455 0.462) #(0.913 0.415 0.431) #(0.921 0.427 0.443) #(0.976 0.721 0.729) #(0.976 0.729 0.737) #(0.983 0.807 0.815) #(0.874 0.309 0.341) #(0.87 0.309 0.341) #(0.933 0.345 0.384) #(0.886 0.328 0.357) #(0.882 0.328 0.361) #(0.936 0.372 0.4) #(0.983 0.788 0.8) #(0.807 0.156 0.215) #(0.807 0.16 0.219) #(0.866 0.25 0.301) #(0.839 0.297 0.345) #(0.921 0.333 0.376) #(0.944 0.369 0.419) #(0.89 0.525 0.552) #(0.807 0.145 0.207) #(0.807 0.18 0.242) #(0.807 0.188 0.25) #(0.936 0.788 0.811) #(0.901 0.671 0.71) #(0.811 0.431 0.361) #(0.843 0.541 0.49) #(0.858 0.587 0.541) #(0.788 0.278 0.242) #(0.811 0.353 0.321) #(0.893 0.4 0.38) #(0.952 0.486 0.486) #(0.921 0.486 0.486) #(0.89 0.768 0.768) #(0.921 0.831 0.831) #(1.0 1.0 1.0) #( ) )! !

!OBMorphicIcons methodsFor: '*helvetia-core-icons' stamp: 'lr 9/12/2007 15:40'!
warning
	^ (ColorForm
	extent: 16@16
	depth: 8
	fromArray: #( 724249387 724249387 724249387 724249387 724249387 724249387 724249387 724249387 724249387 724249124 606743339 724249387 724249387 724248584 136457003 724249387 724249387 724181777 287517227 724249387 724249387 723519506 336077099 724249387 724249387 622725141 319299109 724249387 724249387 520096533 319488039 724249387 724249375 620825110 319357221 657140523 724249371 17566732 202116097 489368363 724245507 252644885 319687949 36055851 724244485 269488146 336597008 68692779 724244777 117900806 101058054 689580843 724249367 387389207 387389207 388705067 724249387 724249387 724249387 724249387 724249387 724249387 724249387 724249387)
	offset: 0@0)
	colorsFromArray: #(#(0.995 0.858 0.451) #(1.0 0.87 0.505) #(1.0 0.886 0.56) #(0.995 0.886 0.556) #(1.0 0.89 0.591) #(0.995 0.893 0.591) #(1.0 0.901 0.619) #(0.995 0.897 0.619) #(1.0 0.933 0.757) #(0.995 0.761 0.297) #(0.995 0.764 0.301) #(0.995 0.764 0.309) #(0.995 0.784 0.357) #(1.0 0.804 0.419) #(0.995 0.804 0.419) #(1.0 0.804 0.423) #(0.995 0.815 0.455) #(1.0 0.866 0.599) #(0.725 0.427 0.0) #(0.509 0.301 0.0) #(0.365 0.215 0.0) #(0.768 0.501 0.141) #(0.768 0.509 0.172) #(0.667 0.501 0.285) #(0.678 0.513 0.293) #(0.671 0.505 0.289) #(0.671 0.509 0.289) #(0.694 0.529 0.305) #(0.682 0.517 0.301) #(0.69 0.529 0.309) #(0.71 0.541 0.321) #(0.698 0.533 0.317) #(0.753 0.584 0.361) #(0.749 0.58 0.361) #(0.764 0.595 0.372) #(0.757 0.587 0.369) #(0.768 0.599 0.376) #(0.784 0.634 0.435) #(0.686 0.517 0.301) #(0.702 0.533 0.317) #(0.764 0.591 0.372) #(0.807 0.682 0.521) #(0.866 0.8 0.725) #( ) )! !

Object subclass: #CHRule
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core'!

CHRule subclass: #CHClickAction
	instanceVariableNames: 'action'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Actions'!

!CHClickAction class methodsFor: 'instance creation' stamp: 'lr 4/2/2009 14:12'!
on: aBlock
	^ self new do: aBlock; yourself! !

!CHClickAction methodsFor: 'visiting' stamp: 'lr 4/2/2009 15:33'!
acceptDsl: aVisitor
	^ CHClickAttribute new
		block: action;
		visitor: aVisitor shallowCopy;
		acceptDsl: aVisitor! !

!CHClickAction methodsFor: 'accessing' stamp: 'lr 8/5/2008 15:00'!
do: aBlock
	action := aBlock fixTemps! !

CHRule subclass: #CHCompletionAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Actions'!

!CHCompletionAction methodsFor: 'visiting' stamp: 'lr 11/21/2008 14:51'!
acceptDsl: aVisitor
	aVisitor model
		addAll: (aVisitor model original
			narrowWith: aVisitor model narrowString;
			entries)! !

CHRule subclass: #CHConditionPattern
	instanceVariableNames: 'conditions else'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Pattern'!

!CHConditionPattern commentStamp: 'lr 5/6/2008 19:40' prior: 0!
I implement an if/then construct.!

!CHConditionPattern methodsFor: 'visiting' stamp: 'lr 7/2/2008 10:20'!
acceptDsl: aVisitor
	conditions do: [ :assoc |
		(aVisitor visit: assoc key)
			ifTrue: [ ^ aVisitor visit: assoc value ] ].
	^ aVisitor visit: else! !

!CHConditionPattern methodsFor: 'accessing' stamp: 'lr 3/19/2008 13:35'!
else: anAction
	else := anAction! !

!CHConditionPattern methodsFor: 'accessing' stamp: 'lr 3/19/2008 13:35'!
if: aBlock then: anAction
	conditions add: aBlock -> anAction! !

!CHConditionPattern methodsFor: 'initialization' stamp: 'lr 3/19/2008 10:29'!
initialize
	super initialize.
	conditions := OrderedCollection new! !

CHRule subclass: #CHMatchPattern
	instanceVariableNames: 'expression actions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Pattern'!

!CHMatchPattern commentStamp: 'lr 5/6/2008 19:40' prior: 0!
I check if some regexp is matched and execute an action on the matched string.!

!CHMatchPattern methodsFor: 'visiting' stamp: 'lr 8/19/2008 13:59'!
acceptDsl: aVisitor
	| stream beginning |
	stream := aVisitor scopedText readStream.
	[ expression searchStream: stream ] whileTrue: [
		1 to: expression subexpressionCount do: [ :index |
			beginning := expression subBeginning: index.
			beginning isNil ifFalse: [
				actions at: index ifPresent: [ :action |
					aVisitor
						scopeFrom: beginning + 1
						to: (expression subEnd: index)
						with: nil visit: action ] ] ] ]! !

!CHMatchPattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 16:57'!
at: anInteger do: anAction 
	actions at: anInteger put: anAction! !

!CHMatchPattern methodsFor: 'accessing' stamp: 'lr 9/11/2007 13:14'!
expression: aString
	expression := aString asRegex! !

!CHMatchPattern methodsFor: 'accessing' stamp: 'lr 8/5/2008 14:56'!
expression: aString do: anAction
	self expression: aString.
	self at: 1 do: anAction! !

!CHMatchPattern methodsFor: 'initialization' stamp: 'lr 9/11/2007 13:14'!
initialize
	super initialize.
	actions := Dictionary new! !

CHRule subclass: #CHRangePattern
	instanceVariableNames: 'begin end outerAction beginAction innerAction endAction'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Pattern'!

!CHRangePattern commentStamp: 'lr 5/6/2008 19:42' prior: 0!
I use two regexps to match the start and the end of a section in the text code and executes actions on the whole match, on the start of the section and on the end (by using #outerAction: #innerAction: #beginAction: #endAction:).!

!CHRangePattern methodsFor: 'visiting' stamp: 'lr 8/19/2008 13:58'!
acceptDsl: aVisitor
	| stream beginStart beginStop endStart endStop |
	stream := aVisitor scopedText readStream.
	[ stream atEnd ] whileFalse: [
		(begin searchStream: stream) ifTrue: [
			beginStart := begin subBeginning: 1.
			beginStop := begin subEnd: 1.
			(end searchStream: stream) 
				ifFalse: [ endStart := endStop := aVisitor scopedText size ]
				ifTrue: [
					endStart := end subBeginning: 1.
					endStop := end subEnd: 1 ].
			aVisitor scopeFrom: beginStart + 1 to: endStop with: nil visit: outerAction.
			aVisitor scopeFrom: beginStart + 1 to: beginStop with: nil visit: beginAction.
			aVisitor scopeFrom: beginStop + 1 to: endStart with: nil visit: innerAction.
			aVisitor scopeFrom: endStart + 1 to: endStop with: nil visit: endAction ] ]! !

!CHRangePattern methodsFor: 'accessing' stamp: 'lr 9/10/2007 15:34'!
begin: aString
	begin := aString asRegex! !

!CHRangePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 17:14'!
begin: aString do: anAction
	self begin: aString.
	beginAction := anAction! !

!CHRangePattern methodsFor: 'accessing' stamp: 'lr 9/10/2007 15:35'!
end: aString
	end := aString asRegex! !

!CHRangePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 17:14'!
end: aString do: anAction
	self end: aString.
	endAction := anAction! !

!CHRangePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 17:14'!
inner: anAction
	innerAction := anAction! !

!CHRangePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 17:14'!
outer: anAction
	outerAction := anAction! !

!CHRule class methodsFor: 'finding' stamp: 'lr 12/2/2008 10:50'!
find: aSymbol for: aClass
	"Find annotated DSL rules of the kind aSymbol applicable for aClass."
	
	| pragmas |
	pragmas := Pragma allNamed: aSymbol from: aClass class to: nil.
	pragmas do: [ :each | each setKeyword: aSymbol asMutator; setArguments: #(0) ].
	pragmas := pragmas , (Pragma allNamed: aSymbol asMutator from: aClass class to: nil).
	pragmas := pragmas select: [ :each | (aClass class lookupSelector: each selector) = each method ].
	pragmas sort: [ :a :b | a arguments first < b arguments first ].
	^ pragmas collect: [ :each | aClass perform: each selector ]! !

!CHRule methodsFor: 'visiting' stamp: 'lr 9/18/2007 11:56'!
acceptDsl: aVisitor
	self subclassResponsibility! !

CHRule subclass: #CHShoutAction
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Actions'!

!CHShoutAction commentStamp: 'lr 5/6/2008 19:41' prior: 0!
I set the style of the text code using the standard Smalltalk-80 Shout syntax highlighter.!

!CHShoutAction methodsFor: 'visiting' stamp: 'lr 10/24/2008 09:54'!
acceptDsl: aVisitor 
	| styler ranges offset |
	styler := SHTextStylerST80 new.
	styler classOrMetaClass: aVisitor theClass.
	ranges := styler
		rangesIn: aVisitor scopedString
		setWorkspace: false.
	ranges isNil ifTrue: [ ^ self ].
	offset := aVisitor scopeStart - 1.
	offset = 0 ifFalse: [
		ranges do: [ :each |
			each start: each start + offset.
			each end: each end + offset ] ].
	styler 
		setAttributesIn: aVisitor text
		fromRanges: ranges! !

CHRule subclass: #CHTreePattern
	instanceVariableNames: 'searchTree verificationBlock action actions'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Pattern'!

!CHTreePattern methodsFor: 'visiting' stamp: 'lr 8/19/2008 14:24'!
acceptDsl: aVisitor 
	| matcher |
	aVisitor scopedTree ifNil: [ ^ self ].
	matcher := ParseTreeSearcher new.
	matcher matchesTree: searchTree do: [ :node :answer |
		(verificationBlock value: node) ifTrue: [
			matcher context keys do: [ :key |
				key isString ifFalse: [
					matcher context
						at: key formattedCode
						put: (matcher context at: key) ] ].
			aVisitor
				scopeNode: node
				with: matcher context
				visit: action.
			matcher context keysAndValuesDo: [ :key :value |
				value isCollection ifFalse: [
					actions at: key ifPresent: [ :subaction |
						aVisitor
							scopeNode: value
							with: matcher context
							visit: subaction ] ] ] ] ].
	matcher executeTree: aVisitor scopedTree! !

!CHTreePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 16:57'!
at: aString do: anAction 
	actions at: (RBParser parseRewriteExpression: aString) put: anAction! !

!CHTreePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 13:23'!
expression: aString
	"Search for the expression pattern aString."
	
	self searchTree: (RBParser parseRewriteExpression: aString)! !

!CHTreePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 17:22'!
expression: aString do: anAction
	self expression: aString.
	action := anAction! !

!CHTreePattern methodsFor: 'initialization' stamp: 'lr 6/9/2008 13:41'!
initialize
	super initialize.
	actions := Dictionary new.
	verificationBlock := [ :visitor | true ]! !

!CHTreePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 13:23'!
method: aString
	"Search for the method pattern aString."

	self searchTree: (RBParser parseRewriteMethod: aString)! !

!CHTreePattern methodsFor: 'accessing' stamp: 'lr 7/4/2008 17:22'!
method: aString do: anAction
	self method: aString.
	action := anAction! !

!CHTreePattern methodsFor: 'accessing' stamp: 'lr 3/28/2008 13:49'!
searchTree: aProgramNode
	searchTree := aProgramNode! !

!CHTreePattern methodsFor: 'accessing' stamp: 'lr 8/5/2008 14:58'!
searchTree: aProgramNode do: anAction
	self searchTree: aProgramNode.
	action := anAction! !

!CHTreePattern methodsFor: 'accessing' stamp: 'lr 3/19/2008 10:25'!
verification: aBlock
	verificationBlock := aBlock! !

Object subclass: #CHVisitor
	instanceVariableNames: 'theClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core'!

!CHVisitor commentStamp: 'lr 4/9/2008 14:49' prior: 0!
Instance Variables
	theClass:		<Behavior>				The class or metaclass containing the current code.
	text:			<String>					The full method body.
	scopedText:		<Slice>					The currently scoped text.
	tree:			<RBMethodNode>			The parse-tree of the method.
	scopedTree:		<RBProgramNode>		The currently scoped parse-tree node.!

CHVisitor subclass: #CHAstVisitor
	instanceVariableNames: 'text scopedText tree scopedTree context'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core'!

CHAstVisitor subclass: #CHAnnotator
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Visitors'!

!CHAnnotator methodsFor: 'configuration' stamp: 'lr 6/18/2008 08:31'!
pragma
	^ #annotator! !

!CHAstVisitor class methodsFor: 'instance creation' stamp: 'lr 6/16/2008 11:52'!
class: aClass source: aText
	^ self basicNew initializeClass: aClass source: aText! !

!CHAstVisitor class methodsFor: 'instance creation' stamp: 'lr 6/16/2008 11:52'!
class: aClass tree: aParseTree
	^ self basicNew initializeClass: aClass tree: aParseTree! !

!CHAstVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 8/19/2008 13:53'!
@ aKey
	^ context isNil ifFalse: [ context at: aKey ifAbsent: nil ]! !

!CHAstVisitor methodsFor: 'private' stamp: 'lr 6/16/2008 11:52'!
buildScopedTree
	^ self tree bestNodeFor: self scopedText interval! !

!CHAstVisitor methodsFor: 'private' stamp: 'lr 8/5/2008 11:43'!
buildTree
	^ [ QQParser parseMethod: self string ]
		on: SmaCCParserError 
		do: [ :err1 |
			[ QQParser parseExpression: self string ]
				on: SmaCCParserError 
				do: [ :err2 | QQParser parseMethod: 'doIt' ] ]! !

!CHAstVisitor methodsFor: 'querying' stamp: 'lr 8/19/2008 13:25'!
hasPragmaNamed: aSymbol
	^ (self pragmaNamed: aSymbol) notNil! !

!CHAstVisitor methodsFor: 'initialization' stamp: 'lr 6/16/2008 11:53'!
initializeClass: aClass source: aText
	self initializeClass: aClass.
	text := aText asText.
	scopedText := text string sliceFrom: 1 to: aText size! !

!CHAstVisitor methodsFor: 'initialization' stamp: 'lr 6/16/2008 11:51'!
initializeClass: aClass tree: aParseTree
	self initializeClass: aClass source: aParseTree formattedCode.
	tree := scopedTree := aParseTree! !

!CHAstVisitor methodsFor: 'testing' stamp: 'lr 3/27/2009 13:47'!
isDoIt
	^ self tree isDoIt or: [ self tree isSequence ]! !

!CHAstVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 8/5/2008 11:21'!
node
	"Answer the currently scoped node."

	^ self scopedTree! !

!CHAstVisitor methodsFor: 'querying' stamp: 'lr 8/19/2008 13:50'!
pragmaNamed: aSymbol
	^ self pragmaNamed: aSymbol ifAbsent: nil! !

!CHAstVisitor methodsFor: 'querying' stamp: 'lr 8/19/2008 13:50'!
pragmaNamed: aSymbol ifAbsent: aBlock
	^ self pragmas
		detect: [ :each | each keyword = aSymbol ]
		ifNone: aBlock! !

!CHAstVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 8/5/2008 11:21'!
pragmas
	"Answer a list of pragmas in the current method."

	^ self tree pragmas collect: [ :each | each pragma ]! !

!CHAstVisitor methodsFor: 'scoping' stamp: 'lr 10/24/2008 09:46'!
scopeFrom: aStartInteger to: aStopInteger with: aDictionary visit: anObject
	"Visit anObject in the source scope from index aFromInteger to aToInteger."
	
	| snapshot |
	(aStopInteger < aStartInteger or: [ anObject isNil ])
		ifTrue: [ ^ self ].
	snapshot := self shallowCopy.
	aDictionary isNil
		ifFalse: [ context := aDictionary ].
	scopedText := scopedText
		sliceFrom: aStartInteger
		to: aStopInteger.
	scopedTree := nil.
	self visit: anObject.
	self copyFrom: snapshot! !

!CHAstVisitor methodsFor: 'scoping' stamp: 'lr 8/19/2008 13:55'!
scopeNode: aNode with: aDictionary visit: anObject
	"Visit anAction in the scope of aNode."

	| snapshot |
	(aNode isNil or: [ anObject isNil ])
		ifTrue: [ ^ self ].
	snapshot := self shallowCopy.
	aDictionary isNil
		ifFalse: [ context := aDictionary ].
	scopedText := text
		sliceFrom: aNode start
		to: aNode stop.
	scopedTree := aNode.
	self visit: anObject.
	self copyFrom: snapshot! !

!CHAstVisitor methodsFor: 'accessing-scoped' stamp: 'lr 10/24/2008 09:41'!
scopeStart
	"Answer the start index of the scope."
	
	^ scopedText start! !

!CHAstVisitor methodsFor: 'accessing-scoped' stamp: 'lr 10/24/2008 09:41'!
scopeStop
	"Answer the stop index of the scope."
	
	^ scopedText stop! !

!CHAstVisitor methodsFor: 'accessing-scoped' stamp: 'lr 11/21/2008 09:31'!
scopedStream
	^ self scopedString readStream! !

!CHAstVisitor methodsFor: 'accessing-scoped' stamp: 'lr 10/24/2008 09:40'!
scopedString
	"Answer the currently scoped source string."

	^ text string copyFrom: scopedText start to: scopedText stop! !

!CHAstVisitor methodsFor: 'accessing-scoped' stamp: 'lr 6/16/2008 11:51'!
scopedText
	"The currently scoped source text."
	
	^ scopedText! !

!CHAstVisitor methodsFor: 'accessing-scoped' stamp: 'lr 6/16/2008 11:51'!
scopedTree
	"The currently scoped parse-tree node."
	
	^ scopedTree ifNil: [ scopedTree := self buildScopedTree ]! !

!CHAstVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 11/18/2008 13:40'!
selector
	"Answer the selector of the method, or nil there is a parse error."
	
	| node |
	self text isEmpty
		ifTrue: [ ^ nil ].
	node := [ QQParser parseMethodPattern: self text ]
		on: SmaCCParserError
		do: [ :err | ^ nil ].
	^ node isNil
		ifFalse: [ node selector ]! !

!CHAstVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 11/21/2008 09:31'!
stream
	^ self string readStream! !

!CHAstVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 6/16/2008 11:51'!
string
	^ text string! !

!CHAstVisitor methodsFor: 'accessing' stamp: 'lr 8/5/2008 11:22'!
text
	"Answer the full source code."
	
	^ text! !

!CHAstVisitor methodsFor: 'accessing' stamp: 'lr 8/5/2008 11:22'!
tree
	"Answer the parse-tree of the method."
	
	^ tree ifNil: [ tree := self buildTree ]! !

CHAstVisitor subclass: #CHCompleter
	instanceVariableNames: 'selection model'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Visitors'!

!CHCompleter methodsFor: 'initialization' stamp: 'lr 11/21/2008 14:08'!
initializeOn: aModel class: aClass morph: aMorph
	self initializeClass: aClass source: aMorph contents.
	selection := aMorph editor selectionInterval.
	model := aModel! !

!CHCompleter methodsFor: 'accessing' stamp: 'lr 11/21/2008 14:13'!
model
	"Answer the completion model."

	^ model! !

!CHCompleter methodsFor: 'accessing' stamp: 'lr 11/21/2008 14:13'!
position
	"Answer the cursor position in the input stream."

	^ selection first! !

!CHCompleter methodsFor: 'configuration' stamp: 'lr 11/21/2008 14:17'!
pragma
	^ #complete! !

!CHCompleter methodsFor: 'accessing' stamp: 'lr 11/21/2008 15:17'!
selectedNode
	^ self tree bestNodeFor: self selection! !

!CHCompleter methodsFor: 'accessing' stamp: 'lr 11/21/2008 14:14'!
selection
	"Answer the selection interval in the input stream."

	^ selection! !

!CHCompleter methodsFor: 'visiting' stamp: 'lr 11/21/2008 16:18'!
start
	"Perform the rules until we have filled the model somehow."
	
	| currentNode |
	self rules do: [ :rule |
		currentNode := self selectedNode.
		[ currentNode isNil or: [ currentNode isSequence ] ] whileFalse: [
			self scopeNode: currentNode with: self model visit: [
				self visit: rule.
				self model isEmpty
					ifFalse: [ ^ self ].
				currentNode := currentNode parent ] ] ]! !

CHAstVisitor subclass: #CHHighlighter
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Visitors'!

!CHHighlighter class methodsFor: 'utilities' stamp: 'lr 11/6/2008 14:58'!
mark: aCollection with: anObject
	| object |
	aCollection isCollection
		ifFalse: [ ^ aCollection ].	
	^ aCollection flatten collect: [ :each |
		each isVariableBinding
			ifFalse: [ each -> anObject ]
			ifTrue: [
				object := anObject isCollection
					ifTrue: [ anObject asArray ]
					ifFalse: [ Array with: anObject ].
				each value: (each value isCollection
					ifTrue: [ each value asArray , object ]
					ifFalse: [ (Array with: each value) , object ]) ] ]! !

!CHHighlighter methodsFor: 'configuration' stamp: 'lr 6/16/2008 11:51'!
pragma
	^ #highlight! !

CHAstVisitor subclass: #CHTransformer
	instanceVariableNames: ''
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Visitors'!

!CHTransformer methodsFor: 'configuration' stamp: 'lr 6/16/2008 11:40'!
pragma
	^ #transform! !

CHVisitor subclass: #CHParser
	instanceVariableNames: 'stream doIt'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Visitors'!

!CHParser class methodsFor: 'instance creation' stamp: 'lr 6/16/2008 11:58'!
class: aClass stream: aStream doIt: aBoolean
	^ self basicNew initializeClass: aClass stream: aStream doIt: aBoolean! !

!CHParser methodsFor: 'initialization' stamp: 'lr 6/16/2008 11:59'!
initializeClass: aClass stream: aStream doIt: aBoolean
	self initializeClass: aClass.
	stream := aStream.
	doIt := aBoolean! !

!CHParser methodsFor: 'testing' stamp: 'lr 3/27/2009 13:48'!
isDoIt
	"Answer if the receiving visitor is a do-it."
	
	^ doIt! !

!CHParser methodsFor: 'configuration' stamp: 'lr 12/2/2008 10:50'!
pragma
	^ #parse! !

!CHParser methodsFor: 'accessing' stamp: 'lr 10/24/2008 13:43'!
selector
	"Answer the selector of the method, or nil."
	
	^ RBParser parseMethodPattern: stream contents! !

!CHParser methodsFor: 'visiting' stamp: 'lr 3/27/2009 13:49'!
start
	| result |
	self rules do: [ :each |
		result := self visit: each.
		(result isString)
			ifTrue: [ stream := result readStream ].
		(result isKindOf: RBProgramNode)
			ifTrue: [ ^ result ] ].
	^ self isDoIt
		ifTrue: [ QQParser parseDoIt: self stream ]
		ifFalse: [ QQParser parseMethod: self stream ]! !

!CHParser methodsFor: 'accessing' stamp: 'lr 6/16/2008 12:00'!
stream
	^ stream! !

!CHParser methodsFor: 'accessing' stamp: 'lr 3/27/2009 13:48'!
string
	^ stream contents! !

!CHVisitor class methodsFor: 'instance creation' stamp: 'lr 6/16/2008 11:52'!
class: aClass
	^ self basicNew initializeClass: aClass! !

!CHVisitor methodsFor: 'initialization' stamp: 'lr 6/16/2008 11:52'!
initializeClass: aClass
	theClass := aClass! !

!CHVisitor methodsFor: 'testing' stamp: 'lr 3/27/2009 13:42'!
isDoIt
	"Answer if the receiving visitor is a do-it."
	
	self subclassResponsibility! !

!CHVisitor methodsFor: 'configuration' stamp: 'lr 3/19/2008 10:21'!
pragma
	"Answer the pragma that should be used to collect the appropriate rules."
	
	self subclassResponsibility! !

!CHVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 4/2/2009 15:05'!
rules
	"Answer a collection of rules that should be used visited by the receiver."

	^ CHRule find: self pragma for: self theClass! !

!CHVisitor methodsFor: 'visiting' stamp: 'lr 6/16/2008 12:04'!
start
	^ self visit: self rules! !

!CHVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 11/21/2008 09:31'!
stream
	self subclassResponsibility! !

!CHVisitor methodsFor: 'accessing-dynamic' stamp: 'lr 3/27/2009 13:42'!
string
	self subclassResponsibility! !

!CHVisitor methodsFor: 'accessing' stamp: 'lr 3/27/2009 14:09'!
theClass
	"The class or metaclass containing the current code."
	
	^ theClass ifNil: [ theClass := UndefinedObject ]! !

!CHVisitor methodsFor: 'visiting' stamp: 'lr 6/16/2008 12:05'!
visit: anObject
	^ anObject acceptDsl: self! !

!Object methodsFor: '*helvetia-core-visitor' stamp: 'lr 7/2/2008 11:17'!
acceptDsl: aVisitor
	"By default do nothing and answer the receiver."
	
	^ self! !

!DisplayScanner methodsFor: '*helvetia-core-scanning' stamp: 'lr 3/19/2008 11:33'!
gutterIcon: aForm 
	aForm 
		displayOn: bitBlt destForm
		at: (rightMargin - aForm width) @ (lineHeight - aForm height // 2 + destY)
		clippingBox: bitBlt clipRect
		rule: Form blend
		fillColor: nil! !

!DisplayScanner methodsFor: '*helvetia-core-scanning' stamp: 'lr 3/31/2009 14:59'!
highlight: anAttribute
	| width |
	(lastIndex isNil or: [ runStopIndex isNil ])
		ifTrue: [ ^ self ].
	width := (font ifNil: [ textStyle fontAt: 1 ]) 
		widthOfString: text string from: lastIndex to: runStopIndex.
	anAttribute draw: (destX @ lineY extent: width @ lineHeight) on: bitBlt! !

SmaCCParserError subclass: #CHParserError
	instanceVariableNames: 'position'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Visitors'!

!CHParserError class methodsFor: 'instance creation' stamp: 'lr 11/21/2008 10:04'!
signal: aString at: anInteger
	| exception |
	^ (exception := self new)
		tag: exception;
		position: anInteger;
		signal: aString! !

!CHParserError methodsFor: 'accessing' stamp: 'lr 11/21/2008 10:51'!
position
	^ position ifNil: [ 1 ]! !

!CHParserError methodsFor: 'accessing' stamp: 'lr 11/21/2008 10:03'!
position: anInteger
	position := anInteger! !

SHTextStyler subclass: #CHTextStyler
	instanceVariableNames: 'classOrMetaClass'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Highlighting'!

!CHTextStyler methodsFor: 'accessing' stamp: 'lr 9/11/2007 14:24'!
classOrMetaClass: aBehavior
	classOrMetaClass := aBehavior! !

!CHTextStyler methodsFor: 'accessing' stamp: 'lr 9/12/2007 08:42'!
environment: anObject! !

!CHTextStyler methodsFor: 'accessing' stamp: 'lr 9/7/2007 15:48'!
font: aFont! !

!CHTextStyler methodsFor: 'private' stamp: 'lr 9/18/2007 14:27'!
privateFormat: aText
	^ aText! !

!CHTextStyler methodsFor: 'private' stamp: 'lr 4/2/2009 15:32'!
privateStyle: aText
	(CHHighlighter class: classOrMetaClass source: aText)
		start! !

!CHTextStyler methodsFor: 'accessing' stamp: 'lr 3/11/2009 15:59'!
sourceMap: aSortedCollection! !

!CHTextStyler methodsFor: 'accessing' stamp: 'lr 11/7/2008 10:51'!
workspace: anObject! !

!Collection methodsFor: '*helvetia-core-visiting' stamp: 'lr 6/16/2008 12:06'!
acceptDsl: aVisitor
	^ self collect: [ :each | aVisitor visit: each ]! !

!BlockClosure methodsFor: '*helvetia-core-visitor' stamp: 'lr 6/16/2008 12:05'!
acceptDsl: aVisitor
	^ self value: aVisitor! !

!SequenceableCollection methodsFor: '*helvetia-core-copying' stamp: 'lr 4/2/2009 15:05'!
sliceFrom: aFromInteger to: aToInteger 
	^ CHSlice on: self start: aFromInteger stop: aToInteger! !

!MultiCharacterScanner methodsFor: '*helvetia-core-scanning' stamp: 'lr 9/12/2007 16:01'!
gutterIcon: aForm 
	! !

!MultiCharacterScanner methodsFor: '*helvetia-core-scanning' stamp: 'lr 3/31/2009 11:32'!
highlight: anAttribute! !

!Parser2 methodsFor: '*helvetia-core-override' stamp: 'lr 4/2/2009 15:33'!
parse: aStream class: aClass noPattern: aBoolean notifying: anObject ifFail: aBlock
	"Parse sourceStream into a embedded BlockNode if doitFlag is true (no method header) or a MethodNode if doitFlag is false.  Parsing is done with respect to parseScope to find non-local variables.  Errors in parsing are reported to req if not nil followed by executing the fail block."

	| parser tree |
	source := aStream.
	requestor := anObject.
	doitFlag := aBoolean.
	scope := aClass parseScope.
	failBlock := [ ^ aBlock value ].
	parser := self realParserClass.
	^ [	tree := (CHParser class: scope actualClass stream: aStream doIt: doitFlag)
			start.
		(CHTransformer class: scope actualClass tree: tree)
			start.
		[ tree verifyIn: scope ]
			on: SemanticWarning
			do: [ :ex | ex correctIn: self ].
		(CHAnnotator class: scope actualClass tree: tree)
			start.
		tree source: source contents ]
		on: UnhandledError 
		do: [ :ex |
			(SmaCCParserError handles: ex exception)
				ifTrue: [ self notify: ex exception description at: ex exception tag position]
				ifFalse: [ ex pass ] ]! !

TextAttribute subclass: #CHClickAttribute
	instanceVariableNames: 'block visitor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Highlighting'!

!CHClickAttribute methodsFor: 'events' stamp: 'lr 4/10/2008 09:42'!
actOnClickFor: aModel in: aParagraph at: aPoint editor: anEditor
	| replacement definition |
	replacement := block numArgs = 1
		ifTrue: [ block value: visitor ]
		ifFalse: [ block value: visitor value: aModel ].
	replacement ifNil: [ ^ false ].
	definition := aModel getDefinition.
	definition instVarNamed: 'source' put: replacement.
	aModel browser announce: definition.
	^ true! !

!CHClickAttribute methodsFor: 'accessing' stamp: 'lr 4/10/2008 09:41'!
block: aBlock
	block := aBlock! !

!CHClickAttribute methodsFor: 'testing' stamp: 'lr 4/10/2008 09:37'!
mayActOnClick
	^ true! !

!CHClickAttribute methodsFor: 'accessing' stamp: 'lr 4/10/2008 09:40'!
visitor: aVisitor
	visitor := aVisitor! !

TextAttribute subclass: #CHGutterAttribute
	instanceVariableNames: 'icon'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Highlighting'!

!CHGutterAttribute class methodsFor: 'instance creation' stamp: 'lr 9/12/2007 12:03'!
error
	^ self new icon: (OBMorphicIcons iconNamed: #error)! !

!CHGutterAttribute class methodsFor: 'instance creation' stamp: 'lr 9/12/2007 12:03'!
warning
	^ self new icon: (OBMorphicIcons iconNamed: #warning)! !

!CHGutterAttribute methodsFor: 'scanning' stamp: 'lr 11/21/2008 12:14'!
emphasizeScanner: aScanner 
	aScanner gutterIcon: icon! !

!CHGutterAttribute methodsFor: 'accessing' stamp: 'lr 9/12/2007 11:52'!
icon: aForm
	icon := aForm! !

TextAttribute subclass: #CHHighlightAttribute
	instanceVariableNames: 'color outline borderWidth borderColor'
	classVariableNames: ''
	poolDictionaries: ''
	category: 'Helvetia-Core-Highlighting'!

!CHHighlightAttribute class methodsFor: 'utilities' stamp: 'lr 4/1/2009 16:34'!
wave: aColor height: anInteger
	| form |
	form := Form extent: (2 * anInteger) - 2 @ anInteger depth: Display depth.
	1 to: anInteger do: [ :x | form colorAt: (x - 1) @ (anInteger - x) put: aColor ].
	1 to: anInteger - 1 do: [ :x | form colorAt: (anInteger + x - 1) @ x put: aColor ].
	^ form! !

!CHHighlightAttribute methodsFor: 'accessing' stamp: 'lr 3/31/2009 11:18'!
borderColor
	^ borderColor! !

!CHHighlightAttribute methodsFor: 'accessing' stamp: 'lr 3/31/2009 14:58'!
borderColor: anArrayOrColor
	borderColor := anArrayOrColor isArray
		ifTrue: [ anArrayOrColor ]
		ifFalse: [ Array new: 4 withAll: anArrayOrColor ]! !

!CHHighlightAttribute methodsFor: 'accessing-convenience' stamp: 'lr 3/31/2009 15:37'!
borderColorBottom: aColor
	self borderColor at: 3 put: aColor! !

!CHHighlightAttribute methodsFor: 'accessing-convenience' stamp: 'lr 3/31/2009 15:37'!
borderColorLeft: aColor
	self borderColor at: 4 put: aColor! !

!CHHighlightAttribute methodsFor: 'accessing-convenience' stamp: 'lr 3/31/2009 15:37'!
borderColorRight: aColor
	self borderColor at: 2 put: aColor! !

!CHHighlightAttribute methodsFor: 'accessing-convenience' stamp: 'lr 3/31/2009 15:37'!
borderColorTop: aColor
	self borderColor at: 1 put: aColor! !

!CHHighlightAttribute methodsFor: 'accessing' stamp: 'lr 3/31/2009 11:18'!
borderWidth
	^ borderWidth! !

!CHHighlightAttribute methodsFor: 'accessing' stamp: 'lr 3/31/2009 14:58'!
borderWidth: anArrayOrInteger
	borderWidth := anArrayOrInteger isArray
		ifTrue: [ anArrayOrInteger ]
		ifFalse: [ Array new: 4 withAll: anArrayOrInteger ]! !

!CHHighlightAttribute methodsFor: 'accessing-convenience' stamp: 'lr 3/31/2009 15:38'!
borderWidthBottom: anInteger
	self borderWidth at: 3 put: anInteger! !

!CHHighlightAttribute methodsFor: 'accessing-convenience' stamp: 'lr 3/31/2009 15:38'!
borderWidthLeft: anInteger
	self borderColor at: 4 put: anInteger! !

!CHHighlightAttribute methodsFor: 'accessing-convenience' stamp: 'lr 3/31/2009 15:38'!
borderWidthRight: anInteger
	self borderColor at: 2 put: anInteger! !

!CHHighlightAttribute methodsFor: 'accessing-convenience' stamp: 'lr 3/31/2009 15:38'!
borderWidthTop: anInteger
	self borderColor at: 1 put: anInteger! !

!CHHighlightAttribute methodsFor: 'accessing' stamp: 'lr 3/31/2009 11:18'!
color
	^ color! !

!CHHighlightAttribute methodsFor: 'accessing' stamp: 'lr 3/31/2009 11:19'!
color: aColor
	color := aColor! !

!CHHighlightAttribute methodsFor: 'drawing' stamp: 'lr 4/1/2009 16:53'!
draw: aRectangle color: aColorOrForm on: aBitBlt
	| bitBlt |
	aColorOrForm isColor
		ifTrue: [ aBitBlt copy fill: aRectangle fillColor: aColorOrForm rule: Form blend ]
		ifFalse: [
			(bitBlt := aBitBlt copy)
				clipRect: aRectangle; combinationRule: Form paint; fillColor: nil;
				sourceForm: aColorOrForm; sourceRect: aColorOrForm boundingBox;
				colorMap: (aColorOrForm colormapIfNeededFor: bitBlt destForm).
			aRectangle origin x // aColorOrForm width *  aColorOrForm width 
				to: aRectangle corner x by: aColorOrForm width 
				do: [ :x |
					aRectangle origin y 
						to: aRectangle corner y 
						by: aColorOrForm height 
						do: [ :y | bitBlt destX: x; destY: y; copyBits ] ] ]! !

!CHHighlightAttribute methodsFor: 'drawing' stamp: 'lr 4/1/2009 16:50'!
draw: aRectangle on: aBitBlt
	| bounds | 
	bounds := Rectangle
		left: aRectangle left - self outline fourth 
		right: aRectangle right + self outline second 
		top: aRectangle top - self outline first
		bottom: aRectangle bottom + self outline third.
	self draw: bounds color: self color on: aBitBlt.
	self borderWidth first > 0 ifTrue: [
		self
			draw: (bounds withHeight: self borderWidth first)
			color: self borderColor first on: aBitBlt ].
	self borderWidth second > 0 ifTrue: [
		self 
			draw: (bounds withLeft: bounds right - self borderWidth second)
			color: self borderColor second on: aBitBlt ].
	self borderWidth third > 0 ifTrue: [
		self 
			draw: (bounds withTop: bounds bottom - self borderWidth third)
			color: self borderColor third on: aBitBlt ].
	self borderWidth fourth > 0 ifTrue: [
		self 
			draw: (bounds withWidth: self borderWidth fourth)
			color: self borderColor fourth on: aBitBlt ]! !

!CHHighlightAttribute methodsFor: 'scanning' stamp: 'lr 3/31/2009 11:32'!
emphasizeScanner: aScanner
	aScanner highlight: self! !

!CHHighlightAttribute methodsFor: 'initialization' stamp: 'lr 4/1/2009 16:45'!
initialize
	super initialize.
	self outline: 0.
	self color: Color transparent.
	self borderColor: Color transparent.
	self borderWidth: 0! !

!CHHighlightAttribute methodsFor: 'accessing' stamp: 'lr 4/1/2009 16:45'!
outline
	^ outline! !

!CHHighlightAttribute methodsFor: 'accessing' stamp: 'lr 4/1/2009 16:44'!
outline: anArrayOrInteger
	outline := anArrayOrInteger isArray
		ifTrue: [ anArrayOrInteger ]
		ifFalse: [ Array new: 4 withAll: anArrayOrInteger ]! !

!TextAttribute methodsFor: '*helvetia-core-visiting' stamp: 'lr 10/24/2008 09:52'!
acceptDsl: aVisitor
	aVisitor text
		addAttribute: self
		from: aVisitor scopeStart
		to: aVisitor scopeStop! !

!OBDefinitionPanel methodsFor: '*helvetia-core-override' stamp: 'lr 4/2/2009 15:35'!
createCompletionController
	^ CHCompletionController model: self! !