"

 COPYRIGHT (c) 1993 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

"{ Package: 'stx:libcomp' }"

Parser subclass:#Explainer

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'System-Compiler'

!

!Explainer class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 1993 by Claus Gittinger

	      All Rights Reserved

 This software is furnished under a license and may be used

 only in accordance with the terms of that license and with the

 inclusion of the above copyright notice.   This software may not

 be provided or otherwise made available to, or used by, any

 other person.  No title to or ownership of the software is

 hereby transferred.

"

!

documentation

"

    a very simple explainer - much more should be added ...

    This one is involved, when the 'explain' function is used in a 

    codeView (popup or via CMD-E), or if the mouse button is clicked

    on some code construct in the new browser.

    [author:]

        Claus Gittinger

"

! !

!Explainer class methodsFor:'explaining'!

explainLiteralNode:node in:code forClass:cls short:short interval:intervalIfKnown

    |expl literalValue findInnerMost|

    literalValue := node value.

    expl := literalValue class name "allBold" , '-constant.'.

    (literalValue isInteger) ifTrue:[

        (literalValue ~= 0 and:[literalValue ~= 1]) ifTrue:[

            expl := expl , '('.

            #(2 10 16) do:[:base |

                base ~= (node token radix ? 10) ifTrue:[

                    expl := expl , ' ' , (literalValue radixPrintStringRadix:base)

                ].

            ].

            expl := expl , ' )'.

        ].

        ^ expl.

    ].

    (literalValue isArray or:[ literalValue isByteArray ]) ifTrue:[

        literalValue size == 0 ifTrue:[

            ^ 'empty ' , expl

        ].

    ].

    node isLiteralArray ifTrue:[

        intervalIfKnown notNil ifTrue:[

            findInnerMost := [:token |

                        token value do:[:eachToken |

                            |selectorOrName|

                            ((eachToken start to:eachToken stop) intersect:intervalIfKnown) notEmpty ifTrue:[

                                eachToken value isArray ifTrue:[

                                    findInnerMost value:eachToken.

                                ].

                                eachToken value isSymbol ifTrue:[

                                    selectorOrName := eachToken value.

                                    selectorOrName isUppercaseFirst ifTrue:[

                                        (Smalltalk includesKey:selectorOrName) ifTrue:[

                                            ^ expl, ' / ', (Explainer explainGlobal:selectorOrName inClass:cls short:short)

                                        ].

                                    ].

                                    ^ expl, ' / ', (Explainer explainSelector:selectorOrName inClass:cls short:short)

                                ].

                            ].

                        ]

                     ].

            findInnerMost value:node token.

        ].

    ].

    ^ expl

    "Modified: / 09-10-2006 / 12:09:43 / cg"

