"

 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

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

    Transcript showCR:self class name, '': 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 ..."

    Transcript showCR:self class name, '': 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.

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

    | parser |

    super compile:theCode forClass:aClass inCategory:cat.

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

    ^ parser selector notNil ifTrue:[

        aClass compiledMethodAt: parser selector.

    ] ifFalse:[ 

        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.

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

    ^ 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 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: String new.

    initCode nextPutLine:'initialize'.

    runValue := maxValue + 1.

    enumValues keysAndValuesDo:[:idx :eachVariableName |

        |oldValue thisValue|

        oldValue := nonMetaClass classVarAt:eachVariableName.

        oldValue notNil ifTrue:[

            thisValue := oldValue numericValue.

        ] ifFalse:[

            thisValue := runValue.

            runValue := runValue + 1.

        ].

        initCode 

            nextPutAll:'    ';

            nextPutAll:eachVariableName;

            nextPutAll:' := self basicNew'.

        (aClass canUnderstand:#'setNumericValue:') ifTrue:[

            initCode nextPutAll:' setNumericValue: ',thisValue printString.

        ].

        (aClass canUnderstand:#'setCssClassString:') ifTrue:[

            initCode nextPutAll:('; setCssClassString: ''' , nonMetaClass nameWithoutPrefix asLowercaseFirst , eachVariableName , '''').

        ].

        (aClass canUnderstand:#'setName:') ifTrue:[

            initCode nextPutAll:('; setName: ''' , eachVariableName asLowercaseFirst , '''').

        ].

        initCode nextPutLine:'.'.

    ].

    initCode cr.

    initCode nextPutLine:'    "'.

    initCode nextPutLine:'     ',className, ' initialize'.

    initCode nextPutLine:'    "'.

    self

        compile:(initCode contents)

        forClass:metaClass 

        inCategory:#'class initialization'.

    code := 'allStateNames\    ^ #( ' ,

                ((enumValues collect:[:each | '#''',each asLowercaseFirst,'''']) asStringWith:' ') , ')',

                '\\    "\' ,

                '     ',className, ' allStateNames\' ,

                '    "\'.

    self

        compile:code withCRs

        forClass:metaClass 

        inCategory:#queries.

    self executeCollectedChangesNamed:('Generate EnumType Code for ' , className).

    aClass initialize.

    "Modified: / 1.2.1998 / 16:10:03 / cg"

!

createExamplesMethodForViewClass:aClass

    "create an examples method"

    |nonMetaClass metaClass className code|

    nonMetaClass := aClass theNonMetaclass.

    metaClass := aClass theMetaclass.

    className := nonMetaClass name.

    self startCollectChanges.

    (metaClass includesSelector:#examples) ifFalse:[

        code := 

'examples

"

 Notice that everything between [exBegin] and [exEnd] is extracted by the html-doc generator

 to create nicely formatted and clickable executable examples in the generated html-doc.

 (see the browsers class-documentation menu items for more)

 trying the widget as standAlone view:

                                                        [exBegin]

    %1 new open

                                                        [exEnd]

 embedded in another view:

                                                        [exBegin]

    |top v|

    top := StandardSystemView new.

    top extent:300@300.

    v := %1 new.

    v origin:10@10 corner:150@150.

    top add:v.

    top open

                                                        [exEnd]

"

' bindWith:className.    

        self 

            compile:code

            forClass:metaClass 

            inCategory:#documentation.

    ].

    self executeCollectedChangesNamed:('Add Example to ' , className).

!

createInitializationMethodIn:aClass

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

    |nonMetaClass metaClass className code initializer m|

    nonMetaClass := aClass theNonMetaclass.

    metaClass := aClass theMetaclass.

    className := nonMetaClass name.

    self startCollectChanges.

    (nonMetaClass includesSelector:#initialize) ifFalse:[