"
COPYRIGHT (c) 2020-2022 LabWare
"
"{ Package: 'stx:goodies/monticello' }"

"{ NameSpace: Smalltalk }"

MCStXSnapshotTransformation subclass:#MCStXSnapshotPreWriteTransformation
	instanceVariableNames:'extensionMethodCategoryMap projectDefinition includeExtrasForSTX'
	classVariableNames:''
	poolDictionaries:''
	category:'SCM-Monticello-St/X Storing'
!

!MCStXSnapshotPreWriteTransformation class methodsFor:'documentation'!

copyright
"
COPYRIGHT (c) 2020-2022 LabWare


"
!

documentation
"
    documentation to be added.

    [author:]
        Jan Vrany <jan.vrany@fit.cvut.cz>

    [instance variables:]

    [class variables:]

    [see also:]

"
! !

!MCStXSnapshotPreWriteTransformation methodsFor:'accessing'!

monticelloName
    | def code package |

    def := self projectDefinition.
    def notNil ifTrue:[^ def monticelloName].

    "/ No project definition - the package is proably
    "/ pure Monticello / Tonel package with no St/X extras.
    "/ 
    "/ Since all we have now is just a snapshot, we have to look
    "/ at any class or method definition and get the package name
    "/ from there.
    code := original definitions detect: [:e | e isClassDefinition ] ifNone: [ nil ].
    code notNil ifTrue: [
        package := code actualClass package.
    ] ifFalse: [ 
        "/ Look for some method definition
        code := original definitions detect: [:e | e isMethodDefinition ] ifNone: [ nil ].
        code notNil ifTrue: [ 
            package := (code actualClass compiledMethodAt: code selector) package.
        ].
    ].

    "/ If package DOES NOT look like Smalltalk/X package name,
    "/ return it...
    (package notNil and:[ package includesAny:':/']) ifFalse: [ 
         ^ package
    ].

    "/ ...otherwise, we cannot make a guess.
    self error: 'Cannot guess (monticello) package name!!'

    "Created: / 31-05-2013 / 00:12:27 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified (format): / 28-10-2021 / 15:52:39 / Jan Vrany <jan.vrany@labware.com>"
!

projectDefinition
    original definitions reverseDo:[:d|
        | c |
        (d isClassDefinition
            and:[(c := d actualClass) notNil
                and:[c isProjectDefinition]])
                    ifTrue:[ ^ c  ]
    ].
    ^nil

    "Created: / 31-05-2013 / 00:23:47 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 31-05-2013 / 10:45:08 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!MCStXSnapshotPreWriteTransformation methodsFor:'accessing - templates'!

monticelloSmalltalkXExtensionMethodCategories_Code
^
'monticelloSmalltalkXExtensionMethodCategor
    "Returns an array of triples (class name, selector , St/X category)
     This information is used by Smalltalk/X when reading back Monticello package
     to patch methods category as in Monticello extensions must have funny name
     to be recognized by Monticello as extensions."

    ^#(
%1
    )
'

    "Created: / 31-05-2013 / 00:20:51 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

monticelloSmalltalkXProjectType_Code
^
'monticelloSmalltalkXProjectType
    "Returns either #library or #application.
     This information is used by Smalltalk/X when reading back Monticello package
     to patch my superclass as neither LibraryDefinition nor ApplicationDefinition classes
     are present in Squeak/Pharo images."

    ^%1
'

    "Created: / 30-05-2013 / 12:42:53 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!MCStXSnapshotPreWriteTransformation methodsFor:'testing'!

isExtensionMethodDefinition: definition
    ^(transformed includesClassNamed: definition className) not

    "Created: / 30-05-2013 / 22:48:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 31-05-2013 / 01:16:20 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

isSmalltalkXPackage
    ^ projectDefinition notNil

    "Created: / 12-06-2013 / 09:22:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
! !

!MCStXSnapshotPreWriteTransformation methodsFor:'transforming'!