!

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 

     instances classesOfInstVars implementingClasses canBeNil

     bestMatches|

    selector := node selector.      

    selectorString := selector printString contractTo:30.

    boldSelectorString := selectorString "allBold".

    recClassSet := self guessPossibleImplementorClassesFor:(node receiver) in:code forClass:cls.

    recClassSet size == 1 ifTrue:[

        srchClass := recClassSet first.

        "take care - Set cannot store nil!!"

        implementingClasses := recClassSet collect:[:cls | cls whichClassIncludesSelector:selector] as:Array. 

        (implementingClasses includes:nil) ifTrue:[

            implementingClasses size > 1 ifTrue:[

                ^ 'possibly not understood: %1 (%2 other implementors)'

                    bindWith:selector "allBold"

                    with:(implementingClasses size - 1)

            ].

            bestMatches := Parser findBestSelectorsFor:selector in:srchClass.

            bestMatches size > 0 ifTrue:[

                ^ 'NOT understood here: %1 (Best guess: %2)'

                    bindWith:selector

                    with:(bestMatches first "allBold")

            ].

            ^ 'NOT understood here: %1' bindWith:selector "allBold"

        ].

    ].

    implementingClasses isNil ifTrue:[

        receiver := node receiver.

        receiver isVariable ifTrue:[

            nm := receiver name.

            nm = 'self' ifTrue:[

                srchClass := cls

            ].

            nm = 'super' ifTrue:[

                srchClass := cls superclass

            ].

            definer := receiver whoDefines:nm.

            definer isNil ifTrue:[

                "/ not a local or argument

                (cls instanceVariableNames includes:nm) ifTrue:[

                    "/ ok - an instVar; see what values we find...

                    instances := cls allSubInstances.

                    classesOfInstVars := instances collect:[:eachInst | (eachInst instVarNamed:nm) class].

                    classesOfInstVars := classesOfInstVars asSet.

                    canBeNil := (classesOfInstVars remove:UndefinedObject ifAbsent:[]) notNil.

                    "take care - Set cannot store nil!!"

                    implementingClasses := classesOfInstVars collect:[:cls | (cls whichClassIncludesSelector:selector) ? 0].

                    implementingClasses remove:0 ifAbsent:[].

                ] ifFalse:[

                    nm isUppercaseFirst ifTrue:[

                        nm knownAsSymbol ifTrue:[

                            globalValue := Smalltalk at:nm asSymbol.

                            globalValue isClass ifTrue:[

                                srchClass := globalValue class.    

                            ].

                        ]

                    ].

                ].

            ].

        ].

        receiver isLiteral ifTrue:[

            srchClass := receiver value class

        ].

        srchClass notNil ifTrue:[

            implClass := srchClass whichClassIncludesSelector:selector.

            implClass isNil ifTrue:[

                ^ '%1 is NOT understood here.' bindWith:boldSelectorString

            ].

            info := '%1 >> %2' bindWith:implClass name "allBold" with:selectorString "allBold".

            implMethod := implClass compiledMethodAt:selector.

            implMethodComment := self fetchCommentOfMethod:implMethod.

            implMethodComment notNil ifTrue:[

                info := info , ' ' , implMethodComment.

            ].

            ^ info

        ].

        implementingClasses isNil ifTrue:[

            implementingClasses := Smalltalk allImplementorsOf:selector

        ].

    ].

    implementingClasses size == 1 ifTrue:[

        implClass := implementingClasses anElement.

        info := '%1 >> %2' bindWith:implClass name "allBold" with:selectorString.

        srchClass isNil ifTrue:[

            "/ info := 'guess: ', info.

            info := info , ' (guess)'.

        ].

    ] ifFalse:[

        info := Explainer explainSelector:selector inClass:cls short:short.

    ].

    implementingClasses notEmptyOrNil ifTrue:[

        implMethods := implementingClasses collect:[:implClass | implClass compiledMethodAt:selector].

        implMethods size <= 5 ifTrue:[

            comments := implMethods collect:[:implMethod | implMethod comment ? ''].

            (comments includes:'') ifFalse:[

                comments := comments collect:[:implMethodComment | implMethodComment firstLine].

                comments asSet size == 1 ifTrue:[

                    info := info , ' ' , (self fetchCommentOfMethod:implMethods first).

                ].

            ].

        ].

    ].

    ^ info

    "Modified: / 06-02-2007 / 19:26:11 / cg"

!

explainMethodNode:node in:code forClass:cls short:short interval:intervalIfKnown

    |srchClass selector selectorString implClass 

     "sendingMethods numSendingMethods sendingClasses" boldSelectorString|

    selector := node selector.      

    selectorString := selector printString contractTo:30.

    boldSelectorString := selectorString "allBold".

    (srchClass := cls superclass) notNil ifTrue:[

        implClass := srchClass whichClassIncludesSelector:selector.

        implClass notNil ifTrue:[

            ^ '%1 hides implementation in %2.' 

              bindWith:boldSelectorString

              with:implClass name "allBold"

        ].

    ].

    (cls includesSelector:selector) ifFalse:[

        ^ '%1: a new method.' bindWith:boldSelectorString

    ].

"/

"/        sendingMethods := SystemBrowser 

"/                                allCallsOn:selector 

"/                                in:(cls withAllSubclasses , cls allSubclasses) 

"/                                ignoreCase:false 

"/                                match:false.

"/        sendingMethods := sendingMethods select:[:eachMethod | eachMethod mclass notNil].  "/ remove unbound ones

"/

"/        sendingClasses := (sendingMethods collect:[:eachMethod | eachMethod mclass]) asSet.

"/        numSendingMethods := sendingMethods size.

"/        numSendingMethods == 1 ifTrue:[

"/            sendingClasses first == cls ifTrue:[

"/                ^ '%1: sent locally from %2.' 

"/                    bindWith:boldSelectorString

