"

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

    [author:]

        Claus Gittinger

"

! !

!Explainer class methodsFor:'explaining'!

commonSuperClassOf:listOfClassNames

    |common found|

    listOfClassNames do:[:className |

        |class|

        class := Smalltalk classNamed:className.

        common isNil ifTrue:[

            common := class

        ] ifFalse:[

            (class isSubclassOf:common) ifTrue:[

                "keep common"

            ] ifFalse:[

                (common isSubclassOf:class) ifTrue:[

                    common := class

                ] ifFalse:[

                    "walk up, checking"

                    found := false.

                    common allSuperclassesDo:[:sup |

                        (found not and:[class isSubclassOf:sup]) ifTrue:[

                            common := sup.

                            found := true.

                        ]

                    ].

                    found ifFalse:[

                        class allSuperclassesDo:[:sup |

                            (found not and:[common isSubclassOf:sup]) ifTrue:[

                                common := sup.

                                found := true.

                            ]

                        ].

                    ].

                ]

            ].

        ].

        common == Object ifTrue:[^ common]

    ].

    ^ common

    "Modified: 17.6.1996 / 17:09:21 / stefan"

    "Modified: 5.9.1996 / 19:34:41 / cg"

!

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|

    string := someText string withoutSeparators.

    stringText := string asText allBold.

    "

     ask parser for variable names

    "

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

            ^ '''' , stringText , ''' is a class instance variable in ' , c soleInstance name , '.'

        ].

        ^ '''' , stringText , ''' is an instance variable in ' , c name , '.'

    ].

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

    c := parser inWhichClassIsClassVar:string.

    c notNil ifTrue:[

        ^ '''' , stringText , ''' is a class variable in ' , c name , '.'

    ].

    aClass isMeta ifTrue:[

        c := aClass soleInstance.

    ] ifFalse:[

        c := aClass.

    ].

    c privateClasses do:[:pClass |

        (pClass name = string 

         or:[pClass nameWithoutPrefix = string]) ifTrue:[

            string := '''' , stringText , ''' is a private class in ''' , c name , '''.'.

            shortText ifFalse:[

                string := (string , '\\It is only visible locally.') withCRs

            ].

            ^ string withCRs

        ].

    ].

    (spc := aClass nameSpace) notNil ifTrue:[

        sym := (spc name , '::' , string) asSymbolIfInterned.

        sym notNil ifTrue:[

            (Smalltalk at:sym) isBehavior ifTrue:[

                string :=  '''' , stringText , ''' is a class in the ''' , spc name , ''' nameSpace.'.

                shortText ifFalse:[

                    string := (string 

                         , '\\It is only visible within this nameSpace.'

                         , '\Access from the outside is possible'

                         , '\by the special name ''' , spc name , '::' , string , '''.') withCRs

                ].

                ^ string withCRs

            ].

        ].

    ].

"/    string knownAsSymbol ifTrue:[

        "globals & symbols"

        tmp := self explainKnownSymbol:string inClass:aClass short:shortText.

        tmp notNil ifTrue:[ ^ tmp].

        "/ try with added colon ...

        sel := string , ':'.

        Symbol allInstancesDo:[:sym |

            (sym startsWith:sel) ifTrue:[

                tmp := self explainKnownSymbol:sym inClass:aClass short:shortText.

                tmp notNil ifTrue:[ ^ tmp].

            ]

        ].

"/    ].

    "try for some obvious things"

    tmp := self explainPseudoVariable:string in:aClass short:true.

    tmp notNil ifTrue:[ ^ tmp].

    "try syntax ..."

    tmp := self explainSyntax:string short:shortText.

    tmp notNil ifTrue:[ ^ tmp].

    shortText ifTrue:[

        ^ ''

    ].

    parser isNil ifTrue:[

        ^ 'parse error - no explanation'

    ].

    ^ 'cannot explain this (could not figure out what this is).'

    "Created: / 3.12.1995 / 12:47:37 / cg"

    "Modified: / 16.4.1997 / 12:46:11 / stefan"

    "Modified: / 23.3.1999 / 13:29:56 / cg"

!

explainHereIn:aClass

    ^ 'like self, here refers to the object which received the message.

However, when sending a message to here the search for methods

implementing this message will start in the defining class (' , aClass name , ')

instead of the receivers class (' , aClass name , ' or subclass).

Thus, using here, redefined methods will NOT be reached with a here-send.'

!

explainKnownSymbol:string inClass:aClass

    "return explanation or nil"

    ^ self explainKnownSymbol:string inClass:aClass short:false

!

explainKnownSymbol:string inClass:aClass short:shortText

    "return explanation or nil"

    |sym list count tmp commonSuperClass val s s2 

     firstImplementingClass cm msg t|

    sym := string asSymbolIfInterned.

    sym isNil ifTrue:[^ nil].

    "try globals"

    (Smalltalk includesKey:sym) ifTrue:[

        tmp := '''' , string asText allBold , ''' is a global variable.'.

        val := Smalltalk at:sym.

        val isBehavior ifTrue:[

            "/ a class

            shortText ifTrue:[

                ^ '''' , string , ''' is ' , (val isLoaded ifTrue:['a'] ifFalse:['an autoloaded'])

, ' class in the ''' , val category , ''' category.'.

            ].

            val name = string ifTrue:[

                tmp := tmp , '

' , string , ' is ' , (val isLoaded ifTrue:['a'] ifFalse:['an autoloaded'])

, ' class categorized as ' , val category , '

in the ''' , val package , ''' package.'.

                ^ tmp.

            ].

            tmp := tmp , '

' , string , ' is bound to the class ' , val name ,

' in category ' , val category , '.'.

            ^ tmp.

        ].

        shortText ifTrue:[

            ^ '''' , string , ''' is ' , ' a global, currently bound to ' , val classNameWithArticle , '.'.

        ].

        tmp := tmp , '

Its current value is ' , val classNameWithArticle , '.'.

        ^ tmp.

    ].

    "

     try selectors

     look who implements it

    "

    list := Set new.

    Smalltalk allClassesDo:[:c|

        (c implements:sym) ifTrue:[

            list add:(c name).

            firstImplementingClass isNil ifTrue:[

                firstImplementingClass := c

            ]

        ].

        (c class implements:sym) ifTrue:[

            list add:(c name , ' class').

            firstImplementingClass isNil ifTrue:[

                firstImplementingClass := c class

            ]

        ]

    ].

    (aClass canUnderstand:sym) ifTrue:[

        firstImplementingClass := (aClass whichClassImplements:sym)

    ] ifFalse:[

        s2 := ''.

    ].

    count := list size.

    (count ~~ 0) ifTrue:[

        "

         for up-to 4 implementing classes,

         list them

        "

        list := list asOrderedCollection sort.

        tmp := ' is a selector implemented in '.

        s := '#' , string asText allBold.

        (count == 1) ifTrue:[

            (t := list first) isMeta ifTrue:[

                t := 'the ' , t

            ].

        ] ifFalse:[

            shortText ifTrue:[

                msg := s , tmp , count printString , ' classes.'.

                ^ msg

            ].

            (count == 2) ifTrue:[

                msg := s , tmp , (list at:1) , ' and ' , (list at:2) , '.' , s2

            ] ifFalse:[

                (count == 3) ifTrue:[

                    msg := s , tmp , '

' , (list at:1) , ', ' , (list at:2) , ' and ' , (list at:3) , '.' , s2

                ] ifFalse:[

                    (count == 4) ifTrue:[

                        msg := s , tmp , '

' , (list at:1) , ', ' , (list at:2) , ', ' , (list at:3), ' and ' , (list at:4) , '.' , s2

                    ] ifFalse:[

                        "

                         if there are more, look for a common

                         superclass and show it ...

                        "

                        commonSuperClass := self commonSuperClassOf:list.

                        (commonSuperClass ~~ Object 

                        and:[commonSuperClass ~~ Behavior

                        and:[commonSuperClass ~~ Class

                        and:[commonSuperClass ~~ ClassDescription]]]) ifTrue:[

                            (list includes:commonSuperClass) ifTrue:[

                                msg := s . tmp , count printString , commonSuperClass name 

                                         , ' and redefined in ' , (count - 1) printString  

                                         , ' subclasses'

                                         , s2.

                                firstImplementingClass := commonSuperClass

                            ] ifFalse:[

                                msg := s , tmp, count printString , ' subclasses of ' , commonSuperClass name , s2

                            ]

                        ] ifFalse:[

                            (commonSuperClass == Object

                            and:[commonSuperClass implements:sym]) ifTrue:[

                                msg := s , tmp , count printString , ' classes.

All objects seem to respond to that message, 

since there is an implementation in Object.' , s2.

                                firstImplementingClass := Object

                            ] ifFalse:[

                                ((commonSuperClass == Behavior

                                 or:[commonSuperClass == Class

                                 or:[commonSuperClass == ClassDescription]])

                                and:[commonSuperClass implements:sym]) ifTrue:[

                                    msg := s , tmp , count printString , ' classes.

All classes seem to respond to that message, 

since there is an implementation in ' , commonSuperClass name , '.' , s2.

                                    firstImplementingClass := commonSuperClass

                                ] ifFalse:[

                                    "

                                     otherwise just give the number.

                                    "

                                    msg := s , tmp , count printString , ' classes.' , s2

                                ]

                            ]

                        ]

                    ]

                ]

            ].

        ].

        firstImplementingClass notNil ifTrue:[

            WindowGroup activeGroup withWaitCursorDo:[

                cm := firstImplementingClass compiledMethodAt:sym.

                cm notNil ifTrue:[

                    cm := cm methodComment.

                ]

            ].

            cm notNil ifTrue:[

                msg := msg , '\\The comment in ' withCRs , firstImplementingClass name allBold , ' is:\' withCRs , cm allItalic.

            ]

        ].

        ^ msg

    ].

    ^ nil

    "Modified: / 17.6.1996 / 17:09:30 / stefan"

    "Created: / 23.3.1999 / 13:29:33 / cg"

    "Modified: / 23.3.1999 / 13:40:40 / cg"

!

explainPseudoVariable:string in:aClass

    "return explanation for the pseudoVariables self, super etc."

    ^ self explainPseudoVariable:string in:aClass short:false

!

explainPseudoVariable:string in:aClass short:shortText

    "return explanation for the pseudoVariables self, super etc."

    (string = 'self') ifTrue:[

        ^ self explainSelfIn:aClass short:shortText

    ].

    (string = 'super') ifTrue:[

        shortText ifTrue:[

            ^ '''super'' - message lookup starts in superclass ''' , aClass superclass name , '''.'

        ].

        ^ self explainSuperIn:aClass

    ].

    (string = 'here') ifTrue:[

        shortText ifTrue:[

            ^ '''here'' - message lookup always starts in ''' , aClass name , '''.'

        ].

        ^ self explainHereIn:aClass

    ].

    (string = 'thisContext') ifTrue:[

        shortText ifTrue:[

            ^ '''thisContext'' - the current stack frame as an object.'