hg/stx-libcomp: comparison Explainer.st

equal deleted inserted replaced

-:ca4ea3855eef
+:707275c1f86d
 ! !
 !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:[
 expl := expl , ' ('.
 #(2 10 16) with:#('binary: ' 'decimal: ' 'hex: ') do:[:base :baseExpl |
 explainMessageNode:node in:code forClass:cls short:short interval:intervalIfKnown
 "answer a string which explains node"
 |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.
 recClassSet size == 1 ifTrue:[
 srchClass := recClassSet first.
 bindWith:selector "allBold"
 with:(implementingClasses size - 1)
 ].
 (#('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,'..." ?'.
 ].
 bestMatches := Parser findBestSelectorsFor:selector in:srchClass.
 bestMatches size > 0 ifTrue:[
 ^ ('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
 ].
 ].
 implementingClasses isNil ifTrue:[
 receiver := node receiver.
 srchClass notNil ifTrue:[
 implClass := srchClass whichClassIncludesSelector:selector.
 implClass isNil ifTrue:[
 ^ '%1 is NOT understood here.' bindWith:boldSelectorString
 ].
+implementingClasses := { implClass }.
-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 isNil ifTrue:[
 implementingClasses := Smalltalk allImplementorsOf:selector
 ].
 ].
 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 := self asLink:info to:(self actionToBrowseClass:implClass selector:selector).
-"/ info := 'guess: ', info.
-info := info , ' (guess)'.
+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.
 ].
 "/    implementingClasses notEmptyOrNil ifTrue:[
 "Modified: / 30-04-2016 / 17:08:11 / cg"
 !
 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.
+selectorString := selector printString contractTo:50.
-boldSelectorString := selectorString "allBold".
 (srchClass := cls superclass) notNil ifTrue:[
 implClass := srchClass whichClassIncludesSelector:selector.
 implClass notNil ifTrue:[
-^ '%1 hides implementation in %2.'
+^ '%1 overrides implementation in %2.'
-bindWith:boldSelectorString
+bindWith:(self asLink:selectorString "allBold" to:(self actionToOpenMethodFinderFor:selector))
-with:implClass name "allBold"
+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
 "/                                allCallsOn:selector
 "/                                in:(cls withAllSubclasses , cls allSubclasses)
 ^ nil
 !
 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.
 (#( 'self' 'super' 'thisContext' 'here') includes:nm) ifTrue:[
 ^ Explainer explainPseudoVariable:nm in:cls short:short
 definingNode := node whoDefines:nm.
 definingNode notNil ifTrue:[
 namePart := '''' , nmBold , ''''.
 definingNode isMethod ifTrue:[
-(definingNode arguments contains:[:arg | arg name = nm]) ifTrue:[
+argNode := definingNode arguments detect:[:arg | arg name = nm] ifNone:nil.
-expl := namePart , ' is a method argument.'
+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:[
 definingNode isBlock ifTrue:[
 (definingNode arguments contains:[:arg | arg name = nm]) ifTrue:[
 !
 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.
 methodComment := lines first.
 methodComment := methodComment withoutSeparators.
 c := aClass whichClassDefinesInstVar:string.
 c notNil ifTrue:[
 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
 ].
 val := aClass theNonMetaclass instVarNamed:string.
 "classvars"
 c := explainer inWhichClassIsClassVar:string.
 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
 ].
 "private classes"
 c := aClass theNonMetaclass.
 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
 ].
 ^ stringText withCRs
 sharedPool isSharedPool ifFalse:[
 ^ 'oops - not a shared pool: ',eachPoolName
 ].
 (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.
 ^ stringText , ' (' , valString , ').'
 ].
 "namespace & global variables"
 (spc := aClass nameSpace) notNil ifTrue:[
 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,', '
 ].
 cls isSharedPool ifTrue:[
 "Created: / 28-02-2012 / 10:44:55 / cg"
 !
 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.
 self addTypesOfInstvar:instVarName inClass:aClass fromExistingInstancesTo:setOfTypes.
 "/ look for assignments
 shortText ifTrue:[
 tmp := ' is implemented in '.
 ] ifFalse:[
 tmp := ' is a selector implemented in '.
 ].
-s := "'#' ," string allBold.
+s := string allBold.
-s := s actionForAll:(self actionToBrowseImplementorsOf:selector).
+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:[
 t := firstImplementingClassName.
 firstImplementingClass isMeta ifTrue:[
 |superName|
 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.
 However, when sending a message to "super", the search for methods
 ^ self explainSyntax:string short:false
 !
 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>
 ":=" and "_" (which is left-arrow in some fonts) mean assignment.
 "|" is also a selector understood by Booleans.'
 ].
 (string startsWith:'$' ) ifTrue:[
 shortText ifTrue:[
-^ '"$x" - character literal (syntax)'.
+^ '"$x" - ',(self asClassLink:'Character'),' literal (syntax)'.
 ].
 ^ 'is a Character literal constant.
 Character objects represent indivdual text cheracters in Unicode encoding.
 For example, $a is the character "a" with an encoding of 97 "hex: 16r61".
 ].
 (string startsWith:'#' ) ifTrue:[
 (string startsWith:'#(' ) ifTrue:[
 shortText ifTrue:[
-^ '"#(..)" - array literal (syntax)'.
+^ '"#(..)" - ',(self asClassLink:'Array'),' literal (syntax)'.
 ].
 ^ 'is a constant Array (literal).
 The array-object is created at compilation time and a reference to this is
 used at execution time (thus, the same object is referred to every time).
 element in an Array-constant).'
 ].
 (string startsWith:'#[') ifTrue:[
 shortText ifTrue:[
-^ '"#[..]" - byteArray literal (syntax)'.
+^ '"#[..]" - ',(self asClassLink:'ByteArray'),' literal (syntax)'.
 ].
 ^ 'is a constant ByteArray (literal).
 The elements of a constant ByteArray must be Integer constants in the range
 0 .. 255.
 (notice, that not all Smalltalk implementations support constant ByteArrays).'
 ].
 (string startsWith:'#''') ifTrue:[
 shortText ifTrue:[
-^ '"#''..''" - symbol literal (syntax)'.
+^ '"#''..''" - ',(self asClassLink:'Symbol'),' literal (syntax)'.
 ].
 ^ 'is a constant symbol containing non-alphanumeric characters.
 Symbols are unique strings, meaning that there exists
 exactly one instance of a given symbol. Therefore symbols can
 be compared using == (identity compare) in addition to = (contents compare).
 Beside this, Symbols behave mostly like Strings but are immutable.'
 ].
 shortText ifTrue:[
-^ '"#.." - symbol literal (syntax)'.
+^ '"#.." - ',(self asClassLink:'Symbol'),' literal (syntax)'.
 ].
 ^ 'is a constant symbol.
 Symbols are unique strings, meaning that there exists
 exactly one instance of a given symbol. Therefore symbols can
 with unary messages preceeding binary messages, preceeding keyword mesages.'
 ].
 ((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]
 defines a block.
 Blocks represent pieces of executable code. The definition of a block does
 Blocks are also often used as callbacks from UI components or as exception handlers.'
 ].
 ((string startsWith:'{') or:[string endsWith:'}']) ifTrue:[
 shortText ifTrue:[
-^ '"{..}" array instantiation (syntax)'.
+^ '"{..}" ',(self asClassLink:'Array'),' instantiation (syntax)'.
 ].
 ^ '{ <expr1>. .. <exprN> }
 This is syntactic sugar for "Array with:<expr1> .. with:<exprN>".
 !
 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.
 setOfTypes isEmpty ifTrue:[^ nil].
 types sortBySelector:#name.
 "/ 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
 |valString|
 ! !
 !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:[
 val := expr value.
 valClass := val class.
 self rememberType:valClass in:setOfTypes.
 ^ setOfTypes.
 ].
 expr isMessage ifTrue:[
-msgSelector := expr selector.
+self addTypeOfMessageNode:expr forAssignmentTo:varName to:setOfTypes.
-msgReceiver := expr receiver.
+^ setOfTypes.
+].
-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.
-].
-( #(// 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 |
 code := aMethod source.
 "Created: / 30-04-2016 / 15:07:33 / cg"
 !
 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|
 "/ quick check (avoids expensive parse)
 "Created: / 30-04-2016 / 15:09:18 / cg"
 !
 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 |
 self addTypesAssignedToInstvar:instVarName inClass:aClass method:m to:setOfTypes
 ].
 "Created: / 30-04-2016 / 14:52:56 / cg"
 !
 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|
 visitor := PluggableParseNodeVisitor new.
 visitor
 actionForNodeClass:AssignmentNode
 put:[:node |
-|leftSide expr|
+(node variable isInstanceVariableNamed:instVarName) ifTrue:[
+self addTypeOfExpressionNode:(node expression) forAssignmentTo:instVarName to:setOfTypes
-leftSide := node variable.
-(leftSide isInstanceVariable and:[ leftSide name = instVarName ]) ifTrue:[
-expr := node expression.
-self addTypeOfExpressionNode:expr forAssignmentTo:instVarName to:setOfTypes
 ].
 true "/ yes - visit subnodes
 ].
 visitor visit:tree.
 !
 addTypesAssignedToLocal:localName inTree:tree to:setOfTypes
-"look to asssignments to an instance variable, and pick up low hanging class information.
+"look to asssignments to a local 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|
 "/ hack, allowing to deal with both types of AST (sigh)
 (tree isKindOf:(Smalltalk at:#RBProgramNode)) ifTrue:[
 visitor := (Smalltalk at:#RBPluggableProgramNodeVisitor) new.
 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:(node value) forAssignmentTo:localName to:setOfTypes
-self addTypeOfExpressionNode:expr forAssignmentTo:localName to:setOfTypes
 ].
 true "/ yes - visit subnodes
 ].
 visitor visitNode:tree.
 ] ifFalse:[
 "Modified: / 30-04-2016 / 20:05:09 / cg"
 ! !
 !Explainer class methodsFor:'utilities'!
+actionToBrowseClass:class
+^ self actionToBrowseClass:class selector:nil.
+!
 actionToBrowseClass:class selector:selectorOrNil
-selectorOrNil isNil ifTrue:[
+^ [
-^ [Tools::NewSystemBrowser openInClass:class]
+self thisOrNewBrowserInto:[:browser :openHow |
-] ifFalse:[
+browser
-^ [Tools::NewSystemBrowser openInClass:class selector:selectorOrNil]
+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
-actionToBrowseImplementorsOf:selector
+spawnClassBrowserFor:classes in:openHow
+]
+]
+"/ ^ [Tools::NewSystemBrowser browseClasses:classes]
+!
+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'!
 version

branch	jv
changeset 3873	707275c1f86d
parent 3841	a22f33410bdf
parent 3861	214e93764392
child 3874	4f9db2d4c2b7