extensions.st
branchjv
changeset 16408 bc62fb9a8df6
parent 16369 1090224cc0db
parent 16394 90afc9e9d35f
child 16409 d960c5f89145
--- a/extensions.st	Tue May 03 06:42:52 2016 +0200
+++ b/extensions.st	Wed May 04 06:51:10 2016 +0200
@@ -872,6 +872,169 @@
     ^ self printStringForBrowserWithSelector:selector inClass:nil
 ! !
 
+!Explainer class methodsFor:'utilities'!
+
+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 sortedByName classNames|
+
+    aCollectionOfClasses isEmpty ifTrue:[
+        ^ 'No %1classes' bindWith:prefix.
+    ].
+
+    classNames := aCollectionOfClasses asIdentitySet asOrderedCollection collect:[:each | each theNonMetaclass name].
+
+    nClassNames := classNames size.
+
+    nClassNames <= 4 ifTrue:[
+        nClassNames == 1 ifTrue:[
+            ^ '%2' "'1 %1class: %2'" bindWith:prefix with:(classNames first allBold).
+        ].
+        sortedByName := classNames sort.
+        nClassNames == 2 ifTrue:[
+            ^ '%2 and %3' "'2 %1classes: %2 and %3'" bindWith:prefix
+                        with:(sortedByName first allBold)
+                        with:(sortedByName second allBold).
+        ].
+        nClassNames == 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).
+        ].
+        nClassNames == 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 %2classes' bindWith:nClassNames printString allBold with:prefix
+
+    "Modified: / 27-07-2006 / 10:09:02 / cg"
+! !
+
+!Explainer class methodsFor:'utilities'!
+
+methodImplementorsInfoFor:aMethod
+    "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
+! !
+
+!Explainer class methodsFor:'utilities'!
+
+methodInheritanceInfoFor:aMethod
+    |methodsSuperclass inheritedClass msg methodsClass sel mthd|
+
+    methodsClass := aMethod mclass.
+    methodsClass isNil ifTrue:[^ nil].
+
+    methodsSuperclass := methodsClass superclass.
+    methodsSuperclass isNil ifTrue:[^ nil].
+
+    sel := aMethod selector.
+    inheritedClass := methodsSuperclass whichClassIncludesSelector:sel.
+    inheritedClass notNil ifTrue:[
+        mthd := inheritedClass compiledMethodAt:sel.
+        msg := (sel contractTo:30) allBold.
+        (mthd sends:#'subclassResponsibility') ifTrue:[
+            msg := msg , ' overrides subclassResponsibility in '.
+        ] ifFalse:[
+            msg := msg , ' overrides implementation in '.
+        ].
+        msg := msg , inheritedClass name allBold.
+        "/ msg := msg , '.'.
+    ].
+
+    ^ msg
+! !
+
+!Explainer class methodsFor:'utilities'!
+
+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
+! !
+
+!Explainer class methodsFor:'utilities'!
+
+methodSpecialInfoFor:aMethod
+    "handles special cases - such as documentation methods"
+
+    |cls sel|
+
+    cls := aMethod mclass.
+    cls isNil ifTrue:[^ nil].
+    sel := aMethod selector.
+    cls 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
+! !
+
 !Filename methodsFor:'debugging'!
 
 inspector2TabContentsView