"

 COPYRIGHT (c) 2002 by eXept Software AG

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

"{ NameSpace: Smalltalk }"

CodeGeneratorTool subclass:#SmalltalkCodeGeneratorTool

	instanceVariableNames:''

	classVariableNames:''

	poolDictionaries:''

	category:'Interface-Browsers'

!

!SmalltalkCodeGeneratorTool class methodsFor:'documentation'!

copyright

"

 COPYRIGHT (c) 2002 by eXept Software AG

              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

"

    This utility class contains various code generation facilites;

    these were extracted from the old and newBrowser.

    There is probably more to come...

    [author:]

        Claus Gittiner

"

! !

!SmalltalkCodeGeneratorTool class methodsFor:'code generation'!

initialMenuSpecMethodSourceForApplications

    "return code for a menuSpec with typical stuff in it"

    ^

'mainMenu

    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,

     the MenuEditor may not be able to read the specification."

    "

     MenuEditor new openOnClass:%1 andSelector:#mainMenu

    "

    <resource: #menu>

    ^ ',(self initialMenuSpecForApplications decodeAsLiteralArray literalArrayEncoding storeString),'

'.

!

initialPageMenuSpecMethodSourceForWebApplications

    "return code for a menuSpec with typical stuff in it"

    ^

'mainMenu

    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,

     the MenuEditor may not be able to read the specification."

    "

     MenuEditor new openOnClass:%1 andSelector:#mainMenu

    "

    <resource: #menu>

    ^ ',(self initialPageMenuSpecForWebApplications decodeAsLiteralArray literalArrayEncoding storeString),'

'.

    "

     self initialPageMenuSpecMethodSourceForWebApplications

    "

!

initialPageSpecMethodSourceForWebApplications

    "return an empty pageSpec"

    ^

'pageSpec

    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,

     the UIPainter may not be able to read the specification."

    "

     UIPainter new openOnClass:%1 andSelector:#pageSpec

    "

    <resource: #canvas>

    ^ ',(self initialPageSpecForWebApplications decodeAsLiteralArray literalArrayEncoding storeString),'

'.

!

initialToolbarMenuSpecMethodSource

    "return a menuSpec with typical stuff in it"

    ^

'toolbarMenu

    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,

     the MenuEditor may not be able to read the specification."

    "

     MenuEditor new openOnClass:%1 andSelector:#toolbarMenu

    "

    <resource: #menu>

    ^ ',(self initialToolbarMenuSpec decodeAsLiteralArray literalArrayEncoding storeString),'

'.

    "

     self initialToolbarMenuSpecMethodSource

    "

!

initialWindowSpecMethodSourceForApplications

    "return an empty windowSpec with an initial menubar in it"

    ^

'windowSpec

    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,

     the UIPainter may not be able to read the specification."

    "

     UIPainter new openOnClass:%1 andSelector:#windowSpec

    "

    <resource: #canvas>

    ^ ',

        self initialWindowSpecForApplications2 decodeAsLiteralArray prettyPrintString

.

    "

     self initialWindowSpecMethodSourceForApplications

    "

!

initialWindowSpecMethodSourceForDialogs

    "return an empty windowSpec for dialogs"

    ^

'windowSpec

    "This resource specification was automatically generated by the CodeGeneratorTool."

    "Do not manually edit this!! If it is corrupted,

     the UIPainter may not be able to read the specification."

    "

     UIPainter new openOnClass:%1 andSelector:#windowSpec

    "

    <resource: #canvas>

    ^ ',

        self initialWindowSpecForDialogs decodeAsLiteralArray prettyPrintString

! !

!SmalltalkCodeGeneratorTool class methodsFor:'code generation-menus'!

createActionMethodFor:aSelector in:aClass category:aCategory redefine:redefine

    |alreadyInSuperclass method code|

    (aClass includesSelector:aSelector) ifTrue:[

        ^ nil

    ].

    alreadyInSuperclass := aClass superclass canUnderstand:aSelector.

    (alreadyInSuperclass and:[redefine not]) ifTrue:[

        ^ nil

    ].

    method := self methodNameTemplateFor:aSelector.

    code := '%1

    <resource: #uiCallback>

    "automatically generated by UIEditor ..."

    "*** the code below performs no action"

    "*** (except for some feedback on the Transcript)"

    "*** Please change as required and accept in the browser."

    "*** (and replace this comment by something more useful ;-)"

    "action to be added ..."

    Logger info:''action for #%2 ...''.