"/                    with:sendingMethods first selector "allBold"

"/            ].

"/            ^ '%1: sent in hierarchy from %2 in %3.' 

"/                bindWith:boldSelectorString

"/                with:sendingMethods first selector "allBold"

"/                with:sendingClasses first name.

"/        ].

"/        numSendingMethods == 2 ifTrue:[

"/            sendingClasses asIdentitySet size == 1 ifTrue:[

"/                sendingClasses first == cls ifTrue:[

"/                    ^ '%1: sent locally from %2 and %3.' 

"/                        bindWith:boldSelectorString

"/                        with:sendingMethods first selector "allBold"

"/                        with:sendingMethods second selector "allBold"

"/                ].

"/                ^ '%1: sent in hierarchy from %2 and %3 in %4.' 

"/                    bindWith:boldSelectorString

"/                    with:sendingMethods first selector "allBold"

"/                    with:sendingMethods second selector "allBold"

"/                    with:sendingClasses first name.

"/            ].

"/        ].

"/        numSendingMethods == 0 ifTrue:[

"/"/            ^ '%1: no sender found.' 

"/"/                bindWith:boldSelectorString.

"/            ^ nil

"/        ].

"/        ^ '%1: %2 sending methods in hierarchy.' 

"/            bindWith:boldSelectorString

"/            with:numSendingMethods.

"/

"/        "/ the following is too expensive...

"/"/        sendingMethods := SystemBrowser allCallsOn:selector in:Smalltalk allClasses.

"/"/        numSendingMethods == 0 ifTrue:[

"/"/            ^ '%1: nowhere sent.' bindWith:boldSelectorString

"/"/        ].

"/"/        numSendingMethods == 1 ifTrue:[

"/"/            sendingMethods first mclass == cls ifTrue:[

"/"/                ^ '%1: only sent from %2.' 

"/"/                    bindWith:boldSelectorString

"/"/                    with:sendingMethods first selector "allBold"

"/"/            ].

"/"/            ^ '%1: only sent from %2 in %3.' 

"/"/                bindWith:boldSelectorString

"/"/                with:sendingMethods first selector "allBold"

"/"/                with:sendingMethods first mclass name.

"/"/        ].

"/"/        sendingClasses := (sendingMethods collect:[:eachMethod | eachMethod mclass]) asSet.

"/"/        sendingClasses size == 1 ifTrue:[

"/"/            sendingClasses first == cls ifTrue:[

"/"/                ^ '%1: locally sent from %2 methods.' 

"/"/                    bindWith:boldSelectorString

"/"/                    with:numSendingMethods

"/"/            ].

"/"/            ^ '%1 only sent from %2 methods in %3.' 

"/"/                bindWith:boldSelectorString

"/"/                with:numSendingMethods

"/"/                with:sendingClasses first name.

"/"/        ].

    ^ nil

    "Modified: / 09-10-2006 / 12:11:16 / cg"

!

explainNode:node in:code forClass:cls short:short 

    self explainNode:node in:code forClass:cls short:short interval:nil

!

explainNode:node in:code forClass:cls short:short interval:intervalIfKnown

    node isVariable ifTrue:[

        ^ self explainVariableNode:node in:code forClass:cls short:short interval:intervalIfKnown.

    ].

    node isLiteral ifTrue:[

        ^ self explainLiteralNode:node in:code forClass:cls short:short interval:intervalIfKnown

    ].

    node isMessage ifTrue:[

        ^ self explainMessageNode:node in:code forClass:cls short:short interval:intervalIfKnown

    ].

    node isMethod ifTrue:[

        ^ self explainMethodNode:node in:code forClass:cls short:short interval:intervalIfKnown

    ].

    ^ nil

!

