"

 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'

!

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

    [author:]

        Claus Gittinger

"

! !

!Explainer class methodsFor:'explaining'!

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

    |expl literalValue findInnerMost elementIndex codeOfCharacterBeforeCursor|

    literalValue := node value.

    expl := literalValue class 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|

                    ((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)

                                ].

                            ].

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

                        ].

                    ].

                ]

             ].

        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 implMethods comments definer

     instances classesOfInstVars implementingClasses canBeNil

     bestMatches hint|

    selector := node buildSelectorString.

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

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

                ^ ('NOT understood here: %1 (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 size > 0 ifTrue:[

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

                    bindWith:selector allBold

                    with:(bestMatches first "allBold")

                    with:(srchClass whichClassIncludesSelector:bestMatches first) name) , hint

            ].

            ^ ('NOT understood here: %1' 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.

                    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

            ].

            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 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" boldSelectorString|

    selector := node selector.

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

    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

    "retrieve the comment of a method (if possible and there is one; otherwise, return nil)"

    |methodComment lines|

    "/ with wait cursor, because it accesses sourcecode (via SCM)

    WindowGroup activeGroup withWaitCursorDo:[

        methodComment := mthd comment.

    ].

    methodComment isEmptyOrNil ifTrue:[^ nil].

    lines := methodComment asStringCollection.

    methodComment := lines first.

    methodComment := methodComment withoutSeparators.

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

    methodComment := methodComment withoutSeparators.

    (lines size > 1) ifTrue:[

        methodComment := methodComment , ' ...'

    ].

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

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