transform: anMCSnapshot
    "Returns a transformed **copy** of the original snapshot"

    includeExtrasForSTX := anMCSnapshot options includeExtrasForSTX.
    extensionMethodCategoryMap := OrderedCollection new.
    original := anMCSnapshot.
    projectDefinition := self projectDefinition.
    super transform: anMCSnapshot.
    includeExtrasForSTX ifTrue:[
        (projectDefinition notNil and:[projectDefinition isPackageManifest not and:[extensionMethodCategoryMap notEmpty]]) ifTrue:[
            | source |

            source :=
                self monticelloSmalltalkXExtensionMethodCategories_Code bindWith:
                    (String streamContents:[:s|
                        extensionMethodCategoryMap do:[:entry|
                            s tab; tab; nextPutLine:  entry storeString
                        ].
                    ]).

             transformed definitions addFirst:
                (MCMethodDefinition
                    className:  projectDefinition name
                    classIsMeta: true
                    selector: 'monticelloSmalltalkXExtensionMethodCategories'
                    category: 'accessing - monticello'
                    timeStamp: 'Generated by ', self class name , ' at ' , Timestamp now printString
                    source: source)
        ].
    ].
    ^transformed.

    "Created: / 31-05-2013 / 00:05:45 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 07-09-2015 / 15:28:22 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 29-11-2021 / 14:46:02 / Jan Vrany <jan.vrany@labware.com>"
! !

!MCStXSnapshotPreWriteTransformation methodsFor:'visiting'!

visitClassComment: definition
    | comment source |

    comment := definition comment asStringWithNativeLineEndings."/ Make sure comment has native line endings
    comment := comment spacesToTabs.                            "/ Make sure there are only tabs (norm on Squeak / Pharo)
    comment := comment asStringWithSqueakLineEndings.           "/ Make sure comment has Squeak line endings
    comment := comment asSingleByteStringIfPossible.            "/ Convert to single byte string
    definition comment: comment.     

    source := definition source asStringWithNativeLineEndings.  "/ Make sure source has native line endings
    source := source spacesToTabs.                              "/ Make sure there are only tabs (norm on Squeak / Pharo)
    source := source asStringWithSqueakLineEndings.             "/ Make sure source has Squeak line endings
    source := source asSingleByteStringIfPossible.              "/ Convert to single byte string
    definition source: source.

    "Created: / 17-09-2021 / 12:12:39 / Jan Vrany <jan.vrany@labware.com>"
    "Modified: / 17-09-2021 / 15:18:37 / Jan Vrany <jan.vrany@labware.com>"
!

