"

 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' }"

"{ NameSpace: Smalltalk }"

Parser subclass:#Explainer

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'System-Compiler'

!

Object variableSubclass:#ActionWithInfo

	instanceVariableNames:'block info'

	classVariableNames:''

	poolDictionaries:''

	privateIn:Explainer

!

!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' menu 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 (then a short explanaition

    is shown in the lower info area).

    Most of the texts returned here are heuristically motivated,

    based on the experience with beginners and their frequently asked questions.

    TODO:

    this is in an experimental stage; the naive type inferer replicates code

    found in DWIM support; it should use the code there.

    [author:]

        Claus Gittinger

"

! !

!Explainer class methodsFor:'explaining'!

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

    |expl literalValue literalsClass findInnerMost elementIndex codeOfCharacterBeforeCursor|

    literalValue := node value.

    literalsClass := literalValue class.

    expl := (self asClassLink:literalsClass name "allBold") , '-constant'.

    (literalValue isInteger) ifTrue:[

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

            expl := expl , ' ('.

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

        expl := expl , ' ',literalValue storeString,' (code: ',literalValue codePoint printString,' hex: 16r',literalValue codePoint hexPrintString,')'.

        ^ expl.

    ].

    (node isLiteralArray and:[intervalIfKnown notNil]) ifTrue:[

        "/ see which element we have to explain

        findInnerMost :=

            [:token |

                token value keysAndValuesDo:[:index :eachToken |

                    |selectorOrName selectorExplanation|

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

                        elementIndex := index.  "/ see below

                        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)

                                ].

                            ].

                            selectorExplanation := (Explainer explainSelector:selectorOrName inClass:cls short:short).

                            selectorExplanation isNil ifTrue:[^ expl].

                            ^ expl, ' / ', selectorExplanation.

                        ].

                    ].

                ]

             ].

        findInnerMost value:node token.

    ].

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

        literalValue size == 0 ifTrue:[

            ^ 'empty ' , expl

        ].

        elementIndex notNil ifTrue:[

            ^ expl , (' (size=%1; element=%2)' bindWith:literalValue size with:elementIndex)

        ].

        literalValue isString ifTrue:[

            elementIndex := intervalIfKnown start - node token start.

            (elementIndex between:1 and:literalValue size) ifTrue:[

                codeOfCharacterBeforeCursor := (literalValue at:elementIndex) codePoint.

                ^ expl , (' (size=%1; position=%2; codePoint=16r%3)' 

                        bindWith:literalValue size 

                        with:elementIndex

                        with:codeOfCharacterBeforeCursor hexPrintString)

            ]

        ].

        ^ expl , (' (size=%1)' bindWith:literalValue size)

    ].

    ^ expl

    "Modified (format): / 30-04-2016 / 16:00:05 / 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 definer

     instances classesOfInstVars implementingClasses canBeNil

     bestMatches hint redefiningClasses|

    selector := node buildSelectorString.

    selectorString := selector printString contractTo:50.

    selector := selector asSymbolIfInterned.    "/ avoid creating new symbols.

    selector isNil ifTrue:[

        ^ '%1 is NOWHERE impemented.' bindWith:boldSelectorString

    ].

    selectorString := self asLink:selectorString to:(self actionToBrowseImplementorsOf:selector).

    boldSelectorString := selectorString "allBold".

    recClassSet := self guessPossibleClassesFor:(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]) asArray.

        (implementingClasses includes:nil) ifTrue:[

            implementingClasses size > 1 ifTrue:[

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

                    bindWith:selector "allBold"

                    with:(implementingClasses size - 1)

            ].

            (#('self'  'super' 'true' 'false' 'thisContext') includes:selector) ifTrue:[

                ^ ('%1 is NOT understood here (missing period after previous statement?)' 

                        bindWith:selector allBold)

            ].

            hint := ''.    

            (recClassSet contains:[:cls | cls isMeta not and:[cls theMetaclass canUnderstand:selector]]) ifTrue:[

                hint := '. But class understands it - did you mean "rcvr class ',selector,'..." ?'.

            ].

            bestMatches := Parser findBestSelectorsFor:selector in:srchClass.

            bestMatches notEmptyOrNil ifTrue:[

                |guessedClass|

                guessedClass := srchClass whichClassIncludesSelector:bestMatches first.

                guessedClass notNil ifTrue:[

                    ^ ('%1 is NOT understood here (best guess is: "%2" from %3)'

                        bindWith:selector allBold

                        with:(bestMatches first "allBold")

                        with:guessedClass name) , hint.

                ].

            ].

            ^ ('%1 is NOT understood here' bindWith:selector allBold), hint

        ].

    ].

    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 select:[:eachInst| eachInst isProtoObject not].

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

                    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

            ].

            redefiningClasses := srchClass allSubclasses select:[:cls | cls implements:selector].

        ] ifFalse:[

            implementingClasses isNil ifTrue:[

                implementingClasses := Smalltalk allImplementorsOf:selector

            ].

        ].

    ].

    implClass isNil ifTrue:[

        implementingClasses size == 1 ifTrue:[

            implClass := implementingClasses anElement.

        ]

    ].

    implClass notNil ifTrue:[ 

        |clsName action1 action2|

        implMethod := implClass compiledMethodAt:selector.

        clsName := implClass name.

        clsName := self asLink:clsName to:(self actionToBrowseClass:implClass selector:selector).

        info := '%1 » %2' bindWith:clsName "allBold" with:selectorString.

        info := self asLink:info to:(action1 := self actionToBrowseClass:implClass selector:selector info:nil).

        redefiningClasses size > 0 ifTrue:[

            redefiningClasses size == 1 ifTrue:[

                |redefiner|

                redefiner := redefiningClasses first.

                info := info,(' (redefined in %1)'

                                bindWith:(self 

                                            asLink:redefiner name

                                            to:(action2 := self actionToBrowseClass:redefiner selector:selector))).

                action2 info:((redefiner compiledMethodAt:selector) source) 

            ] ifFalse:[    

                info := info,' (redefined in '

                             ,('%1 classes' 

                                    bindWith:(self 

                                              asLink:redefiningClasses size printString

                                              info:'Browse redefiners'

                                              to:(action2 := self actionToBrowseImplementorsOf:selector in:redefiningClasses)))

                             ,')'. 

                action2 info:'Browse redefiners'            

            ].

        ].

        implMethodComment := self fetchDescriptionOfMethod:"fetchCommentOfMethod:"implMethod.

        implMethodComment notNil ifTrue:[

            info := info , Character cr , implMethodComment.

            action1 info:implMethod source.

        ].

        ^ info

"/        (srchClass isNil and:[(cls includesBehavior:implClass) not]) 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 <= 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: / 30-04-2016 / 17:08:11 / cg"

!

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

    |srchClass selector selectorString implClass

     "sendingMethods numSendingMethods sendingClasses" |

    selector := node selector.

    selector := selector asSymbolIfInterned.    "/ avoid creating new symbols.

    selectorString := selector printString contractTo:50.

    (srchClass := cls superclass) notNil ifTrue:[

        implClass := srchClass whichClassIncludesSelector:selector.

        implClass notNil ifTrue:[

            ^ '%1 overrides implementation in %2.'

              bindWith:(self asLink:selectorString "allBold" to:(self actionToOpenMethodFinderFor:selector))

              with:(self asLink:implClass name "allBold" to:(self actionToBrowseClass:implClass selector:selector))

        ].

    ].

    (cls includesSelector:selector) ifFalse:[

        ^ '%1: a new method.' bindWith:selectorString "allBold"

    ].

"/

"/        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 argNode argClass argClassSet|

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

            argNode := definingNode arguments detect:[:arg | arg name = nm] ifNone:nil.

            argNode notNil ifTrue:[