"======================================================================
|
|   Smalltalk GUI wrapper for method source code widgets
|
|   $Revision: 1.7.5$
|   $Date: 2000/05/28 16:56:52$
|   $Author: pb$
|
 ======================================================================"


"======================================================================
|
| Copyright 1988-92, 1994-95, 1999, 2000 Free Software Foundation, Inc.
| Written by Paolo Bonzini.
|
| This file is part of GNU Smalltalk.
|
| GNU Smalltalk 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, or (at your option) any later version.
| 
| GNU Smalltalk 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
| GNU Smalltalk; see the file COPYING.  If not, write to the Free Software
| Foundation, 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.  
|
 ======================================================================
"

BText subclass:  #BCode
	  instanceVariableNames: 'class line highlighted source variables pools temps highlightBlock'
	  classVariableNames: 'Colors Highlight'
	  poolDictionaries: ''
	  category: 'Graphics-Browser'
!

!BCode class methodsFor: 'choosing behavior'!

highlight
    ^Highlight
!

highlight: aBoolean
    Highlight := aBoolean    
! !

!BCode class methodsFor: 'event handlers'!

colorAt: aSymbol
    ^Colors at: aSymbol ifAbsent: [ nil ]
!

colorAt: aSymbol put: aColor
    ^Colors at: aSymbol put: (BTextAttributes foregroundColor: aColor)
!

initializeColors
    Colors := IdentityDictionary new: 32.
    self highlight: true.
    self
	colorAt: #classVar put: 'cyan4';
	colorAt: #globalVar put: 'cyan4';
	colorAt: #poolVar put: 'cyan4';
	colorAt: #undeclaredVar put: 'red';
	colorAt: #instanceVar put: 'black';
	colorAt: #argument put: 'black';
	colorAt: #temporary put: 'black';
	colorAt: #specialId put: 'grey50';
	colorAt: #literal put: 'grey50';
	colorAt: #temporaries put: 'magenta';
	colorAt: #methodHeader put: 'magenta';
	colorAt: #primitive put: 'magenta';
	colorAt: #arguments put: 'magenta';
	colorAt: #special put: 'magenta';
	colorAt: #unaryMsg put: 'magenta4';
	colorAt: #binaryMsg put: 'chocolate4';
	colorAt: #keywordMsg put: 'NavyBlue';
	colorAt: #comment put: 'SpringGreen4'
! !

!BCode methodsFor: 'event handlers'!

create
    super create.
    highlighted := false.
    self onKeyUpEventSend: #checkLine: to: self.
    self onMouseUpEvent: 1 send: #checkLine: to: self.
!

invokeCallback
    highlighted ifTrue: [ self blackLine ].
    super invokeCallback
!

checkLine: unused
    | oldLine |
    oldLine := line.
    line := self currentLine.
    line = oldLine | highlighted | class isNil
	ifFalse: [ self removeAttributes; highlight ].
! !

!BCode methodsFor: 'widget protocol'!

contents: textOrAssociation
    line := 1.
    highlighted := false.
    (textOrAssociation isKindOf: Association) 
	ifTrue: [
	    source := ReadStream on: (textOrAssociation value).
	    super contents: textOrAssociation value.
	    self inClass: textOrAssociation key; highlight
	]
	ifFalse: [
	    source := class := variables := temps := pools := nil.
	    super contents: textOrAssociation
	]
! !

!BCode methodsFor: 'syntax highlighting callbacks'!

foundMethodHeader: stSelectorNode
    stSelectorNode isNil ifFalse: [
	self declareVariables: stSelectorNode args in: temps as: #argument
    ].
    highlightBlock value: #methodHeader.
    ^stSelectorNode
!

foundTemporaries: anOrderedCollection
    anOrderedCollection isNil ifFalse: [
	self declareVariables: anOrderedCollection in: temps as: #temporary
    ].
    highlightBlock value: #temporaries.
    ^anOrderedCollection
!

foundComment: unused
    highlightBlock value: #comment
!

foundPrimitive: primitive
    highlightBlock value: #primitive.
    ^primitive
!

foundIdentifier: aString
    highlightBlock value: (self variableKind: aString asSymbol).
    ^aString
!

foundConstant: node
    highlightBlock value: #literal.
    ^node
!

foundBlockArgs: anOrderedCollection
    anOrderedCollection isNil ifFalse: [
	self declareVariables: anOrderedCollection in: temps as: #argument
    ].
    highlightBlock value: #arguments.
    ^anOrderedCollection
!
    
foundSpecialChar: result
    highlightBlock value: #special.
    ^result
!

foundKeywordMessage: result
    highlightBlock value: #keywordMsg.
    ^result
!

foundBinaryMessage: result
    highlightBlock value: #binaryMsg.
    ^result
!

foundUnaryMessage: result
    highlightBlock value: #unaryMsg.
    ^result
! !

!BCode methodsFor: 'syntax highlighting'!

