--- a/Explainer.st Fri May 06 08:25:55 2016 +0200
+++ b/Explainer.st Mon May 09 21:50:46 2016 +0200
@@ -56,10 +56,11 @@
!Explainer class methodsFor:'explaining'!
explainLiteralNode:node in:code forClass:cls short:short interval:intervalIfKnown
- |expl literalValue findInnerMost elementIndex codeOfCharacterBeforeCursor|
+ |expl literalValue literalsClass findInnerMost elementIndex codeOfCharacterBeforeCursor|
literalValue := node value.
- expl := literalValue class name "allBold" , '-constant'.
+ literalsClass := literalValue class.
+ expl := (self asClassLink:literalsClass name "allBold") , '-constant'.
(literalValue isInteger) ifTrue:[
(literalValue ~~ 0 and:[literalValue ~~ 1]) ifTrue:[
@@ -146,18 +147,18 @@
|receiver nm srchClass selector selectorString implClass
boldSelectorString globalValue recClassSet
- implMethod implMethodComment info implMethods comments definer
+ implMethod implMethodComment info definer
instances classesOfInstVars implementingClasses canBeNil
bestMatches hint|
selector := node buildSelectorString.
- selectorString := selector printString contractTo:30.
+ selectorString := selector printString contractTo:50.
selector := selector asSymbolIfInterned. "/ avoid creating new symbols.
selector isNil ifTrue:[
^ '%1 is NOWHERE impemented.' bindWith:boldSelectorString
].
- selectorString := selectorString actionForAll:(self actionToBrowseImplementorsOf:selector).
+ selectorString := self asLink:selectorString to:(self actionToBrowseImplementorsOf:selector).
boldSelectorString := selectorString "allBold".
recClassSet := self guessPossibleImplementorClassesFor:(node receiver) in:code forClass:cls.
@@ -174,9 +175,11 @@
].
(#('self' 'super' 'true' 'false' 'thisContext') includes:selector) ifTrue:[
- ^ ('NOT understood here: %1 (missing period after previous statement?)' bindWith:selector allBold),hint
+ ^ ('NOT understood here: %1 (missing period after previous statement?)'
+ bindWith:selector allBold)
].
+ hint := ''.
(recClassSet contains:[:cls | cls isMeta not and:[cls theMetaclass canUnderstand:selector]]) ifTrue:[
hint := '. But class understands it - did you mean "rcvr class ',selector,'..." ?'.
].
@@ -185,9 +188,9 @@
^ ('NOT understood here: %1 (best guess is: "%2" from %3)'
bindWith:selector allBold
with:(bestMatches first "allBold")
- with:(srchClass whichClassIncludesSelector:bestMatches first) name) , (hint?'')
+ with:(srchClass whichClassIncludesSelector:bestMatches first) name) , hint
].
- ^ ('NOT understood here: %1' bindWith:selector allBold),(hint ? '')
+ ^ ('NOT understood here: %1' bindWith:selector allBold),hint
].
].
@@ -234,17 +237,7 @@
implClass isNil ifTrue:[
^ '%1 is NOT understood here.' bindWith:boldSelectorString
].
-
- implMethod := implClass compiledMethodAt:selector.
-
- info := '%1 >> %2' bindWith:implClass name "allBold" with:selectorString "allBold".
- info := info actionForAll:(self actionToBrowseClass:implClass selector:selector).
-
- implMethodComment := self fetchCommentOfMethod:implMethod.
- implMethodComment notNil ifTrue:[
- info := info , ' ' , implMethodComment.
- ].
- ^ info
+ implementingClasses := { implClass }.
].
implementingClasses isNil ifTrue:[
implementingClasses := Smalltalk allImplementorsOf:selector
@@ -253,15 +246,23 @@
implementingClasses size == 1 ifTrue:[
|clsName|
+
implClass := implementingClasses anElement.
implMethod := implClass compiledMethodAt:selector.
clsName := implClass name.
- clsName := clsName actionForAll:(self actionToBrowseClass:implClass selector:selector).
+ clsName := self asLink:clsName to:(self actionToBrowseClass:implClass selector:selector).
info := '%1 >> %2' bindWith:clsName "allBold" with:selectorString.
- (srchClass isNil and:[(cls includesBehavior:implClass) not]) ifTrue:[
- "/ info := 'guess: ', info.
- info := info , ' (guess)'.
+ info := self asLink:info to:(self actionToBrowseClass:implClass selector:selector).
+
+ implMethodComment := self fetchCommentOfMethod:implMethod.
+ implMethodComment notNil ifTrue:[
+ info := info , ' ' , implMethodComment.
].
+ ^ info
+"/ (srchClass isNil and:[(cls includesBehavior:implClass) not]) ifTrue:[
+"/ "/ info := 'guess: ', info.
+"/ info := info , ' (guess)'.
+"/ ].
] ifFalse:[
info := Explainer explainSelector:selector inClass:cls short:short.
].
@@ -303,23 +304,22 @@
explainMethodNode:node in:code forClass:cls short:short interval:intervalIfKnown
|srchClass selector selectorString implClass
- "sendingMethods numSendingMethods sendingClasses" boldSelectorString|
+ "sendingMethods numSendingMethods sendingClasses" |
selector := node selector.
selector := selector asSymbolIfInterned. "/ avoid creating new symbols.
- selectorString := selector printString contractTo:30.
- boldSelectorString := selectorString "allBold".
+ selectorString := selector printString contractTo:50.
(srchClass := cls superclass) notNil ifTrue:[
implClass := srchClass whichClassIncludesSelector:selector.
implClass notNil ifTrue:[
- ^ '%1 hides implementation in %2.'
- bindWith:boldSelectorString
- with:implClass name "allBold"
+ ^ '%1 overrides implementation in %2.'
+ bindWith:(self asLink:selectorString "allBold" to:(self actionToOpenMethodFinderFor:selector))
+ with:(self asLink:implClass name "allBold" to:(self actionToBrowseClass:implClass selector:selector))
].
].
(cls includesSelector:selector) ifFalse:[
- ^ '%1: a new method.' bindWith:boldSelectorString
+ ^ '%1: a new method.' bindWith:selectorString "allBold"
].
"/
"/ sendingMethods := SystemBrowser
@@ -425,7 +425,7 @@
!
explainVariableNode:node in:code forClass:cls short:short interval:intervalIfKnown
- |expl nm nmBold definingNode namePart|
+ |expl nm nmBold definingNode namePart argNode argClass argClassSet|
nm := node name.
@@ -439,8 +439,14 @@
definingNode notNil ifTrue:[
namePart := '''' , nmBold , ''''.
definingNode isMethod ifTrue:[
- (definingNode arguments contains:[:arg | arg name = nm]) ifTrue:[
- expl := namePart , ' is a method argument.'
+ argNode := definingNode arguments detect:[:arg | arg name = nm] ifNone:nil.
+ argNode notNil ifTrue:[
+ expl := namePart , ' is a method argument.'.
+
+ argClassSet := self guessPossibleImplementorClassesFor:argNode in:code forClass:cls.
+ argClassSet size == 1 ifTrue:[
+ argClass := argClassSet first.
+ ].
].
].
expl isNil ifTrue:[
@@ -488,12 +494,21 @@
fetchCommentOfMethod:mthd
"retrieve the comment of a method (if possible and there is one; otherwise, return nil)"
- |methodComment lines|
+ |windowGroup methodComment lines|
"/ with wait cursor, because it accesses sourcecode (via SCM)
- WindowGroup activeGroup withWaitCursorDo:[
+ "/ however: this class is in libcomp (should be in libtool)
+ "/ so check if WindowGroup (from libview) is present
+ windowGroup := Smalltalk at:#WindowGroup.
+ windowGroup isNil ifTrue:[
methodComment := mthd comment.
+ ] ifFalse:[
+ windowGroup activeGroup withWaitCursorDo:[
+ methodComment := mthd comment.
+ ].
].
+ "/ Transcript showCR:methodComment.
+
methodComment isEmptyOrNil ifTrue:[^ nil].
lines := methodComment asStringCollection.
@@ -647,7 +662,7 @@
c isMeta ifTrue:[
clsName := c theNonMetaclass name.
shortText ifTrue:[
- clsName := (clsName actionForAll:(self actionToBrowseClass:c selector:nil)).
+ clsName := self asLink:clsName to:(self actionToBrowseClass:c).
stringText := stringText , ': a class instVar in ' , clsName
] ifFalse:[
stringText := stringText, ': a class instance variable inherited from ' , clsName
@@ -665,7 +680,7 @@
c notNil ifTrue:[
clsName := c name.
shortText ifTrue:[
- clsName := (clsName actionForAll:(self actionToBrowseClass:c selector:nil)).
+ clsName := self asLink:clsName to:(self actionToBrowseClass:c).
stringText := stringText , ': a classVar in ' , clsName
] ifFalse:[
stringText := stringText , ': a class variable in ' , clsName
@@ -681,7 +696,7 @@
c privateClasses do:[:pClass |
(pClass name = string
or:[pClass nameWithoutPrefix = string]) ifTrue:[
- stringText := (stringText actionForAll:(self actionToBrowseClass:pClass selector:nil)).
+ stringText := self asLink:stringText to:(self actionToBrowseClass:pClass).
stringText := stringText , ': a private class in ''' , c name , '''.'.
shortText ifFalse:[
stringText := (stringText , '\\It is only visible locally.') withCRs
@@ -702,7 +717,7 @@
].
(sharedPool includesKey:sharedPoolSym) ifTrue:[
poolName := sharedPool name.
- poolName := (poolName actionForAll:(self actionToBrowseClass:sharedPool selector:nil)).
+ poolName := self asLink:poolName to:(self actionToBrowseClass:sharedPool).
stringText := stringText , ': a pool variable in ',poolName.
val := sharedPool at:sharedPoolSym.
valString := self valueStringFor:val.
@@ -717,7 +732,7 @@
sym := (spc name , '::' , string) asSymbolIfInterned.
sym notNil ifTrue:[
(cls := Smalltalk at:sym) isBehavior ifTrue:[
- stringText := (stringText actionForAll:(self actionToBrowseClass:cls selector:nil)).
+ stringText := self asLink:stringText to:(self actionToBrowseClass:cls).
string := stringText , ': '.
cls name = sym ifFalse:[
string := string , 'refers to ',cls name,', '
@@ -944,14 +959,19 @@
!
explainInstanceVariable:instVarName inClass:aClass short:shortText
- |template stringText setOfTypes typesDescription|
+ |varNameInText classNameInText template stringText setOfTypes typesDescription|
+ varNameInText := instVarName allBold.
+ classNameInText := aClass name.
+
shortText ifTrue:[
- template := '%1: an instVar in %2'
+ template := '%1: an instVar in %2'.
+ varNameInText := self asLink:varNameInText to:(self actionToBrowseInstvarRefsTo:instVarName inClass:aClass).
+ classNameInText := self asLink:classNameInText to:(self actionToBrowseClass:aClass).
] ifFalse:[
template := '%1: an instance variable in %2'
].
- stringText := template bindWith:instVarName allBold with:aClass name.
+ stringText := template bindWith:varNameInText with:classNameInText.
"/ look for instances
setOfTypes := IdentitySet new.
@@ -1134,16 +1154,20 @@
] ifFalse:[
tmp := ' is a selector implemented in '.
].
- s := "'#' ," string allBold.
- s := s actionForAll:(self actionToBrowseImplementorsOf:selector).
+ s := string allBold.
+ count > 1 ifTrue:[
+ s := self asLink:s to:(self actionToOpenMethodFinderFor:selector).
+ ] ifFalse:[
+ s := self asLink:s to:(self actionToBrowseImplementorsOf:selector).
+ ].
shortText ifTrue:[
|typesDescription|
msg := s , tmp.
- typesDescription := (self typeDescriptionFor:listOfImplementingClasses andSelector:selector).
+ typesDescription := self typeDescriptionFor:listOfImplementingClasses andSelector:selector wordBetween:'and'.
typesDescription notNil ifTrue:[
- msg := msg,' (',typesDescription,')'
+ msg := msg,typesDescription
].
] ifFalse:[
(count == 1) ifTrue:[
@@ -1403,7 +1427,7 @@
superName := aClass superclass name.
shortText ifTrue:[
- ^ '"super" - message lookup starts in superclass "%1" (call redefined method).' bindWith:superName
+ ^ '"super" - message lookup starts in superclass "%1" (call redefined method).' bindWith:(self asClassLink:superName)
].
^ 'like "self", "','super'allBold,'" refers to the object which received the message.
@@ -1423,11 +1447,15 @@
!
explainSyntax:string short:shortText
- "try syntax ...; return explanation or nil"
+ "try syntax ...; return explanation or nil.
+ This is meant for beginners..."
((string = ':=') or:[string = '_']) ifTrue:[
shortText ifTrue:[
- ^ '":=" - assign to variable on the left (syntax)'.
+ string = '_' ifTrue:[
+ ^ '"_" - old style for assignment. Consider changing to ":=".'
+ ].
+ ^ '":=" - assign to variable on the left (syntax).'.
].
^ '<variable> := <expression>
@@ -1472,7 +1500,7 @@
(string startsWith:'$' ) ifTrue:[
shortText ifTrue:[
- ^ '"$x" - character literal (syntax)'.
+ ^ '"$x" - ',(self asClassLink:'Character'),' literal (syntax)'.
].
^ 'is a Character literal constant.
@@ -1485,7 +1513,7 @@
(string startsWith:'#' ) ifTrue:[
(string startsWith:'#(' ) ifTrue:[
shortText ifTrue:[
- ^ '"#(..)" - array literal (syntax)'.
+ ^ '"#(..)" - ',(self asClassLink:'Array'),' literal (syntax)'.
].
^ 'is a constant Array (literal).
@@ -1499,7 +1527,7 @@
(string startsWith:'#[') ifTrue:[
shortText ifTrue:[
- ^ '"#[..]" - byteArray literal (syntax)'.
+ ^ '"#[..]" - ',(self asClassLink:'ByteArray'),' literal (syntax)'.
].
^ 'is a constant ByteArray (literal).
@@ -1510,7 +1538,7 @@
(string startsWith:'#''') ifTrue:[
shortText ifTrue:[
- ^ '"#''..''" - symbol literal (syntax)'.
+ ^ '"#''..''" - ',(self asClassLink:'Symbol'),' literal (syntax)'.
].
^ 'is a constant symbol containing non-alphanumeric characters.
@@ -1521,7 +1549,7 @@
].
shortText ifTrue:[
- ^ '"#.." - symbol literal (syntax)'.
+ ^ '"#.." - ',(self asClassLink:'Symbol'),' literal (syntax)'.
].
^ 'is a constant symbol.
@@ -1542,7 +1570,7 @@
((string startsWith:'[') or:[string endsWith:']']) ifTrue:[
shortText ifTrue:[
- ^ '"[..]" - a block (aka lambda/closure for experts)'.
+ ^ '"[..]" - a ',(self asClassLink:'Block'),' (aka lambda/closure for experts)'.
].
^ '[:arg1 .. :argN | statements]
@@ -1558,7 +1586,7 @@
((string startsWith:'{') or:[string endsWith:'}']) ifTrue:[
shortText ifTrue:[
- ^ '"{..}" array instantiation (syntax)'.
+ ^ '"{..}" ',(self asClassLink:'Array'),' instantiation (syntax)'.
].
^ '{ <expr1>. .. <exprN> }
@@ -1662,9 +1690,15 @@
typeDescriptionFor:setOfTypes andSelector:selectorOrNil
"up to 3 types are shown by name; more are simply counted"
+ ^ self typeDescriptionFor:setOfTypes andSelector:selectorOrNil wordBetween:'or'
+!
+
+typeDescriptionFor:setOfTypes andSelector:selectorOrNil wordBetween:wordbetween
+ "up to 3 types are shown by name; more are simply counted"
+
|types numTypes
type1 type2 type3
- nm1 nm2 nm3|
+ nm1 nm2 nm3 link|
"/ reduce...
self compressSetOfTypes:setOfTypes.
@@ -1676,21 +1710,26 @@
"/ now make this a nice string
numTypes := types size.
type1 := types first.
- nm1 := type1 name actionForAll:(self actionToBrowseClass:type1 selector:selectorOrNil).
+ nm1 := self asLink:type1 name to:(self actionToBrowseClass:type1 selector:selectorOrNil).
numTypes == 1 ifTrue:[
^ nm1
].
+
type2 := types second.
- nm2 := type2 name actionForAll:(self actionToBrowseClass:type2 selector:selectorOrNil).
+ nm2 := self asLink:type2 name to:(self actionToBrowseClass:type2 selector:selectorOrNil).
numTypes == 2 ifTrue:[
- ^ nm1,' or ',nm2
+ ^ nm1,' ',wordbetween,' ',nm2
].
type3 := types third.
- nm3 := type3 name actionForAll:(self actionToBrowseClass:type3 selector:selectorOrNil).
+ nm3 := self asLink:type3 name to:(self actionToBrowseClass:type3 selector:selectorOrNil).
numTypes == 3 ifTrue:[
- ^ nm1,', ',nm2,' or ',nm3
+ ^ nm1,', ',nm2,' ',wordbetween,' ',nm3
].
- ^ ('one of %1 classes' bindWith:numTypes) actionForAll:(self actionToBrowseClasses:types).
+ link := self actionToBrowseClasses:types.
+"/ selectorOrNil notNil ifTrue:[
+"/ link := self actionToOpenMethodFinderFor:selectorOrNil.
+"/ ].
+ ^ self asLink:('%1 classes' bindWith:numTypes) to:link.
!
valueStringFor:aValue
@@ -1730,7 +1769,11 @@
!Explainer class methodsFor:'naive type inferer'!
addTypeOfExpressionNode:expr forAssignmentTo:varName to:setOfTypes
- |val valClass msgSelector msgReceiver|
+ "pick up low hanging type information.
+ This is far from being complete, but often gives a hint good enough for code completion
+ and info in the browser."
+
+ |val valClass|
"/ only look for wellknown types on the right side.
expr isLiteral ifTrue:[
@@ -1744,78 +1787,117 @@
].
expr isMessage ifTrue:[
- msgSelector := expr selector.
- msgReceiver := expr receiver.
-
- msgSelector == #? ifTrue:[
- self addTypeOfExpressionNode:(expr arg1) forAssignmentTo:varName to:setOfTypes.
- ^ setOfTypes
- ].
- "/ really really only low hanging fruit...
- "/ ignore / here, because of filename
- ( #(+ - *) includes:msgSelector ) ifTrue:[
- "/ ignore foo := foo OP expr
- "/ ignore foo := expr OP foo
- (msgReceiver isVariable and:[msgReceiver name = varName]) ifFalse:[
- (expr arg1 isVariable and:[expr arg1 name = varName]) ifFalse:[
- self rememberType:Number in:setOfTypes.
- ]
- ].
- ^ setOfTypes.
- ].
+ self addTypeOfMessageNode:expr forAssignmentTo:varName to:setOfTypes.
+ ^ setOfTypes.
+ ].
- ( #(// size hash identityHash) includes:msgSelector ) ifTrue:[
- self rememberType:Integer in:setOfTypes.
- ^ setOfTypes.
- ].
- ( #(next next:) includes:msgSelector ) ifTrue:[
- |rcvrTypes|
-
- rcvrTypes := self addTypeOfExpressionNode:msgReceiver forAssignmentTo:nil to:Set new.
- rcvrTypes notEmpty ifTrue:[
-self halt.
- self rememberType:Character in:setOfTypes.
- ].
- ^ setOfTypes.
- ].
- ( msgSelector startsWith:'as') ifTrue:[
- valClass := Smalltalk classNamed:(msgSelector copyFrom:3).
- valClass notNil ifTrue:[
- self rememberType:valClass in:setOfTypes.
- ^ setOfTypes.
- ].
- ].
- ( #(copy shallowCopy) includes:msgSelector ) ifTrue:[
- msgReceiver isLiteral ifTrue:[
- self addTypeOfExpressionNode:msgReceiver forAssignmentTo:varName to:setOfTypes.
- ].
- ^ setOfTypes
- ].
-
- msgReceiver isGlobal ifTrue:[
- |globalValue|
-
- globalValue := msgReceiver value.
- globalValue isBehavior ifTrue:[
- ( #(new new: basicNew basicNew:) includes:msgSelector ) ifTrue:[
- self rememberType:globalValue in:setOfTypes.
- ^ setOfTypes.
- ].
- ].
-self breakPoint:#cg.
- ] ifFalse:[
-self breakPoint:#cg.
- ]
- ].
^ setOfTypes
"Created: / 30-04-2016 / 15:28:59 / cg"
"Modified: / 30-04-2016 / 20:17:35 / cg"
!
+addTypeOfMessageNode:expr forAssignmentTo:varName to:setOfTypes
+ "pick up low hanging type information.
+ This is far from being complete, but often gives a hint good enough for code completion
+ and info in the browser."
+
+ |valClass msgSelector msgReceiver|
+
+ msgSelector := expr selector.
+ msgReceiver := expr receiver.
+
+ msgSelector == #? ifTrue:[
+ self addTypeOfExpressionNode:(expr arg1) forAssignmentTo:varName to:setOfTypes.
+ ^ setOfTypes
+ ].
+
+ "/ really really only very low hanging fruit...
+ "/ ignore #/ here, because of filename
+ ( #(+ - *) includes:msgSelector ) ifTrue:[
+ "/ ignore foo := foo OP expr
+ "/ ignore foo := expr OP foo
+ (msgReceiver isVariable and:[msgReceiver name = varName]) ifFalse:[
+ (expr arg1 isVariable and:[expr arg1 name = varName]) ifFalse:[
+ self rememberType:Number in:setOfTypes.
+ ]
+ ].
+ ^ setOfTypes.
+ ].
+
+ ( #(// size hash identityHash) includes:msgSelector ) ifTrue:[
+ self rememberType:Integer in:setOfTypes.
+ ^ setOfTypes.
+ ].
+
+ ( #(next next:) includes:msgSelector ) ifTrue:[
+ |rcvrTypes|
+
+ rcvrTypes := self addTypeOfExpressionNode:msgReceiver forAssignmentTo:nil to:Set new.
+ rcvrTypes notEmpty ifTrue:[
+self breakPoint:#cg.
+ self rememberType:Character in:setOfTypes.
+ ].
+ ^ setOfTypes.
+ ].
+
+ ( msgSelector startsWith:'as') ifTrue:[
+ valClass := Smalltalk classNamed:(msgSelector copyFrom:3).
+ valClass notNil ifTrue:[
+ self rememberType:valClass in:setOfTypes.
+ ^ setOfTypes.
+ ].
+ ].
+
+ ( #(copy shallowCopy) includes:msgSelector ) ifTrue:[
+ msgReceiver isLiteral ifTrue:[
+ self addTypeOfExpressionNode:msgReceiver forAssignmentTo:varName to:setOfTypes.
+ ].
+ ^ setOfTypes
+ ].
+
+ msgReceiver isGlobal ifTrue:[
+ |instCreatorMessages globalValue implMethod|
+
+ instCreatorMessages := #(new new: basicNew basicNew:).
+
+ globalValue := msgReceiver value.
+ globalValue isBehavior ifTrue:[
+ ( instCreatorMessages includes:msgSelector ) ifTrue:[
+ self rememberType:globalValue in:setOfTypes.
+ ^ setOfTypes.
+ ].
+ implMethod := globalValue class lookupMethodFor:msgSelector.
+ "/ mhmh - fuzzy; if the implementing message sends any of the above to itself...
+ "/ assume it is returning it.
+ implMethod isNil ifTrue:[
+ "/ will not be understood
+self breakPoint:#cg.
+ ^ setOfTypes.
+ ].
+ (implMethod messagesSentToSelf includesAny:instCreatorMessages) ifTrue:[
+self breakPoint:#cg.
+ self rememberType:globalValue in:setOfTypes.
+ ^ setOfTypes.
+ ].
+ "/ very fuzzy - if the implementing method is in the "instance creation" category...
+ ((implMethod category ? '') startsWith:'instance creation') ifTrue:[
+self breakPoint:#cg.
+ self rememberType:globalValue in:setOfTypes.
+ ^ setOfTypes.
+ ].
+ ].
+ self breakPoint:#cg.
+ ^ setOfTypes
+ ].
+
+self breakPoint:#cg.
+ ^ setOfTypes
+!
+
addTypesAssignedToInstvar:instVarName inClass:aClass method:aMethod to:setOfTypes
"look to asssignments to an instance variable, and pick up low hanging class information.
- This is far from being complete, but gives a hint good enough for code completion
+ This is far from being complete, but often gives a hint good enough for code completion
and info in the browser."
| code |
@@ -1830,7 +1912,7 @@
addTypesAssignedToInstvar:instVarName inClass:aClass source:code to:setOfTypes
"look to asssignments to an instance variable, and pick up low hanging class information.
- This is far from being complete, but gives a hint good enough for code completion
+ This is far from being complete, but often gives a hint good enough for code completion
and info in the browser."
|tree|
@@ -1848,7 +1930,7 @@
addTypesAssignedToInstvar:instVarName inClass:aClass to:setOfTypes
"look to asssignments to an instance variable, and pick up low hanging class information.
- This is far from being complete, but gives a hint good enough for code completion
+ This is far from being complete, but often gives a hint good enough for code completion
and info in the browser."
aClass methodDictionary do:[:m |
@@ -1860,7 +1942,7 @@
addTypesAssignedToInstvar:instVarName inTree:tree to:setOfTypes
"look to asssignments to an instance variable, and pick up low hanging class information.
- This is far from being complete, but gives a hint good enough for code completion
+ This is far from being complete, but often gives a hint good enough for code completion
and info in the browser."
|visitor|
@@ -1869,12 +1951,8 @@
visitor
actionForNodeClass:AssignmentNode
put:[:node |
- |leftSide expr|
-
- leftSide := node variable.
- (leftSide isInstanceVariable and:[ leftSide name = instVarName ]) ifTrue:[
- expr := node expression.
- self addTypeOfExpressionNode:expr forAssignmentTo:instVarName to:setOfTypes
+ (node variable isInstanceVariableNamed:instVarName) ifTrue:[
+ self addTypeOfExpressionNode:(node expression) forAssignmentTo:instVarName to:setOfTypes
].
true "/ yes - visit subnodes
].
@@ -1882,8 +1960,8 @@
!
addTypesAssignedToLocal:localName inTree:tree to:setOfTypes
- "look to asssignments to an instance variable, and pick up low hanging class information.
- This is far from being complete, but gives a hint good enough for code completion
+ "look to asssignments to a local variable, and pick up low hanging class information.
+ This is far from being complete, but often gives a hint good enough for code completion
and info in the browser."
|visitor|
@@ -1894,12 +1972,11 @@
visitor
actionForNodeClass:(Smalltalk at:#RBAssignmentNode)
put:[:node |
- |leftSide expr|
+ |leftSide|
leftSide := node variable.
(leftSide isTemporary and:[ leftSide name = localName ]) ifTrue:[
- expr := node value.
- self addTypeOfExpressionNode:expr forAssignmentTo:localName to:setOfTypes
+ self addTypeOfExpressionNode:(node value) forAssignmentTo:localName to:setOfTypes
].
true "/ yes - visit subnodes
].
@@ -1998,24 +2075,340 @@
!Explainer class methodsFor:'utilities'!
+actionToBrowseClass:class
+ ^ self actionToBrowseClass:class selector:nil.
+!
+
actionToBrowseClass:class selector:selectorOrNil
- selectorOrNil isNil ifTrue:[
- ^ [Tools::NewSystemBrowser openInClass:class]
- ] ifFalse:[
- ^ [Tools::NewSystemBrowser openInClass:class selector:selectorOrNil]
- ].
+ ^ [
+ self thisOrNewBrowserInto:[:browser :openHow |
+ browser
+ spawnFullBrowserInClass:class selector:selectorOrNil in:openHow
+"/ spawnMethodBrowserFor:{class compiledMethodAt:selectorOrNil}
+"/ in:openHow
+"/ label:nil
+ ]
+ ].
!
actionToBrowseClasses:classes
- ^ [Tools::NewSystemBrowser browseClasses:classes]
+ ^ [
+ self thisOrNewBrowserInto:[:browser :openHow |
+ browser
+ spawnClassBrowserFor:classes in:openHow
+ ]
+ ]
+ "/ ^ [Tools::NewSystemBrowser browseClasses:classes]
!
-actionToBrowseImplementorsOf:selector
+actionToBrowseImplementorsOf:selector
+ ^ [
+ self thisOrNewBrowserInto:[:browser :openHow |
+ browser
+ spawnMethodImplementorsBrowserFor:{ selector }
+ in:openHow
+ ]
+ ]
+!
+
+actionToBrowseInstvarRefsTo:instVarName inClass:class
+ ^ [(Tools::NewSystemBrowser basicNew)
+ browseVarRefsToAny:{ instVarName }
+ classes:{ class }
+ variables:#instVarNames access:#readOrWrite all:true
+ title:'references to ',instVarName
+ in:#newBrowser
+ ]
+!
+
+actionToBrowseMethod:mthd
+ ^ self actionToBrowseClass:(mthd mclass) selector:(mthd selector).
+!
+
+actionToOpenMethodFinderFor:selector
MethodFinderWindow notNil ifTrue:[
^ [MethodFinderWindow openOnSelectorPattern:selector].
].
+ ^ self actionToBrowseImplementorsOf:selector
+!
+
+asClassLink:nameOfClass
+ "return text with a hyperlink to browse a class by that name"
- ^ [UserPreferences systemBrowserClass browseImplementorsOf:selector]
+ |cls|
+
+ cls := Smalltalk classNamed:nameOfClass string asUppercaseFirst.
+ cls isNil ifTrue:[^ nameOfClass].
+
+ ^ self asLink:nameOfClass to:(self actionToBrowseClass:cls)
+!
+
+asLink:aString to:action
+ ^ (aString actionForAll:action)
+ withColor:(Color blue)
+!
+
+infoStringForClasses:aCollectionOfClasses withPrefix:prefix
+ "get a nice user readable list for some classes.
+ Up to 4 are named, otherwise the count is presented.
+ The prefix can be sth like ' other', ' sub', ' super',
+ ' implementing' etc. Or it can be an empty string.
+ To be shown in the info line at the bottom."
+
+ |nClassNames classes sortedByName classNames
+ link1 link2 link3 link4|
+
+ aCollectionOfClasses isEmpty ifTrue:[
+ ^ 'No %1classes' bindWith:prefix.
+ ].
+
+ classes := aCollectionOfClasses asIdentitySet asOrderedCollection.
+ classNames := classes collect:[:each | each theNonMetaclass name].
+
+ nClassNames := classNames size.
+
+ nClassNames <= 4 ifTrue:[
+ sortedByName := classNames sortWith:classes.
+
+ link1 := self asLink:classNames first "allBold" to:(self actionToBrowseClass:classes first).
+ nClassNames == 1 ifTrue:[
+ ^ '%2' "'1 %1class: %2'"
+ bindWith:prefix
+ with:link1.
+ ].
+ link2 := self asLink:classNames second "allBold" to:(self actionToBrowseClass:classes second).
+ nClassNames == 2 ifTrue:[
+ ^ '%2 and %3' "'2 %1classes: %2 and %3'"
+ bindWith:prefix
+ with:link1
+ with:link2.
+ ].
+ link3 := self asLink:classNames third "allBold" to:(self actionToBrowseClass:classes third).
+ nClassNames == 3 ifTrue:[
+ ^ '%2, %3 and %4' "'3 %1classes: %2, %3 and %4'"
+ bindWith:prefix
+ with:link1
+ with:link2
+ with:link3.
+ ].
+ link4 := self asLink:classNames fourth "allBold" to:(self actionToBrowseClass:classes fourth).
+ nClassNames == 4 ifTrue:[
+ ^ '%2, %3, %4 and %5' "'4 %1classes: %2, %3, %4 and %5'"
+ bindWith:prefix
+ with:link1
+ with:link2
+ with:link3
+ with:link4.
+ ].
+ ].
+ ^ self asLink:('%1 %2classes' bindWith:(nClassNames printString "allBold") with:prefix)
+ to:(self actionToBrowseClasses:classes)
+
+ "Modified: / 27-07-2006 / 10:09:02 / cg"
+!
+
+infoStringForMethods:aCollectionOfMethods withPrefix:prefix
+ "get a nice user readable list for some methods.
+ Up to 3 are named, otherwise the count is presented.
+ The prefix can be sth like ' other', ' sender', ' implementor',
+ Or it can be an empty string.
+ Result is meant to be shown in the info line at the bottom of a browser."
+
+ |nMethodNames sortedByName methodNames|
+
+ aCollectionOfMethods isEmpty ifTrue:[
+ ^ 'No %1' bindWith:prefix.
+ ].
+
+ methodNames := aCollectionOfMethods asOrderedCollection
+ collect:[:each | each whoString].
+
+ nMethodNames := methodNames size.
+
+ nMethodNames <= 3 ifTrue:[
+ nMethodNames == 1 ifTrue:[
+ ^ '%2' "'1 %1class: %2'" bindWith:prefix with:(methodNames first allBold).
+ ].
+ sortedByName := methodNames sort.
+ nMethodNames == 2 ifTrue:[
+ ^ '%2 and %3' "'2 %1classes: %2 and %3'" bindWith:prefix
+ with:(sortedByName first allBold)
+ with:(sortedByName second allBold).
+ ].
+ nMethodNames == 3 ifTrue:[
+ ^ '%2, %3 and %4' "'3 %1classes: %2, %3 and %4'" bindWith:prefix
+ with:(sortedByName first allBold)
+ with:(sortedByName second allBold)
+ with:(sortedByName third allBold).
+ ].
+ nMethodNames == 4 ifTrue:[
+ ^ '%2, %3, %4 and %5' "'4 %1classes: %2, %3, %4 and %5'" bindWith:prefix
+ with:(sortedByName first allBold)
+ with:(sortedByName second allBold)
+ with:(sortedByName third allBold)
+ with:(sortedByName fourth allBold).
+ ].
+ ].
+ ^ '%1 %2methods' bindWith:nMethodNames printString allBold with:prefix.
+
+ "
+ Time millisecondsToRun:[
+ self infoStringForMethods:(SystemBrowser allCallsOn:#'at:put:') withPrefix:''
+ ].
+ Time millisecondsToRun:[
+ self infoStringForMethods:(SystemBrowser allCallsOn:#'actionToBrowseClasses:') withPrefix:''
+ ].
+ "
+!
+
+methodImplementorsInfoFor:aMethod inEnvironment:environment
+ "get something about the implementors of aMethod
+ to be shown in the info line at the bottom"
+
+ |implementors msg senders msg2|
+
+ implementors := SystemBrowser
+ findImplementorsOf:aMethod selector
+ in:(environment allClasses)
+ ignoreCase:false.
+
+ implementors notEmpty ifTrue:[
+ msg := 'Only implemented here.'.
+ implementors remove:aMethod ifAbsent:nil.
+ implementors notEmpty ifTrue:[
+ implementors := implementors collect:[:mthd | mthd mclass ? mthd getMclass].
+ implementors notEmpty ifTrue:[
+ msg := 'Also implemented in '.
+ msg := msg , (self infoStringForClasses:implementors withPrefix:'other ').
+ msg := msg , '.'.
+ ]
+ ].
+ ].
+
+false ifTrue:[ "/ too slow
+ senders := SystemBrowser
+ findSendersOf:aMethod selector
+ in:(environment allClasses)
+ ignoreCase:false.
+ senders notEmpty ifTrue:[
+ msg2 := 'Sent from ' , senders size printString, ' methods.'.
+ ] ifFalse:[
+ msg2 := 'No senders.'.
+ ].
+ msg := msg , '/' , msg2
+].
+
+ ^ msg
+!
+
+methodInheritanceInfoFor:aMethod
+ |methodsSuperclass inheritedClass msg methodsClass selector mthd selectorString|
+
+ methodsClass := aMethod mclass.
+ methodsClass isNil ifTrue:[^ nil].
+
+ methodsSuperclass := methodsClass superclass.
+ methodsSuperclass isNil ifTrue:[^ nil].
+
+ selector := aMethod selector.
+ selector isNil ifTrue:[^ nil].
+
+ inheritedClass := methodsSuperclass whichClassIncludesSelector:selector.
+ inheritedClass isNil ifTrue:[^ nil].
+
+ mthd := inheritedClass compiledMethodAt:selector.
+
+ (mthd sends:#'subclassResponsibility') ifTrue:[
+ msg := '%1 overrides subclassResponsibility in %2'.
+ ] ifFalse:[
+ msg := '%1 overrides implementation in %2'.
+ ].
+ selectorString := selector contractTo:30.
+ ^ msg
+ bindWith:(self asLink:selectorString "allBold" to:(self actionToOpenMethodFinderFor:selector))
+ with:(self asLink:inheritedClass name "allBold"
+ to:(self actionToBrowseClass:inheritedClass selector:selector))
+!
+
+methodRedefinitionInfoFor:aMethod
+ "return a user readable string telling in how many subclasses
+ a method is redefined.
+ To be shown in the info line of a browser"
+
+ |redefiningClasses msg cls|
+
+ cls := aMethod mclass.
+ cls isNil ifTrue:[^ nil].
+
+ redefiningClasses := cls allSubclasses select:[:cls | cls includesSelector:aMethod selector. ].
+ redefiningClasses size > 0 ifTrue:[
+ msg := 'redefined in '.
+ msg := msg , (self infoStringForClasses:redefiningClasses withPrefix:'sub').
+ msg := msg , '.'.
+ ].
+
+ ^ msg
+!
+
+methodSendersInfoFor:selector inEnvironment:environment
+ "get something about the senders of a message.
+ to be shown in the info line at the bottom.
+ This may be slow; so think about doing it in background..."
+
+ |senders|
+
+ senders := SystemBrowser
+ findSendersOf:selector
+ in:(environment allClasses)
+ ignoreCase:false
+ match:false.
+
+ senders notEmpty ifTrue:[
+ ^ 'Sent from ' , senders size printString, ' methods.'.
+ ] ifFalse:[
+ ^ 'No senders.'.
+ ].
+!
+
+methodSpecialInfoFor:aMethod
+ "handles special cases - such as documentation methods"
+
+ |cls sel|
+
+ (cls := aMethod mclass) isNil ifTrue:[^ nil].
+ (sel := aMethod selector) isNil ifTrue:[^ nil].
+
+ cls isMeta ifTrue:[
+ (AbstractSourceCodeManager isVersionMethodSelector:sel) ifTrue:[
+ ^ 'The version method is required for the source code repository - do not modify.'.
+ ].
+ sel == #documentation ifTrue:[
+ ^ 'ST/X stores documentation in this method (not in comment slots)'.
+ ].
+ ].
+ ^ nil
+!
+
+thisOrNewBrowserInto:aTwoArgBlock
+ "if I am invoked by a browser,
+ invoke the twoArgBlock withit and an #newBuffer arg.
+ Otherwise, create a new (invisible) browser and pass it to the block
+ with a #newBrowser arg."
+
+ |windowGroupClass browserClass wg app|
+
+ "/ stupid: I am in libcomp; should be in libtool
+ windowGroupClass := Smalltalk at:#WindowGroup.
+ windowGroupClass isNil ifTrue:[^ self].
+ browserClass := Smalltalk at:#'Tools::NewSystemBrowser'.
+ browserClass isNil ifTrue:[^ self].
+
+ ((wg := windowGroupClass activeGroup) notNil
+ and:[ (app := wg application) isKindOf:browserClass ]
+ ) ifTrue:[
+ ^ aTwoArgBlock value:app value:#newBuffer
+ ].
+ ^ aTwoArgBlock value:(browserClass basicNew) value:#newBrowser
! !
!Explainer class methodsFor:'documentation'!