"

 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

    |expl literalValue|

    literalValue := node value.

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

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

        literalValue size == 0 ifTrue:[

            ^ 'empty ' , expl

        ].

    ].

    ^ expl

!

explainMessageNode:node in:code forClass:cls short:short

    "answer a string which explains node"

    |receiver nm srchClass selector selectorString implClass 

     boldSelectorString globalValue recClassSet

     implMethod comment info implMethods comments definer instances classesOfInstVars implementingClasses canBeNil|

    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.

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

        (implementingClasses includes:nil) ifTrue:[

            ^ 'possibly not understood: ' , 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 includes:UndefinedObject.

                    classesOfInstVars remove:UndefinedObject ifAbsent:[].

                    implementingClasses := classesOfInstVars collect:[:cls | cls whichClassIncludesSelector:selector]. 

                ] 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.

            comment := implMethod comment.

            comment notNil ifTrue:[

                comment := comment firstLine.

                comment := comment asText colorizeAllWith:(UserPreferences current commentColor).

                info := info , ' "' , comment , '"'.

            ].

            ^ 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.

        ].

    ] 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:[:comment | comment firstLine].

                comments asSet size == 1 ifTrue:[

                    comment := comments first.    

                    comment := comment asText colorizeAllWith:(UserPreferences current commentColor).

                    info := info , ' "' , comment , '"'.

                ].

            ].

        ].

    ].

    ^ info

!

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

    |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 implements: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

!

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

    node isVariable ifTrue:[

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

    ].

    node isLiteral ifTrue:[

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

    ].

    node isMessage ifTrue:[

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

    ].

    node isMethod ifTrue:[

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

    ].

    ^ nil

!

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

    |expl nm nmBold definingNode|

    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:[

        expl := '''' , nmBold , ''''. 

        definingNode isMethod ifTrue:[

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

                ^ expl , ' is a method argument.'

            ].

        ].

        definingNode isBlock ifTrue:[

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

                ^ expl , ' is a block argument.'

            ].

        ].

        definingNode parent notNil ifTrue:[

            definingNode parent isMethod ifTrue:[

                ^ expl , ' is a method temporary.'

            ].

            definingNode parent isBlock ifTrue:[

                ^ expl , ' is a block temporary.'

            ]

        ].

        ^ expl , ' is a temporary.'

    ].

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

!

guessPossibleImplementorClassesFor:node in:code forClass:cls

    |nm globalValue recClassSet rsltClassSet implSet 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. 

            ].

            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

    ^ Behavior commonSuperclassOf:listOfClassesOrClassNames

!

explain:someText in:source forClass:aClass

    "Given a source and a substring of it, return a string containing

     an explanation.

     This is just a q&d implementation - to be correct, it should use the parser,

     and explain from the parsetree (instead of doing string matches).

     This leads to some wrong explanations, for example if some string is

     used as selector within a string, or if a variable is named like a

     message selector. I.e. the explanation should be context sensitive.

     Also, there could be much more detailed explanations."

    ^ self

        explain:someText in:source forClass:aClass short:false

!

explain:someText in:source forClass:aClass short:shortText

    "Given a source and a substring of it, return a string containing

     an explanation.

     This is just a q&d implementation - to be correct, it should use the parser,

     and explain from the parsetree (instead of doing string matches).

     This leads to some wrong explanations, for example if some string is

     used as selector within a string, or if a variable is named like a

     message selector. I.e. the explanation should be context sensitive.

     Also, there could be much more detailed explanations."

    |parser variables c string tmp

     spc sym sel stringText clsName val valString|

    string := someText string withoutSeparators.

    stringText := string allBold.

    stringText := '''' , stringText , ''''.

    "

     ask parser for variable names

    "

    ParseErrorSignal catch:[

        parser := self parseMethod:source in:aClass ignoreErrors:true ignoreWarnings:true.

    ].

    parser notNil ifTrue:[

        "look for variables"

        variables := parser methodVars.

        (variables notNil and:[variables includes:string]) ifTrue:[

            ^ stringText , ' is a method variable.'

        ].

        variables := parser methodArgs.

        (variables notNil and:[variables includes:string]) ifTrue:[

            ^ stringText , ' is a method argument.'

        ]

    ].

    parser isNil ifTrue:[

        parser := self for:(ReadStream on:source) in:aClass

    ].

    "instvars"

    c := aClass whichClassDefinesInstVar:string.

    c notNil ifTrue:[

        c isMeta ifTrue:[

            clsName := c theNonMetaclass name.

            shortText ifTrue:[

                ^ stringText , ' is a class instVar in ' , clsName , '.'

            ].

            ^ stringText, ' is a class instance variable in ' , clsName , '.'

        ].

        clsName := c name.

        shortText ifTrue:[

            ^ stringText , ' is an instVar in ' , clsName , '.'

        ].

        ^ stringText , ' is an instance variable in ' , clsName , '.'

    ].

"/    variables := aClass allInstVarNames.

"/    (variables notNil and:[variables includes:string]) ifTrue:[

"/        "where is it"

"/        c := aClass.

"/        [c notNil] whileTrue:[ |v|

"/            v := c instVarNames.

"/            (v notNil and:[v includes:string]) ifTrue:[

"/                ^ string , ' is an instance variable in ' , c name

"/            ].

"/            c := c superclass

"/        ].

"/        self error:'oops'

"/    ].

"/    "class instvars"

"/    variables := aClass class allInstVarNames.

"/    (variables notNil and:[variables includes:string]) ifTrue:[

"/        "where is it"

"/        c := aClass.

"/        [c notNil] whileTrue:[ |v|

"/            v := c class instVarNames.

"/            (v notNil and:[v includes:string]) ifTrue:[

"/                ^ string , ' is a class instance variable in ' , c name

"/            ].

"/            c := c superclass

"/        ].

"/        self error:'oops'

"/    ].

    "classvars"