blackLine
    highlighted := false.
    self removeAttributesFrom: 1 @ line to: 1 @ (line + 1)
!

highlight
    self class highlight ifFalse: [ ^self ].
    self highlightSyntax; highlightComments.
    highlighted := true.
!

highlightAs: kind from: start to: end
    self
	setAttributes: (BCode colorAt: kind)
	from: start
	to: end.
!

highlightCommentsIn: line lineNumber: i state: previousState last: last
    | pos state |
    line isEmpty ifTrue: [ ^self ].

    state := previousState.
    pos := Point new.

    line doWithIndex: [ :ch :position |
	state = #string ifFalse: [
	    ch = $" ifTrue: [
		pos x: position y: i.
		(state = #comment)
		    ifTrue: [
			pos x: pos x + 1. "Include the trailing quote"
			self highlightAs: #comment from: last to: pos
		    ]
		    ifFalse: [
			pos x: pos x - 1 "Include the leading quote"
		    ].
		last x: pos x y: i.
		state := (state = #code) ifTrue: [ #comment ] ifFalse: [ #code ].
	    ]
	].
	state = #comment ifFalse: [
	    ch = $' ifTrue: [
		state := (state = #string) ifTrue: [ #code ] ifFalse: [ #string ].
	    ]
	].
    ].
    ^state
!

highlightComments
    | state i last |
    state := #code.
    i := 1.
    last := 1 @ 1.

    source reset.
    [ source atEnd ] whileFalse: [
	state := self
	    highlightCommentsIn: source nextLine
	    lineNumber: i
	    state: state
	    last: last.
	i := i + 1
    ]
!

highlightSyntax
    | buffer lineNumber last pos |
    lineNumber := -1.
    last := 1 @ 1.
    pos := Point new.
    highlightBlock := [ :kind |
	pos x: buffer position - 1 y: lineNumber abs.
	self highlightAs: kind from: last to: pos.
	last x: pos x y: pos y.
    ].

    "To track the line number for the text we parsed, we use a buffer
     that will have to be filled when the processing of each line ends"
    (buffer := ReadBuffer on: (String new: 512))
	fillBlock: [ :data :size || line position ofs |
	    data at: 1 put: Character nl.
	    position := source position.
	    line := ''. ofs := 0.
	    source atEnd ifFalse: [
		line := source nextLine.
		lineNumber < 0
		    ifTrue: [ lineNumber := lineNumber negated ]
		    ifFalse: [ ofs := 1. lineNumber := lineNumber + 1 ].

		data
		    replaceFrom: 1 + ofs
		    to: (line size + ofs min: data size)
		    with: line
		    startingAt: 1.

		line size + ofs > data size ifTrue: [
		    source position: (position + data size) - ofs.
		    lineNumber := lineNumber negated
		].
	    ].
	    line size + ofs
	].

    temps := IdentityDictionary new.
    source reset.

    (STPluggableParser onStream: buffer)
	callback: self;
	parseErrorBlock: [ :f :l :m | "Ignore and hope for the best..." ];
	parseSmalltalk.

    highlightBlock := nil.
!

initVariableClassification
    variables := IdentityDictionary new. "variable Symbol -> its kind"
    pools := IdentityDictionary new.	 "Dictionary -> kind of variables in it"

    variables
	at: #self put: #specialId;
	at: #super put: #specialId;
	at: #true put: #specialId;
	at: #false put: #specialId;
	at: #nil put: #specialId;
	at: #thisContext put: #specialId
!

inClass: aClass
    class == aClass ifTrue: [ ^self ].
    class := aClass.
    self initVariableClassification.
    self declareVariables: class allClassVarNames in: variables as: #classVar.
    self declareVariables: class allInstVarNames in: variables as: #instanceVar.
    class withAllSuperclassesDo: [ :each |
	pools at: class environment put: #globalVar.
	class sharedPools do: [ :pool |
	    pools at: (class environment at: pool) put: #poolVar
	]
    ].
!

declareVariables: aCollection in: dictionary as: kind
    aCollection do: [ :each | dictionary at: each asSymbol put: kind ]
!

variableKind: var
    temps at: var ifPresent: [ :kind | ^kind ].
    ^variables at: var ifAbsentPut: [ self classifyNewVariable: var ]
!

classifyNewVariable: var
    pools keysAndValuesDo: [ :pool :kind |
	(pool includesKey: var) ifTrue: [ ^kind ]
    ].
    ^(var at: 1) isUppercase
	ifTrue: [ #globalVar ]
	ifFalse: [ #undeclaredVar ]
! !



!ReadBuffer methodsFor: 'compiling'!

segmentFrom: startPos to: endPos
    ^nil
! !


PText subclass:  #PCode
	  instanceVariableNames: ''
	  classVariableNames: ''
	  poolDictionaries: ''
	  category: 'Graphics-Browser'
!

!PCode class methodsFor: 'instance creation'!

bloxClass
    ^BCode
! !

BCode initializeColors!