visitClassDefinition: definition
    "
     save ProjectDefinition classes with Object as superclass   
     (because ProjectDefinition is not present in Pharo/Squeak).
     When reading back into ST/X, the PostReadTransformation undoes this
    "
    | comment class |

    comment := definition commentOrNil.
    comment notNil ifTrue: [
        comment := definition comment asStringWithNativeLineEndings."/ Make sure comment has native line endings
        comment := comment spacesToTabs.                            "/ Make sure there are only tabs (norm on Squeak / Pharo)
        comment := comment asStringWithSqueakLineEndings.           "/ Make sure comment has Squeak line endings
        comment := comment asSingleByteStringIfPossible.            "/ Convert to single byte string
        definition comment: comment.     
    ].

    includeExtrasForSTX ifFalse: [ 
        "/ Strip any Smalltalk/X-type namespace (if any)
        | lastColonIndex |

        lastColonIndex := definition className lastIndexOf: $:.
        lastColonIndex ~~ 0 ifTrue: [
            definition className: (definition className copyFrom: lastColonIndex + 1)
        ].
    ].

    class := definition actualClass.
    (class isProjectDefinition) ifTrue:[
        includeExtrasForSTX ifTrue:[            
            definition
    "/            className:(definition className capitalized);
                superclassName: #PackageManifest;
                category: class monticelloName.

            transformed definitions addFirst:
                (MCMethodDefinition
                    className: definition className
                    classIsMeta: true
                    selector: 'monticelloProjectDefinitionTypeName'
                    category: 'accessing - monticello'
                    timeStamp: 'Generated by ', self class name , ' at ' , Timestamp now printString
                    source:
                        (self monticelloSmalltalkXProjectType_Code bindWith: (class isApplicationDefinition ifTrue:[#application] ifFalse:[#library]) storeString))
        ] ifFalse:[
            class isPackageManifest ifFalse: [
                transformed definitions remove: definition.   
            ]
        ].
    ]

    "Created: / 29-05-2013 / 12:19:44 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 31-07-2015 / 09:22:17 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 02-09-2022 / 22:11:10 / Jan Vrany <jan.vrany@labware.com>"
!

visitMethodDefinition: definition
    | class source |

    class := definition actualClass.

    includeExtrasForSTX ifFalse:[
        "/ Remove all version_XX methods
        (AbstractSourceCodeManager isVersionMethodSelector: definition selector) ifTrue:[
            transformed definitions remove: definition.
        ].

        "/ If St/X extras should not be included, then remove all methods
        "/ that belong to project definition class.
        (class theNonMetaclass == projectDefinition and:[projectDefinition isPackageManifest not]) ifTrue:[ 
            transformed definitions remove: definition ifAbsent: [ "Might have been removed in previous step" ].
            ^ self.
        ].
    ].

    "/ Use source porter to perform automagic porting.
    "/ See MCSnapshotOptions >> porter.
    definition accept: original options porter.

    includeExtrasForSTX ifFalse: [ 
        "/ Strip any Smalltalk/X-type namespace (if any)
        | lastColonIndex |

        lastColonIndex := definition className lastIndexOf: $:.
        lastColonIndex ~~ 0 ifTrue: [
            definition className: (definition className copyFrom: lastColonIndex + 1)
        ].
    ]. 

    "/ Now a horrible hack - do not read the chunk below.
    "/ In Squeak / Pharo world, the method source does not
    "/ (shall not?) contain trailing new lines. St/X browser,
    "/ OTOH, puts a trailing new line in methods' source.
    "/ 
    "/ So, when code is loaded into St/X and modified then saved 
    "/ back, it adds an spurious extra trailing line. This creates
    "/ a noise, especially when using Tonel.
    "/ 
    "/ It gets worse. I (JV) did not pay attention to this problem
    "/ before and start hacking, already adding a spurious new lines
    "/ to considerable codebase - too bad.
    "/ 
    "/ To fix while avoiding noise in diffs, we remove trailing newlines
    "/ for modified methods. However, we have to save back source without
    "/ trailing new lines to the method itself so that when the package is
    "/ saved again from the same image, it won't add the new line (because
    "/ second time the method is no longer 'modified').
    "/ 
    "/ Complicated, isn't it? Stupid, isn't it?
    source := definition source.
    (source last == Character lf or: [ source last == Character return ]) ifTrue: [ 
        (ChangeSet current includesChangeForClass: class selector: definition selector) ifTrue: [ 
            | method |

            source := source withoutTrailingSeparators.
            method := class compiledMethodAt: definition selector.
            method source: source.
        ].
    ].

    source := source asStringWithNativeLineEndings.  "/ Make sure source has native line endings
    source := source spacesToTabs.                              "/ Make sure there are only tabs (norm on Squeak / Pharo)
    source := source asStringWithSqueakLineEndings.             "/ Make sure source has Squeak line endings
    source := source asSingleByteStringIfPossible.              "/ Convert to single byte string
    definition source: source.

    (self isExtensionMethodDefinition: definition) ifTrue:[
        | prefix |

        prefix := '*' , self monticelloName asLowercase.
        (definition category asLowercase startsWith: prefix) ifFalse:[
            extensionMethodCategoryMap add:
                (Array
                    with: definition className , (definition classIsMeta ifTrue:[' class'] ifFalse:[''])
                    with: definition selector
                    with: definition category).
            definition category: '*' , self monticelloName.
        ]
    ].

    "Created: / 30-05-2013 / 22:48:36 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 10-05-2015 / 15:08:26 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 02-09-2022 / 22:15:39 / Jan Vrany <jan.vrany@labware.com>"
!

visitOrganizationDefinition: defintion
    "Add a category in which project definition class is..."

    | categories |

    projectDefinition notNil ifTrue: [
        categories := defintion categories.
        (categories includes: projectDefinition monticelloName) ifFalse:[
            categories := categories copyWith: projectDefinition monticelloName asSymbol.
            defintion categories: categories.
        ].
    ].

    "Created: / 05-10-2014 / 00:59:23 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 04-05-2021 / 11:42:08 / Jan Vrany <jan.vrany@labware.com>"
! !

!MCStXSnapshotPreWriteTransformation class methodsFor:'documentation'!

version
    ^ '$Header: /cvs/stx/stx/goodies/monticello/MCStXSnapshotPreWriteTransformation.st,v 1.11 2015-03-30 19:54:21 cg Exp $'
!

version_CVS
    ^ '$Header: /cvs/stx/stx/goodies/monticello/MCStXSnapshotPreWriteTransformation.st,v 1.11 2015-03-30 19:54:21 cg Exp $'
!

version_HG

    ^ '$Changeset: <not expanded> $'
! !