--- a/Explainer.st Sat Apr 30 14:41:53 2016 +0200
+++ b/Explainer.st Sat Apr 30 17:15:35 2016 +0200
@@ -64,18 +64,20 @@
(literalValue isInteger) ifTrue:[
(literalValue ~~ 0 and:[literalValue ~~ 1]) ifTrue:[
expl := expl , ' ('.
- #(2 10 16) with:#('binary: ' 'decimal: ' 'hex: ')do:[:base :baseExpl |
+ #(2 10 16) with:#('binary: ' 'decimal: ' 'hex: ') do:[:base :baseExpl |
|bStr|
base ~= (node token radix ? 10) ifTrue:[
bStr := base==10
ifTrue:[literalValue printString]
- ifFalse:[literalValue radixPrintStringRadix:base].
+ ifFalse:[(literalValue printStringRadix:base) leftPaddedTo:2 with:$0]. "/ looks better: at least a size of 2
+ "/ oops - someone looks at a largeInteger
+ bStr := bStr contractAtEndTo:40.
expl := expl , ' ' , baseExpl, bStr
].
].
expl := expl , ' )'.
- ].
+ ].
^ expl.
].
(literalValue isCharacter) ifTrue:[
@@ -134,7 +136,7 @@
^ expl
- "Modified: / 09-10-2006 / 12:09:43 / cg"
+ "Modified (format): / 30-04-2016 / 16:00:05 / cg"
!
explainMessageNode:node in:code forClass:cls short:short interval:intervalIfKnown
@@ -250,39 +252,39 @@
info := Explainer explainSelector:selector inClass:cls short:short.
].
- implementingClasses notEmptyOrNil ifTrue:[
- implMethods := implementingClasses collect:[:implClass | implClass compiledMethodAt:selector].
- implMethods size <= 8 ifTrue:[
- implMethods size < 4 ifTrue:[
- "/ show full comments
- comments := implMethods
- collect:[:implMethod | implMethod comment]
- thenSelect:[:comment | comment notEmptyOrNil].
- ] ifFalse:[
- "/ show first lines one
- comments := implMethods
- collect:[:implMethod | (self fetchCommentOfMethod:implMethod)]
- thenSelect:[:comment | comment notEmptyOrNil].
- ].
- comments := comments collect:[:each | each colorizeAllWith:(UserPreferences current commentColor) ].
- short ifTrue:[
- comments := comments collect:[:implMethodComment | implMethodComment firstLine] as:Set.
- comments size == 1 ifTrue:[
- ^ info , ' ' , (comments first).
- ].
- ^ info
- ].
- info := info,'\'withCRs.
- comments
- with:implementingClasses
- do:[:eachComment :eachClass |
- info := info,'\comment in ',eachClass name,':\',(eachComment asStringCollection asString)
- ].
- ].
- ].
+"/ implementingClasses notEmptyOrNil ifTrue:[
+"/ implMethods := implementingClasses collect:[:implClass | implClass compiledMethodAt:selector].
+"/ implMethods size <= 8 ifTrue:[
+"/ implMethods size < 4 ifTrue:[
+"/ "/ show full comments
+"/ comments := implMethods
+"/ collect:[:implMethod | implMethod comment]
+"/ thenSelect:[:comment | comment notEmptyOrNil].
+"/ ] ifFalse:[
+"/ "/ show first lines one
+"/ comments := implMethods
+"/ collect:[:implMethod | (self fetchCommentOfMethod:implMethod)]
+"/ thenSelect:[:comment | comment notEmptyOrNil].
+"/ ].
+"/ comments := comments collect:[:each | each colorizeAllWith:(UserPreferences current commentColor) ].
+"/ short ifTrue:[
+"/ comments := comments collect:[:implMethodComment | implMethodComment firstLine] as:Set.
+"/ comments size == 1 ifTrue:[
+"/ ^ info , ' ' , (comments first).
+"/ ].
+"/ ^ info
+"/ ].
+"/ info := info,'\'withCRs.
+"/ comments
+"/ with:implementingClasses
+"/ do:[:eachComment :eachClass |
+"/ info := info,'\comment in ',eachClass name,':\',(eachComment asStringCollection asString)
+"/ ].
+"/ ].
+"/ ].
^ info
- "Modified: / 06-02-2007 / 19:26:11 / cg"
+ "Modified: / 30-04-2016 / 17:08:11 / cg"
!
explainMethodNode:node in:code forClass:cls short:short interval:intervalIfKnown
@@ -460,6 +462,8 @@
!
fetchCommentOfMethod:mthd
+ "retrieve the comment of a method (if possible and there is one; otherwise, return nil)"
+
|methodComment lines|
"/ with wait cursor, because it accesses sourcecode (via SCM)
@@ -479,6 +483,7 @@
^ ('"' , methodComment , '"') colorizeAllWith:(UserPreferences current commentColor).
"Created: / 14-09-2006 / 14:11:58 / cg"
+ "Modified (comment): / 30-04-2016 / 16:17:18 / cg"
!
guessPossibleImplementorClassesFor:node in:code forClass:cls
@@ -552,14 +557,6 @@
!Explainer class methodsFor:'explaining-naive'!
-commonSuperClassOf:listOfClassesOrClassNames
- <resource: #obsolete>
-
- ^ Behavior commonSuperclassOf:listOfClassesOrClassNames
-
- "Modified (format): / 28-02-2012 / 09:00:37 / cg"
-!
-
explain:someText in:source forClass:aClass
"Given a source and a substring of it, return a string containing
an explanation.
@@ -586,8 +583,7 @@
Also, there could be much more detailed explanations."
|explainer variables c string explanation tmp1
- spc sym sel stringText cls clsName val valString
- instIndex setOfTypes toRemove toAdd|
+ spc sym sel stringText cls clsName val valString|
string := someText string withoutSeparators.
string isEmpty ifTrue:[ ^ nil ].
@@ -635,122 +631,7 @@
valString := self valueStringFor:val.
^ stringText , ' (' , valString , ').'
].
-
- clsName := c name.
- shortText ifTrue:[
- stringText := stringText , ': an instVar in ' , clsName , '.'
- ] ifFalse:[
- stringText := stringText , ': an instance variable inherited from ' , clsName , '.'
- ].
- "/ look for instances
- setOfTypes := IdentitySet new.
- instIndex := c instVarIndexFor:string.
- c allSubInstancesDo:[:i |
- |varClass|
- varClass := (i instVarAt:instIndex) class.
- setOfTypes add:varClass.
- ].
- "/ TODO: look for assignments
- c withAllSubclassesDo:[:cls |
- cls methodDictionary do:[:m |
- |tree code visitor|
-
- "/ quick check
- code := m source.
- (code notNil and:[code includesString:string]) ifTrue:[
- tree := Parser parse:code class:cls.
- (tree notNil and:[tree ~~ #Error]) ifTrue:[
- visitor := PluggableParseNodeVisitor new.
- visitor
- actionForNodeClass:AssignmentNode
- put:[:node |
- |val|
-
- node variable name = string ifTrue:[
- "/ only look for wellknown types on the right side.
- node expression isConstant ifTrue:[
- val := node expression evaluate.
- val isArray ifTrue:[
- setOfTypes add:Array
- ] ifFalse:[
- setOfTypes add:val class
- ].
- ] ifFalse:[
- node expression isMessage ifTrue:[
- ( #(+ - * /) includes:node expression selector ) ifTrue:[
- setOfTypes add:Number
- ] ifFalse:[
- ( #(// size) includes:node expression selector ) ifTrue:[
- setOfTypes add:Integer
- ] ifFalse:[
- ( #(copy shallowCopy) includes:node expression selector ) ifTrue:[
- ] ifFalse:[
- ( #(new new: basicNew basicNew:) includes:node expression selector ) ifTrue:[
- node expression receiver isGlobal ifTrue:[
- setOfTypes add:node expression receiver evaluate
- ].
- ] ifFalse:[
-self breakPoint:#cg.
- ]
- ]
- ]
- ]
- ].
- ].
- ].
- true "/ yes - visit subnodes
- ].
- visitor visit:tree.
- ].
- ]
- ]
- ].
-
- "/ reduce...
- toAdd := Set new.
- toRemove := Set new.
- setOfTypes do:[:type1 |
- setOfTypes do:[:type2 |
- |common|
-
- type1 superclass == type2 ifTrue:[
- toRemove add:type1.
- ] ifFalse:[
- type2 superclass == type1 ifTrue:[
- toRemove add:type2.
- ] ifFalse:[
- common := type1 commonSuperclass:type2.
- common ~~ Object ifTrue:[
- toRemove add:type1.
- toRemove add:type2.
- toAdd add:common.
- ].
- ].
- ].
- ]
- ].
- setOfTypes removeAll:toRemove.
- setOfTypes addAll:toRemove.
- setOfTypes := setOfTypes collect:#name as:OrderedCollection.
- setOfTypes sort.
- setOfTypes size == 1 ifTrue:[
- stringText := stringText,' (',setOfTypes first,')'
- ] ifFalse:[
- setOfTypes size == 2 ifTrue:[
- stringText := stringText,' (',setOfTypes first,' or ',setOfTypes second,')'
- ] ifFalse:[
- setOfTypes size == 3 ifTrue:[
- stringText := stringText,' (',setOfTypes first,', ',setOfTypes second,' or ',setOfTypes third,')'
- ] ifFalse:[
- setOfTypes size == 0 ifTrue:[
- stringText := stringText,(' (type unknown)' bindWith:setOfTypes size)
- ] ifFalse:[
- stringText := stringText,(' (one of %1 types)' bindWith:setOfTypes size)
- ].
- ].
- ].
- ].
- ^ stringText
+ ^ self explainInstanceVariable:string inClass:c short:shortText.
].
string isWideString ifFalse:[
@@ -877,7 +758,7 @@
"Created: / 03-12-1995 / 12:47:37 / cg"
"Modified: / 16-04-1997 / 12:46:11 / stefan"
- "Modified: / 27-07-2013 / 09:53:30 / cg"
+ "Modified: / 30-04-2016 / 15:00:28 / cg"
!
explainGlobal:string inClass:aClass short:shortText
@@ -1030,6 +911,50 @@
"Created: / 28-02-2012 / 10:44:55 / cg"
!
+explainInstanceVariable:instVarName inClass:aClass short:shortText
+ |template stringText setOfTypes|
+
+ shortText ifTrue:[
+ template := '%1: an instVar in %2'
+ ] ifFalse:[
+ template := '%1: an instance variable in %2'
+ ].
+ stringText := template bindWith:instVarName allBold with:aClass name.
+
+ "/ look for instances
+ setOfTypes := IdentitySet new.
+ self addTypesOfInstvar:instVarName inClass:aClass fromExistingInstancesTo:setOfTypes.
+ "/ look for assignments
+ aClass withAllSubclassesDo:[:cls | self addTypesAssignedToInstvar:instVarName inClass:cls to:setOfTypes].
+
+ "/ reduce...
+ self compressSetOfTypes:setOfTypes.
+ setOfTypes := setOfTypes collect:#name as:OrderedCollection.
+ setOfTypes sort.
+
+ "/ now make this a nice string
+ setOfTypes size == 1 ifTrue:[
+ stringText := stringText,' (',setOfTypes first,')'
+ ] ifFalse:[
+ setOfTypes size == 2 ifTrue:[
+ stringText := stringText,' (',setOfTypes first,' or ',setOfTypes second,')'
+ ] ifFalse:[
+ setOfTypes size == 3 ifTrue:[
+ stringText := stringText,' (',setOfTypes first,', ',setOfTypes second,' or ',setOfTypes third,')'
+ ] ifFalse:[
+ setOfTypes size == 0 ifTrue:[
+ stringText := stringText,(' (type unknown)' bindWith:setOfTypes size)
+ ] ifFalse:[
+ stringText := stringText,(' (one of %1 types)' bindWith:setOfTypes size)
+ ].
+ ].
+ ].
+ ].
+ ^ stringText
+
+ "Created: / 30-04-2016 / 14:59:22 / cg"
+!
+
explainKnownSymbol:string inClass:aClass
"return an explanation or nil"
@@ -1131,9 +1056,12 @@
explainSelector:string inClass:aClass short:shortText
"return an explanation or nil"
- |sym listOfImplementingClasses listOfSimilarSelectors
+ |sym listOfImplementingClasses listOfImplementingClassNames listOfSimilarSelectors
firstImplementingClassOfSimilar count tmp commonSuperClass s s2
- firstImplementingClass cm msg t check|
+ firstImplementingClass
+ firstImplementingClassName secondImplementingClassName thirdImplementingClassName
+ classProvidingComment
+ cm msg t check|
sym := string asSymbolIfInterned.
sym isNil ifTrue:[^ nil].
@@ -1142,15 +1070,18 @@
try selectors
look who implements it
"
+ listOfImplementingClassNames := Set new.
listOfImplementingClasses := Set new.
listOfSimilarSelectors := Set new.
check :=
[:sel :mthd :cls |
sel == sym ifTrue:[
- listOfImplementingClasses add:(cls name).
+ listOfImplementingClasses add:cls.
+ listOfImplementingClassNames add:(cls name).
firstImplementingClass isNil ifTrue:[
- firstImplementingClass := cls
+ firstImplementingClass := cls.
+ firstImplementingClassName := cls name.
]
] ifFalse:[
(sel startsWith:sym) ifTrue:[
@@ -1183,13 +1114,13 @@
s2 := ''.
].
- count := listOfImplementingClasses size.
+ count := listOfImplementingClassNames size.
(count ~~ 0) ifTrue:[
"
for up-to 4 implementing classes,
list them
"
- listOfImplementingClasses := listOfImplementingClasses asOrderedCollection sort.
+ listOfImplementingClassNames := listOfImplementingClassNames asOrderedCollection sort.
shortText ifTrue:[
tmp := ' is implemented in '.
] ifFalse:[
@@ -1198,7 +1129,8 @@
s := "'#' ," string allBold.
(count == 1) ifTrue:[
- (t := listOfImplementingClasses first) isMeta ifTrue:[
+ t := firstImplementingClassName.
+ firstImplementingClass isMeta ifTrue:[
t := 'the ' , t
].
msg := s , tmp , t , '.'.
@@ -1206,21 +1138,24 @@
msg := msg , s2.
]
] ifFalse:[
+ firstImplementingClassName := listOfImplementingClassNames at:1.
+ secondImplementingClassName := listOfImplementingClassNames at:2.
(count == 2) ifTrue:[
- msg := s,tmp,(listOfImplementingClasses at:1),' and ',(listOfImplementingClasses at:2),'.'.
+ msg := s,tmp,firstImplementingClassName,' and ',secondImplementingClassName,'.'.
shortText ifFalse:[
msg := msg , s2.
].
] ifFalse:[
+ thirdImplementingClassName := listOfImplementingClassNames at:3.
(count == 3) ifTrue:[
- msg := s,tmp,(listOfImplementingClasses at:1),',',(listOfImplementingClasses at:2),' and ',(listOfImplementingClasses at:3),'.'.
+ msg := s,tmp,firstImplementingClassName,',',secondImplementingClassName,' and ',thirdImplementingClassName,'.'.
shortText ifFalse:[
msg := msg , s2.
].
] ifFalse:[
- shortText ifTrue:[
+ false "shortText" ifTrue:[
msg := s , tmp , count printString , ' classes'.
- commonSuperClass := Class commonSuperclassOf:listOfImplementingClasses.
+ commonSuperClass := Class commonSuperclassOf:listOfImplementingClassNames.
commonSuperClass notNil ifTrue:[
(commonSuperClass == Object
and:[commonSuperClass includesSelector:sym]) ifTrue:[
@@ -1235,87 +1170,98 @@
^ msg
].
- (count == 3) ifTrue:[
- msg := s , tmp , '
-' , (listOfImplementingClasses at:1) , ', ' , (listOfImplementingClasses at:2) , ' and ' , (listOfImplementingClasses at:3) , '.' , s2
- ] ifFalse:[
- (count == 4) ifTrue:[
- msg := s , tmp , '
-' , (listOfImplementingClasses at:1) , ', ' , (listOfImplementingClasses at:2) , ', ' , (listOfImplementingClasses at:3), ' and ' , (listOfImplementingClasses at:4) , '.' , s2
+ "
+ if there are more, look for a common
+ superclass and show it ...
+ "
+ commonSuperClass := Behavior commonSuperclassOf:listOfImplementingClasses.
+ (commonSuperClass ~~ Object
+ and:[commonSuperClass ~~ Behavior
+ and:[commonSuperClass ~~ Class
+ and:[commonSuperClass ~~ ClassDescription]]]) ifTrue:[
+ (listOfImplementingClasses includes:commonSuperClass) ifTrue:[
+ msg := s . tmp , count printString , commonSuperClass name
+ , ' and redefined in ' , (count - 1) printString
+ , ' subclasses'
+ , s2.
+ firstImplementingClass := commonSuperClass
] ifFalse:[
- "
- if there are more, look for a common
- superclass and show it ...
- "
- commonSuperClass := Behavior commonSuperclassOf:listOfImplementingClasses.
- (commonSuperClass ~~ Object
- and:[commonSuperClass ~~ Behavior
- and:[commonSuperClass ~~ Class
- and:[commonSuperClass ~~ ClassDescription]]]) ifTrue:[
- (listOfImplementingClasses includes:commonSuperClass) ifTrue:[
- msg := s . tmp , count printString , commonSuperClass name
- , ' and redefined in ' , (count - 1) printString
- , ' subclasses'
- , s2.
- firstImplementingClass := commonSuperClass
- ] ifFalse:[
- msg := s , tmp, count printString , ' subclasses of ' , commonSuperClass name , s2
- ]
+ msg := s , tmp, count printString , ' subclasses of ' , commonSuperClass name , s2
+ ]
+ ] ifFalse:[
+ (commonSuperClass == Object
+ and:[commonSuperClass includesSelector:sym]) ifTrue:[
+ shortText ifTrue:[
+ msg := s , tmp , count printString , ' classes (incl. Object)'.
] ifFalse:[
- (commonSuperClass == Object
- and:[commonSuperClass includesSelector:sym]) ifTrue:[
- msg := s , tmp , count printString , ' classes.
+ msg := s , tmp , count printString , ' classes.
All objects seem to respond to that message,
since there is an implementation in Object.' , s2.
-
- firstImplementingClass := Object
+ ].
+ firstImplementingClass := Object
+ ] ifFalse:[
+ ((commonSuperClass == Behavior
+ or:[commonSuperClass == Class
+ or:[commonSuperClass == ClassDescription]])
+ and:[commonSuperClass includesSelector:sym]) ifTrue:[
+ shortText ifTrue:[
+ msg := s , tmp , count printString , ' classes (incl. all classes)'.
] ifFalse:[
- ((commonSuperClass == Behavior
- or:[commonSuperClass == Class
- or:[commonSuperClass == ClassDescription]])
- and:[commonSuperClass includesSelector:sym]) ifTrue:[
- msg := s , tmp , count printString , ' classes.
+ msg := s , tmp , count printString , ' classes.
All classes seem to respond to that message,
since there is an implementation in ' , commonSuperClass name , '.' , s2.
-
- firstImplementingClass := commonSuperClass
- ] ifFalse:[
- "
- otherwise just give the number.
- "
- msg := s , tmp , count printString , ' classes.' , s2
- ]
- ]
+ ].
+ firstImplementingClass := commonSuperClass
+ ] ifFalse:[
+ "
+ otherwise just give the number.
+ "
+ msg := s , tmp , count printString , ' classes.' , s2
]
]
]
]
].
].
- shortText ifTrue:[
- count == 1 ifTrue:[
- cm := self fetchCommentOfMethod:(firstImplementingClass compiledMethodAt:sym).
- cm notNil ifTrue:[
- msg := msg,'',cm
- ].
- ].
+ "/ look for a comment...
+ count == 1 ifTrue:[
+ classProvidingComment := firstImplementingClass.
] ifFalse:[
-"/ firstImplementingClass notNil ifTrue:[
-"/ WindowGroup activeGroup withWaitCursorDo:[
-"/ cm := self fetchCommentOfMethod:(firstImplementingClass compiledMethodAt:sym).
-"/ ].
-"/ cm notNil ifTrue:[
-"/ msg := msg , '\\The comment in ' withCRs
-"/ , firstImplementingClass name "allBold" , ' is:\' withCRs
-"/ , '"' , cm allItalic , '"'.
-"/ ]
-"/ ].
+ commonSuperClass isNil ifTrue:[
+ commonSuperClass := Behavior commonSuperclassOf:listOfImplementingClasses.
+ ] .
+ (listOfImplementingClasses includes:commonSuperClass) ifTrue:[
+ classProvidingComment := commonSuperClass
+ ].
+ ].
+ classProvidingComment notNil ifTrue:[
+ cm := self fetchCommentOfMethod:(classProvidingComment compiledMethodAt:sym).
+ ].
+ cm isNil ifTrue:[
+ "/ should: find the class with most subclasses from the list
+ (listOfImplementingClasses includes:Collection) ifTrue:[
+ classProvidingComment := Collection
+ ] ifFalse:[
+ (listOfImplementingClasses includes:Stream) ifTrue:[
+ classProvidingComment := Stream
+ ] ifFalse:[
+ classProvidingComment := listOfImplementingClasses detect:[:cls | (self fetchCommentOfMethod:(cls compiledMethodAt:sym)) notNil] ifNone:nil.
+ ]
+ ].
+ classProvidingComment notNil ifTrue:[
+ cm := self fetchCommentOfMethod:(classProvidingComment compiledMethodAt:sym).
+ cm := (' %1 says: ' bindWith:classProvidingComment name),cm
+ ].
+ ].
+ cm notNil ifTrue:[
+ msg := msg,(msg last isSeparator ifTrue:[''] ifFalse:[' ']),cm
].
^ msg
].
+ "/ none implements it (type?);
count := listOfSimilarSelectors size.
(count ~~ 0) ifTrue:[
listOfSimilarSelectors := listOfSimilarSelectors asOrderedCollection sort.
@@ -1343,7 +1289,7 @@
"Modified: / 17-06-1996 / 17:09:30 / stefan"
"Created: / 23-03-1999 / 13:29:33 / cg"
- "Modified: / 27-07-2013 / 09:59:46 / cg"
+ "Modified: / 30-04-2016 / 17:04:30 / cg"
!
explainSelfIn:aClass short:shortText
@@ -1722,6 +1668,200 @@
"Modified: / 14-10-2010 / 11:57:52 / cg"
! !
+!Explainer class methodsFor:'naive type inferer'!
+
+addTypeOfExpressionNode:expr forAssignmentTo:varName to:setOfTypes
+ |val valClass msgSelector msgReceiver|
+
+ "/ only look for wellknown types on the right side.
+ expr isConstant ifTrue:[
+ val := expr evaluate.
+ val isImmutable ifTrue:[
+ valClass := val class mutableClass
+ ] ifFalse:[
+ valClass := val class
+ ].
+ self rememberType:valClass in:setOfTypes.
+ ^ self.
+ ].
+
+ expr isMessage ifTrue:[
+ msgSelector := expr selector.
+ msgReceiver := expr receiver.
+
+ msgSelector == #? ifTrue:[
+ self addTypeOfExpressionNode:(expr arg1) forAssignmentTo:varName to:setOfTypes.
+ ^ self
+ ].
+ "/ really really only low hanging fruit...
+ ( #(+ - * /) 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.
+ ]
+ ].
+ ^ self.
+ ].
+
+ ( #(// size hash identityHash) includes:msgSelector ) ifTrue:[
+ self rememberType:Integer in:setOfTypes.
+ ^ self.
+ ].
+
+ ( #(copy shallowCopy) includes:msgSelector ) ifTrue:[
+ msgReceiver isConstant ifTrue:[
+ self addTypeOfExpressionNode:msgReceiver forAssignmentTo:varName to:setOfTypes.
+ ].
+ ^ self
+ ].
+
+ msgReceiver isGlobal ifTrue:[
+ |globalValue|
+
+ globalValue := msgReceiver evaluate.
+ globalValue isBehavior ifTrue:[
+ ( #(new new: basicNew basicNew:) includes:msgSelector ) ifTrue:[
+ self rememberType:globalValue in:setOfTypes.
+ ^ self.
+ ].
+ ].
+self breakPoint:#cg.
+ ] ifFalse:[
+self breakPoint:#cg.
+ ]
+ ].
+
+ "Created: / 30-04-2016 / 15:28:59 / cg"
+!
+
+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
+ and info in the browser."
+
+ | code |
+
+ code := aMethod source.
+ (code notNil) ifTrue:[
+ self addTypesAssignedToInstvar:instVarName inClass:aClass source:code to:setOfTypes
+ ]
+
+ "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
+ and info in the browser."
+
+ |tree visitor|
+
+ "/ quick check (avoids expensive parse)
+ (code includesString:instVarName) ifFalse:[ ^ self ].
+
+ tree := Parser parse:code class:aClass.
+ (tree isNil or:[tree == #Error]) ifTrue:[ ^ self ]. "/ unparsable
+
+ visitor := PluggableParseNodeVisitor new.
+ 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
+ ].
+ true "/ yes - visit subnodes
+ ].
+ visitor visit:tree.
+
+ "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
+ 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"
+!
+
+addTypesOfInstvar:instVarName inClass:aClass fromExistingInstancesTo:setOfTypes
+ "look for existing instances and see that type is there"
+
+ |instIndex|
+
+ instIndex := aClass instVarIndexFor:instVarName.
+ aClass allSubInstancesDo:[:i |
+ |varClass|
+
+ varClass := (i instVarAt:instIndex) class.
+ self rememberType:varClass in:setOfTypes.
+ ].
+
+ "Created: / 30-04-2016 / 14:56:11 / cg"
+!
+
+compressSetOfTypes:setOfTypes
+ |toAdd toRemove|
+
+ "/ reduce by eliminating common superclasses...
+
+ toAdd := Set new.
+ toRemove := Set new.
+ setOfTypes do:[:type1 |
+ setOfTypes do:[:type2 |
+ |common|
+
+ type1 superclass == type2 ifTrue:[
+ toRemove add:type1.
+ ] ifFalse:[
+ type2 superclass == type1 ifTrue:[
+ toRemove add:type2.
+ ] ifFalse:[
+ common := type1 commonSuperclass:type2.
+ common ~~ Object ifTrue:[
+ toRemove add:type1.
+ toRemove add:type2.
+ toAdd add:common.
+ ].
+ ].
+ ].
+ ]
+ ].
+ setOfTypes removeAll:toRemove.
+ setOfTypes addAll:toRemove.
+
+ "/ hack
+ setOfTypes size == 2 ifTrue:[
+ ((setOfTypes includes:True) and:[setOfTypes includes:False]) ifTrue:[
+ setOfTypes removeAll; add:Boolean.
+ ^ self.
+ ].
+ ((setOfTypes includes:SmallInteger) and:[setOfTypes includes:LargeInteger]) ifTrue:[
+ setOfTypes removeAll; add:Integer.
+ ^ self.
+ ]
+ ].
+
+ "Created: / 30-04-2016 / 15:37:38 / cg"
+!
+
+rememberType:aClass in:setOfTypes
+aClass == UndefinedObject ifTrue:[self halt].
+ setOfTypes add:aClass
+
+ "Created: / 30-04-2016 / 15:35:44 / cg"
+! !
+
!Explainer class methodsFor:'documentation'!
version