--- /dev/null Thu Jan 01 00:00:00 1970 +0000
+++ b/SmallSense__SmalltalkInferencer.st Wed Jan 14 08:28:46 2015 +0000
@@ -0,0 +1,728 @@
+"
+stx:goodies/smallsense - A productivity plugin for Smalltalk/X IDE
+Copyright (C) 2013-2014 Jan Vrany
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+"
+"{ Package: 'stx:goodies/smallsense' }"
+
+"{ NameSpace: SmallSense }"
+
+Object subclass:#SmalltalkInferencer
+ instanceVariableNames:'type class classInfo source parser parserClass tree environment'
+ classVariableNames:''
+ poolDictionaries:''
+ category:'SmallSense-Smalltalk-Types-Inference'
+!
+
+SmalltalkParseNodeVisitor subclass:#Phase1
+ instanceVariableNames:'classInfo sends types'
+ classVariableNames:''
+ poolDictionaries:'SmallSense::SmalltalkInferencerParameters'
+ privateIn:SmalltalkInferencer
+!
+
+SmalltalkParseNodeVisitor subclass:#Phase2
+ instanceVariableNames:'classInfo'
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:SmalltalkInferencer
+!
+
+SmalltalkParseNodeVisitor subclass:#Phase3
+ instanceVariableNames:''
+ classVariableNames:''
+ poolDictionaries:''
+ privateIn:SmalltalkInferencer
+!
+
+!SmalltalkInferencer class methodsFor:'documentation'!
+
+copyright
+"
+stx:goodies/smallsense - A productivity plugin for Smalltalk/X IDE
+Copyright (C) 2013-2014 Jan Vrany
+
+This library is free software; you can redistribute it and/or
+modify it under the terms of the GNU Lesser General Public
+License as published by the Free Software Foundation; either
+version 2.1 of the License.
+
+This library is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+Lesser General Public License for more details.
+
+You should have received a copy of the GNU Lesser General Public
+License along with this library; if not, write to the Free Software
+Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
+"
+!
+
+documentation
+"
+ A heart of SmallSense - a type inferencer. For given class
+ and method source, instance of inferences walks the parse tree
+ and annotate each node with inferred type.
+
+
+ [author:]
+ Jan Vrany <jan.vrany@fit.cvut.cz>
+
+ [instance variables:]
+
+ [class variables:]
+
+ [see also:]
+
+"
+! !
+
+!SmalltalkInferencer class methodsFor:'instance creation'!
+
+forClass: class methodSource: source
+
+ ^self new class: class source: source
+
+ "Created: / 26-11-2011 / 12:45:49 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+forClass: class selector: selector
+
+ ^self new class: class selector: selector.
+
+ "Created: / 26-11-2011 / 12:44:48 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+forExpression: source
+
+ ^self new expression: source.
+
+ "Created: / 04-10-2013 / 08:12:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+forMethod: method
+
+ ^self new method: method.
+
+ "Created: / 26-11-2011 / 12:45:16 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer methodsFor:'accessing'!
+
+environment
+ ^ environment
+!
+
+environment:something
+ environment := something.
+!
+
+klass
+ ^ class
+
+ "Created: / 26-11-2011 / 17:30:35 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+manager
+
+ ^Manager instance
+
+ "Created: / 27-11-2011 / 16:16:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+parser
+ ^ parser
+!
+
+parserClass
+ ^ parserClass
+!
+
+parserClass:aClass
+ parserClass := aClass.
+!
+
+source
+ ^ source
+!
+
+tree
+ ^ tree
+! !
+
+!SmalltalkInferencer methodsFor:'initialization'!
+
+class: cls selector: sel
+
+ | m |
+ m := cls >> sel.
+ m isNil ifTrue:[
+ self error: 'No method found'.
+ ].
+ self method: m.
+
+ "Created: / 26-11-2011 / 12:47:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+class: cls source: src
+
+ type isNil ifTrue:[
+ "/ Guess...
+ type := cls notNil ifTrue:[ #method ] ifFalse:[ #expression ]
+ ].
+ class := cls ? UndefinedObject.
+ classInfo := self manager infoForClass: class.
+ source := src.
+
+ "Created: / 26-11-2011 / 14:46:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 04-10-2013 / 08:31:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+expression: expression
+
+ type := #expression.
+ self class: nil source: expression.
+
+ "Created: / 04-10-2013 / 08:14:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+method: method
+
+ type := #method.
+ self class: method mclass source: method source.
+
+ "Created: / 26-11-2011 / 12:48:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 04-10-2013 / 08:13:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer methodsFor:'private'!
+
+infer
+
+
+ Phase1 process: tree in: class.
+ Phase2 process: tree in: class.
+
+ "
+ (SmallSenseParseNodeInspector new node: tree source: source) open
+ "
+
+ "Created: / 26-11-2011 / 12:51:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 05-08-2014 / 14:04:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+parse
+
+ parserClass isNil ifTrue:[
+ parserClass := class parserClass.
+ ].
+ type == #method ifTrue:[
+ parser := parserClass
+ parseMethod: source in: class
+ ignoreErrors:true
+ ignoreWarnings:true.
+ tree := parser tree.
+ ] ifFalse:[
+ type == #expression ifTrue:[
+ parser := parserClass for: source.
+ tree := parser
+ parseExpressionWithSelf:nil
+ notifying:nil
+ ignoreErrors:false
+ ignoreWarnings:false
+ inNameSpace:nil.
+ parser tree: tree.
+ ].
+ ].
+
+ "Created: / 26-11-2011 / 12:51:31 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 04-10-2013 / 08:15:56 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer methodsFor:'processing'!
+
+process
+
+ "Actually infer types. Returns an annotated method tree.
+ The tree is also stored in an instance variable, so it
+ may be obtained form receiver any time by asking for #tree."
+
+ [
+ self parse.
+ ] on: Error do:[:ex|
+ Transcript showCR: ex description.
+ ^ self.
+ ].
+ tree notNil ifTrue:[
+ self infer.
+ ].
+ ^tree
+
+ "Created: / 26-11-2011 / 12:50:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 21-03-2014 / 19:00:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer::Phase1 class methodsFor:'documentation'!
+
+documentation
+"
+ Inferencing phase 1: guess type of variables based on message sends
+ (idea taken from RoelTyper).
+
+ Also, assign types for known variables (globals, literals, pseudo variables)
+
+ [author:]
+ Jan Vrany <jan.vrany@fit.cvut.cz>
+
+ [instance variables:]
+
+ [class variables:]
+
+ [see also:]
+
+"
+! !
+
+!SmalltalkInferencer::Phase1 methodsFor:'initialization'!
+
+initialize
+ "Invoked when a new instance is created."
+
+ "/ please change as required (and remove this comment)
+ sends := Dictionary new.
+ types := Dictionary new.
+
+ "/ super initialize. -- commented since inherited method does nothing
+
+ "Modified: / 26-11-2011 / 19:31:40 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer::Phase1 methodsFor:'private'!
+
+rootsUnderstanding: selectors
+ "When the set of selectors is not empty, answer a set of the highest possible classes in the system that implement all the selectors.
+ When the set of selectors is empty, return the empty set."
+
+ | initialClasses nextClasses traverseStack next |
+ selectors isEmpty ifTrue: [^OrderedCollection new].
+ nextClasses := OrderedCollection with: Object.
+ traverseStack := OrderedCollection new: 1000.
+
+ selectors
+ do:
+ [:selector |
+ initialClasses := nextClasses.
+ nextClasses := OrderedCollection new.
+ initialClasses
+ do:
+ [:initialClass |
+ "inline canUnderstand: for performance"
+ |cl|
+ cl := initialClass.
+ [(cl == nil) or: [(cl methodDictionary includesKey: selector)]] whileFalse: [cl := cl superclass].
+ (cl == nil)
+ ifFalse: [nextClasses addLast: initialClass]
+ ifTrue:
+ [|size|
+ traverseStack reset.
+ traverseStack addLast: initialClass.
+ size := 1.
+ "(traverseStack isEmpty) removed for performance"
+ [size = 0]
+ whileFalse:
+ [
+ "(traverseStack removeFirst) removed for performance"
+ next := traverseStack removeFirst.
+ size := size -1.
+ next
+ subclassesDo:
+ [:subcl |
+ "(subcl includesSelector: selector) removed for performance"
+ (subcl methodDictionary includesKey: selector)
+ ifTrue: [nextClasses addLast: subcl]
+ ifFalse: [traverseStack addLast: subcl. size := size + 1]]]]]].
+ ^nextClasses
+
+ "Modified: / 24-11-2010 / 14:39:35 / Jakub <zelenja7@fel.cvut.cz>"
+ "Modified: / 26-11-2011 / 14:01:32 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 18-09-2013 / 01:22:07 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer::Phase1 methodsFor:'processing'!
+
+process: tree in: cls
+
+ self process: tree in: cls info: (Manager instance infoForClass: cls)
+
+ "Created: / 26-11-2011 / 13:48:46 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+process: tree in: cls info: clsInfo
+
+ | i c def prereqs |
+
+ class := cls.
+ classInfo := clsInfo.
+
+ "/ Do not process if class is troublesome
+ classInfo isErrorneous ifTrue:[
+ ^ self.
+ ].
+ "Fill types with cached data..."
+
+ c := class.
+ i := classInfo.
+ [ c notNil and:[i notNil] ] whileTrue:[
+ c instVarNames do:[:nm|
+ types at: nm put: (i infoForInstvar: nm)
+ ].
+ c := c superclass.
+ i := i superclassInfo.
+ ].
+
+ self visit:tree.
+
+
+ prereqs := nil.
+ def := ProjectDefinition definitionClassForPackage: class package createIfAbsent: false.
+ def notNil ifTrue:[
+ prereqs := def effectivePreRequisites.
+ ].
+
+
+ "Now, infer variable types based on collected sends"
+ sends keysAndValuesDo:[:varName :sentSelectors|
+ (types includesKey: varName) ifTrue:[
+ | classes union |
+ classes := (self rootsUnderstanding: sentSelectors) collect:[:each | ClassType new klass: each ].
+
+ prereqs notNil ifTrue:[
+ "/ Make classes in packages on which method's package does **NOT** depend
+ "/ less likely to be correct (by lowering their trustfullness)
+ classes do:[:each |
+ (prereqs includes: each klass package) ifTrue:[
+ each trustfullnessAdd: -20
+ ].
+ ]
+ ].
+ union := UnionType new.
+ union addType: (types at: varName) type.
+ union addTypes: classes.
+ (types at: varName) type: union
+ ].
+ ].
+
+ "Created: / 27-11-2011 / 16:22:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 21-11-2014 / 17:19:09 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer::Phase1 methodsFor:'visiting'!
+
+visitAssignmentNode:anObject
+ | type |
+
+ self visit: anObject variable.
+ self visit: anObject expression.
+ type := anObject expression inferedType type.
+ type isUnknownType ifFalse:[
+ anObject variable inferedType union: type
+ ].
+
+ "Created: / 26-11-2011 / 13:53:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 18-09-2013 / 02:31:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitBlockNode:anObject
+ | type |
+
+ super visitBlockNode:anObject.
+ type := Type withClass: Block.
+ type trustfullness: 100.
+ anObject inferedType: type.
+
+ "Created: / 26-11-2011 / 14:46:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitConstantNode:anObject
+ "Type of a constant is trivially its value class"
+
+ | type |
+
+ super visitConstantNode: anObject.
+ type := (Type withClass: anObject value class).
+ type trustfullness: 100.
+ anObject inferedType: type.
+
+ "Created: / 26-11-2011 / 13:55:34 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitMessageNode:anObject
+
+ | rec |
+
+ super visitMessageNode: anObject.
+
+ (rec := anObject receiver) isVariableNode ifTrue:[
+ "We don't have to infer types for global/class variables"
+ (rec isGlobalVariable or:[rec isClassVariable]) ifTrue:[
+ "/ Check for pattern: `Smalltalk at: #ClassName`
+ (rec name = 'Smalltalk' and:[anObject arguments conform:[:node | node isConstant ] ]) ifTrue:[
+ | result |
+
+ "Here, evaluate the node, but only for certain known selectors!!
+ (think of selector #exit :-) - you'll laugh, but it hit me back hard
+ couple times...
+ "
+ (#( at:
+ classNamed:
+ "/ add more...
+ ) includes:anObject selector) ifTrue:[
+ [
+ result := anObject evaluate.
+ result notNil ifTrue:[
+ anObject inferedType: ((Type withClass: result class) trustfullness: 100)
+ ]
+ ] on: Error do:[
+ "/pass
+ ]
+ ]
+ ].
+ ] ifFalse:[
+ (sends at: rec name ifAbsentPut:[Set new]) add: anObject selector.
+ ].
+ ].
+
+ "Created: / 26-11-2011 / 13:02:28 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 04-10-2013 / 07:56:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitSelfNode:anObject
+ | type |
+
+ super visitSelfNode:anObject.
+ type := Type withClass: class.
+ type trustfullness: 100.
+ anObject inferedType:type
+
+ "Created: / 26-11-2011 / 14:43:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 18-09-2013 / 01:25:59 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitSuperNode:anObject
+ | superclass type |
+
+ super visitSuperNode:anObject.
+ superclass := class superclass.
+ type := superclass notNil ifTrue:[ Type withClass: class superclass ] ifFalse:[ Type unknown ].
+ type trustfullness: 100.
+ anObject inferedType:type
+
+ "Created: / 26-11-2011 / 14:44:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 24-11-2014 / 22:17:10 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitVariableNode:anObject
+
+ | t |
+
+ "Following code ensures, that all variable nodes refering same
+ variable shares the inferred type"
+ t := types at: anObject name ifAbsentPut:[Type unknown].
+ anObject inferedType: t.
+
+ anObject isGlobalVariable ifTrue:[
+ | globalName global globalClass |
+
+ globalName := anObject name asSymbolIfInterned.
+ globalName notNil ifTrue:[
+ global := Smalltalk at: globalName.
+
+ "/ Special hack for JAVA - its actually a JavaPackage...
+ global == (Smalltalk at: #JAVA) ifTrue:[
+ global := JavaPackage
+ ].
+ globalClass := global class.
+
+ global notNil ifTrue:[
+ t addClass: globalClass.
+ t trustfullness: 100.
+ ].
+ ].
+ ^self.
+ ].
+ anObject isClassVariable ifTrue:[
+ t addClass: (class theNonMetaclass classVarAt: anObject name asSymbol) class.
+ t trustfullness: 100.
+ ^self.
+ ].
+
+ "Created: / 26-11-2011 / 13:31:19 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 02-12-2014 / 22:06:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer::Phase2 class methodsFor:'documentation'!
+
+documentation
+"
+ Inferencing phase 2: Guess types based on 'known' selectors, like #==, #=, #class, #new: and so on...
+
+ [author:]
+ Jan Vrany <jan.vrany@fit.cvut.cz>
+
+ [instance variables:]
+
+ [class variables:]
+
+ [see also:]
+
+"
+! !
+
+!SmalltalkInferencer::Phase2 methodsFor:'visiting'!
+
+visitMessageNode:aMessageNode
+
+ | selector |
+
+ super visitMessageNode: aMessageNode.
+
+ selector := aMessageNode selector.
+ "/ Some selectors are known / expected to return boolean
+ (#( #== #~~ #= #~= #< #<= #=> #> #contains: includes: includesKey: #anySatisfy: #allSatisfy:) includes: selector) ifTrue:[
+ aMessageNode inferedType: (Type withClass: Boolean).
+ ^ self.
+ ].
+
+ "/ Some selectors are known / expected to return some numerical values
+ (#( #+ #- #* #/ #// #\\ ) includes: selector) ifTrue:[
+ aMessageNode inferedType: (Type withClass: Number).
+ ^ self.
+ ].
+
+
+ "/ #new / #basicNew: conventionally returns an instance of the class, if receiver is a class.
+ (#(#new: #basicNew:) includes: selector) ifTrue:[
+ | rec type |
+ rec := aMessageNode receiver.
+ (rec isSelf and:[class isMetaclass]) ifTrue:[
+ type := Type withClass: class theNonMetaclass.
+ type trustfullnessAdd: 50.
+ aMessageNode inferedType: type.
+ ^self.
+ ].
+
+ type := aMessageNode receiver inferedType instanceSide.
+ aMessageNode inferedType: type.
+ ^self.
+ ].
+
+ "Created: / 05-08-2014 / 14:03:21 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 26-09-2014 / 11:20:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+!
+
+visitUnaryNode:anObject
+
+ | type sel rec classes |
+
+ super visitUnaryNode:anObject.
+
+ sel := anObject selector.
+
+ "/ #class should always return a class of the receiver...
+ sel == #class ifTrue:[
+ type := anObject receiver inferedType classSide.
+ anObject inferedType: type.
+ ^self.
+ ].
+
+ "/ #new / #basicNew: conventionally returns an instance of the class, if receiver is a class.
+ (sel == #new or:[sel == #basicNew]) ifTrue:[
+ rec := anObject receiver.
+ (rec isSelf and:[class isMetaclass]) ifTrue:[
+ type := Type withClass: class theNonMetaclass.
+ type trustfullnessAdd: 50.
+ anObject inferedType: type.
+ ^self.
+ ].
+
+ type := anObject receiver inferedType instanceSide.
+ anObject inferedType: type.
+ ^self.
+ ].
+
+ rec := anObject receiver.
+ classes := rec inferedType classes.
+ classes size == 1 ifTrue:[
+ "/ Special hack for Java, when code is like
+ "/ `JAVA java lang reflect`
+ classes anElement == JavaPackage class ifTrue:[
+ (JAVA notNil and:[anObject selector first isUppercase]) ifTrue:[
+ | jclass |
+
+ "/ fetch an accessor...
+ [
+ jclass := anObject evaluate.
+ "/ fetch the class...
+ jclass := JavaVM classNamed: jclass fullName definedBy: JavaVM systemClassLoader.
+ jclass notNil ifTrue:[
+ anObject inferedType: (Type withClass: jclass class).
+ ] ifFalse:[
+ anObject inferedType: (Type withClass: JavaClass class).
+ ].
+ ] on: Error do:[
+ "/ ignore...
+ ]
+ ] ifFalse:[
+ anObject inferedType: (Type withClass: JavaPackage class).
+ ].
+ ].
+ ].
+
+ "Created: / 27-11-2011 / 15:49:39 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified: / 08-10-2013 / 11:07:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+ "Modified (comment): / 05-08-2014 / 13:56:12 / Jan Vrany <jan.vrany@fit.cvut.cz>"
+! !
+
+!SmalltalkInferencer::Phase3 class methodsFor:'documentation'!
+
+documentation
+"
+ Phase 3: guess types based on naming conventions. This is mainly to process
+ parameters in form of aString or aStringOrBoolean...
+
+ [author:]
+ Jan Vrany <jan.vrany@fit.cvut.cz>
+
+ [instance variables:]
+
+ [class variables:]
+
+ [see also:]
+
+"
+! !
+
+!SmalltalkInferencer class methodsFor:'documentation'!
+
+version_HG
+
+ ^ '$Changeset: <not expanded> $'
+!
+
+version_SVN
+ ^ '$Id$'
+! !
+