' bindWith:method with:aSelector.

    alreadyInSuperclass ifTrue:[

        code := code, (('\    super %1\' bindWith:method) withCRs).

    ].

    self compile:code forClass:aClass inCategory:(aCategory ? #actions).

    ^ code

!

createAspectMethodFor:aSelector in:aClass category:aCategory redefine:redefine

    |alreadyInSuperclass method code text|

    (aClass includesSelector:aSelector) ifTrue:[

        ^ nil

    ].

    alreadyInSuperclass := aClass superclass canUnderstand:aSelector.

    (alreadyInSuperclass and:[redefine not]) ifTrue:[

        ^ nil

    ].

    method := self methodNameTemplateFor:aSelector.

    code := '%1

    "automatically generated by UIEditor ..."

    "*** the code below creates a default model when invoked"

    "*** (which may not be the one you wanted)"

    "*** Please change as required and accept in the browser."

    "*** (and replace this comment by something more useful ;-)"

    "aspect to be added ..."

    Logger info:''aspect for #%2 ...''.

' bindWith:method with:aSelector.

    alreadyInSuperclass ifTrue:[

        text := '    ^ super %1\' bindWith:method.

    ] ifFalse:[

        text := '    ^ builder valueAspectFor:#''%1'' initialValue:true\' bindWith:aSelector.

    ].

    code := code, (text withCRs).

    self compile:code forClass:aClass inCategory:(aCategory ? #actions).

    ^ code

! !

!SmalltalkCodeGeneratorTool class methodsFor:'compilation'!

compile:theCode forClass:aClass inCategory:cat

    "install some code for a class.

     Return the new method or nil.

     If refactory browser stuff is avaliable, the refactory tools are used to support undo"

    | parser selector |

    super compile:theCode forClass:aClass inCategory:cat.

    parser := Parser parseMethodSpecification: theCode in: aClass ignoreErrors: true ignoreWarnings: true.

    (selector := parser selector) notNil ifTrue:[

        ^ aClass compiledMethodAt: selector.

    ].

    ^ nil

    "Created: / 05-08-2014 / 16:14:55 / Jan Vrany <jan.vrany@fit.cvut.cz>"

!

compile:theCode forClass:aClass inCategory:cat notifying: requestor

    "install some code for a class. 

     Return the new method or nil.

     If refactory browser stuff is avaliable the refactory tools are used to support undo"

    CompilationErrorHandlerQuery 

        answer:requestor

        do:[

            ^ self compile:theCode forClass:aClass inCategory:cat

        ]    

    "Created: / 05-08-2014 / 16:04:02 / Jan Vrany <jan.vrany@fit.cvut.cz>"

! !

!SmalltalkCodeGeneratorTool class methodsFor:'private'!

methodNameTemplateFor:aSelector

    |numArgs method|

    numArgs := aSelector numArgs.

    numArgs == 1 ifTrue:[

        method := aSelector, 'anArgument'.

    ] ifFalse:[

        numArgs == 0 ifTrue:[

            method := aSelector

        ] ifFalse:[

            method := ''.

            aSelector keywords keysAndValuesDo:[:i :key|

                method := method, key, 'arg', i printString, ' '.

            ].

        ]

    ].

    ^ method

! !

!SmalltalkCodeGeneratorTool class methodsFor:'utilities - source code'!

methodTemplate

    "return a method definition template string"

    |s|

    s := (TextStream ? WriteStream) on:''.

    s nextPutAll:

'message "selector and argument names"

    "comment stating purpose of this message"

    |temporaries|

    "statement."

    "statement."

    "

     optional: comment giving example use

    "

'.

    s cr.

    s emphasis:(UserPreferences current commentEmphasisAndColor).

    s nextPutAll:

'"

 remove this comment.

 Then `accept'' either via the menu

 or via the keyboard (usually CMD-A).

 You do not need this template; you can also

 select any existing methods code, change it,

 and finally `accept''. The method will then be

 installed under the selector as defined in the

 actual text - no matter which method is selected

 in the browser.

 Or clear this text, type in the method from scratch

 and install it with `accept''.

"

'.

    ^ s contents

!

methodTemplateForDocumentation

    "return a method definition template string"

    |s|

    s := (TextStream ? WriteStream) on:''.

    s nextPutAll:

'documentation

'.

    s emphasis:(UserPreferences current commentEmphasisAndColor).

    s nextPutAll:(

'"

    comment describing this class.

    [instance variables:]

        describe instance variables

    [class variables:]

        describe class variables

    [see also:]

    [author:]

        %1

"

' bindWith:(OperatingSystem getFullUserName)).

    ^ s contents

!

methodTemplateForVersionMethodCVS

    "careful to avoid expansion by cvs here!!"

    ^ ('version_CVS\    ^ ''$' , 'Header$''') withCRs

    "Created: / 21-08-2012 / 11:52:27 / cg"

! !

!SmalltalkCodeGeneratorTool methodsFor:'code generation'!

createClassInitializeMethodIn:aClass

    "create a #initialize method on the class side (I'm tired of typing)"

    |nonMetaClass metaClass className code initializer bindings|

    nonMetaClass := aClass theNonMetaclass.

    metaClass := aClass theMetaclass.

    className := nonMetaClass name.

    self startCollectChanges.

    (metaClass includesSelector:#'initialize') ifFalse:[

        bindings := Dictionary new.

        bindings at:'INIT_CLASSINSTVARS' put:(

            String streamContents:[:s |

                metaClass instVarNames do:[:eachClassInstVar |

                    initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...

                    s nextPutLine:('    "/ %1 := %2.' bindWith:eachClassInstVar with:initializer).

                ]

            ]).

        bindings at:'INIT_CLASSVARS' put:(

            String streamContents:[:s |

                nonMetaClass classVarNames do:[:eachClassVar |

                    initializer := 'nil'. "/ need more intelligence here (try to guess class from messages sent to it) ...

                    s nextPutLine:('    "/ %1 := %2.' bindWith:eachClassVar with:initializer).

                ]

            ]).

        code := (self codeFor_classInitialize) expandPlaceholdersWith:bindings.

        self 

            compile:code

            forClass:metaClass 

            inCategory:#initialization.

    ].

    self executeCollectedChangesNamed:('Add Class Initializer to ' , className).

!

createClassTypeTestMethodsIn:aClass forClasses:subClasses

    "create a #isXXX test methods (I'm tired of typing)"

    | code|

    self startCollectChanges.

    subClasses do:[:eachSubClass |

        |nm selector|

        nm := eachSubClass nameWithoutPrefix.

        selector := 'is' , nm.

        (aClass includesSelector:selector) ifFalse:[

            code := (selector , '\    ^ false') withCRs.

            self 

                compile:code

                forClass:aClass 

                inCategory:#testing.

        ].

        (eachSubClass includesSelector:selector) ifFalse:[

            code := (selector , '\    ^ true') withCRs.

            self 

                compile:code

                forClass:eachSubClass 

                inCategory:#testing.

        ].

    ].

    self executeCollectedChangesNamed:'Add ClassType Tests'

!

createEnumTypeCodeFor:aClass

    |nonMetaClass metaClass className enumValues code initCode runValue maxValue|

    self startCollectChanges.

    nonMetaClass := aClass theNonMetaclass.

    metaClass := aClass theMetaclass.

    className := nonMetaClass name.

    enumValues := nonMetaClass classVarNames.

    enumValues do:[:eachVariableName |

        self 

            createAccessMethodsFor:(Array with:eachVariableName)

            in:metaClass  

            withChange:false

            asValueHolder:false

            readersOnly:true    

            writersOnly:false

    ].

    maxValue := enumValues 

                    inject:0 

                    into:[:maxSoFar :eachVariableName | 

                            |oldVal val| 

                            oldVal := nonMetaClass classVarAt:eachVariableName.

                            oldVal notNil ifTrue:[ val := oldVal numericValue ].

                            (val ? maxSoFar) max:maxSoFar

                         ].

    initCode := WriteStream on:''.

    initCode nextPutLine:'initialize'.

    runValue := maxValue + 1.

    enumValues keysAndValuesDo:[:idx :eachVariableName |