explainVariableNode:node in:code forClass:cls short:short interval:intervalIfKnown

    |expl nm nmBold definingNode namePart|

    nm := node name.

    (#( 'self' 'super' 'thisContext' 'here') includes:nm) ifTrue:[

        ^ Explainer explainPseudoVariable:nm in:cls short:short

    ].

    nm notNil ifTrue:[ nmBold := nm "allBold" ].

    definingNode := node whoDefines:nm.

    definingNode notNil ifTrue:[

        namePart := '''' , nmBold , ''''. 

        definingNode isMethod ifTrue:[

            (definingNode arguments contains:[:arg | arg name = nm]) ifTrue:[

                expl := namePart , ' is a method argument.'

            ].

        ].

        expl isNil ifTrue:[

            definingNode isBlock ifTrue:[

                (definingNode arguments contains:[:arg | arg name = nm]) ifTrue:[

                    expl := namePart , ' is a block argument.'

                ].

            ].

        ].

        expl isNil ifTrue:[

            definingNode parent notNil ifTrue:[

                definingNode parent isMethod ifTrue:[

                    expl := namePart , ' is a method temporary.'.

                ] ifFalse:[

                    definingNode parent isBlock ifTrue:[

                       expl := namePart , ' is a block temporary.'.

                    ]

                ]

            ].

        ].

        expl isNil ifTrue:[

            expl := namePart , ' is a temporary.'

        ].

        (cls allInstanceVariableNames includes:nm) ifTrue:[

            expl := expl , ' (Instance Variable is hidden)'

        ].

        ^ expl.

    ].

    ^ Explainer explain:node name in:code forClass:cls short:short

    "Modified: / 07-11-2006 / 12:22:09 / cg"

!

fetchCommentOfMethod:mthd 

    |methodComment lines|

    methodComment := mthd comment.

    methodComment isNil ifTrue:[^ nil].

    lines := methodComment asStringCollection.

    methodComment := lines first.

    methodComment := methodComment withoutSeparators.

    (methodComment endsWith:',') ifTrue:[ methodComment := methodComment copyWithoutLast:1].

    methodComment := methodComment withoutSeparators.

    (lines size > 1) ifTrue:[

        methodComment := methodComment , ' ...'

    ].

    ^ ('"' , methodComment , '"') colorizeAllWith:(UserPreferences current commentColor).

    "Created: / 14-09-2006 / 14:11:58 / cg"

!

guessPossibleImplementorClassesFor:node in:code forClass:cls

    "given a node of some code of a method in cls,

     return a collection of possible receiver classes."

    |nm globalValue definer instances classesOfInstVars|

    node isVariable ifTrue:[

        nm := node name.

        nm = #self ifTrue:[

            ^ cls withAllSubclasses

        ].

        nm = #here ifTrue:[

            ^ cls withAllSuperclasses

        ].

        nm = #super ifTrue:[

            ^ cls allSuperclasses

        ].

        definer := node whoDefines:nm.

        definer isNil ifTrue:[

            "/ not a local or argument

            (cls instanceVariableNames includes:nm) ifTrue:[

                "/ ok - an instVar; see what values we find...

                instances := cls allSubInstances.

                classesOfInstVars := instances collect:[:eachInst | (eachInst instVarNamed:nm) class].

                classesOfInstVars := classesOfInstVars asSet.

                ^ classesOfInstVars. 

            ].

            (cls classVariableNames includes:nm) ifTrue:[

                ^ Array with:(cls classVarAt:nm asSymbol) class.    

            ].

            nm isUppercaseFirst ifTrue:[

                nm knownAsSymbol ifTrue:[

                    globalValue := Smalltalk at:nm asSymbol.

                    globalValue isClass ifTrue:[

                        ^ Array with:globalValue class.    

                    ].

                ].

                (cls topNameSpace notNil and:[cls topNameSpace ~~ Smalltalk]) ifTrue:[

                    globalValue := cls topNameSpace at:nm asSymbol.

                    globalValue isClass ifTrue:[

                        ^ Array with:globalValue class.    

                    ].

                ]

            ].

        ].

        ^ nil

    ].

    node isLiteral ifTrue:[

        ^ Array with:(node value class)

    ].

"/    node isMessage ifTrue:[

"/        recClassSet := self guessPossibleImplementorClassesFor:(node receiver) in:code forClass:cls.

"/        recClassSet isNil ifTrue:[ ^ nil ].

"/        recClassSet isEmpty ifTrue:[ ^ nil ].

"/

"/        implSet := recClassSet collect:[:recClass | recClass whichClassIncludesSelector:node selector].

"/        "/ toDo: for each implementor, parse its method for possible return types.

"/        ^ rsltClassSet.

"/    ].

    ^ nil

! !

!Explainer class methodsFor:'explaining-naive'!

commonSuperClassOf:listOfClassesOrClassNames