"{ Encoding: utf8 }"

"{ Package: 'stx:goodies/monticello' }"

"{ NameSpace: Smalltalk }"

Object subclass:#MCPackageLoader
	instanceVariableNames:'requirements unloadableDefinitions overrideDefinitions
		obsoletions additions removals errorDefinitions provisions'
	classVariableNames:'Debugging'
	poolDictionaries:''
	category:'SCM-Monticello-Loading'
!


!MCPackageLoader class methodsFor:'initialization'!

new
    ^self basicNew initialize
! !

!MCPackageLoader class methodsFor:'as yet unclassified'!

installSnapshot: aSnapshot
	self new
		installSnapshot: aSnapshot;
		load
!

unloadPackage: aPackage
	self new
		unloadPackage: aPackage;
		loadWithNameLike: aPackage name, '-unload'
!

updatePackage: aPackage withSnapshot: aSnapshot
	self new
		updatePackage: aPackage withSnapshot: aSnapshot;
		load
! !

!MCPackageLoader methodsFor:'accessing'!

overrideDefinitions
    ^ overrideDefinitions
!

unloadableDefinitions
    ^ unloadableDefinitions
! !

!MCPackageLoader methodsFor:'patch ops'!

addDefinition: aDefinition
	additions add: aDefinition
!

modifyDefinition: old to: new
	self addDefinition: new.
	obsoletions at: new put: old.
!

removeDefinition: aDefinition
	removals add: aDefinition
! !

!MCPackageLoader methodsFor:'private'!

analyze
        | sorter |
        sorter := self sorterForItems: additions.
        additions := sorter orderedItems.
        requirements := sorter externalRequirements.
        unloadableDefinitions := sorter itemsWithMissingRequirements asSortedCollection.

        overrideDefinitions := additions select:[:e|e isOverrideDefinition].
        additions := additions reject: [:e|e isOverrideDefinition].
        
        sorter := self sorterForItems: removals.
        removals := sorter orderedItems reversed.

    "Modified: / 08-11-2010 / 17:34:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

basicLoad
        | allowEmptyStatements allowSqueakExtensions |

        allowEmptyStatements := ParserFlags allowEmptyStatements.
        allowSqueakExtensions := ParserFlags allowSqueakExtensions.
        ParserFlags allowEmptyStatements: true.
        ParserFlags allowSqueakExtensions: true.

        errorDefinitions := OrderedCollection new.
        self warnAboutUnloadables.


        [[
        | oldErrorDefinitions |
        additions do: [:ea | self tryToLoad: ea] displayingProgress: 'Loading...'.
        removals do: [:ea | ea unload] displayingProgress: 'Cleaning up...'.
        self shouldWarnAboutErrors ifTrue: [self warnAboutErrors].
        oldErrorDefinitions := errorDefinitions.        
        errorDefinitions := OrderedCollection new.
        oldErrorDefinitions do: [:ea | self tryToLoad: ea] displayingProgress: 'Reloading...'.
        additions do: [:ea | ea postloadOver: (self obsoletionFor: ea)] displayingProgress: 'Initializing...'.

        self warnAboutOverrides.
        self warnAboutErrors.

        ]
        
                on: InMidstOfFileinNotification 
                do: [:n | n resume: true]]
                        ensure: 
                            [self flushChangesFile.
                            ParserFlags allowEmptyStatements: allowEmptyStatements.
                            ParserFlags allowSqueakExtensions: allowSqueakExtensions.        
                            ]

    "Modified: / 08-11-2010 / 23:49:38 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 20-08-2011 / 18:20:54 / cg"
!

dependencyWarning
	^ String streamContents:
		[:s |
		s nextPutAll: 'This package depends on the following classes:'; cr.
		requirements do: [:ea | s space; space; nextPutAll: ea; cr].
		s nextPutAll: 'You must resolve these dependencies before you will be able to load these definitions: '; cr.
		unloadableDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] 
!

errorDefinitionWarning
	^ String streamContents:
		[:s |
		s nextPutAll: 'The following definitions had errors while loading.  Press Proceed to try to load them again (they may work on a second pass):'; cr.
		errorDefinitions do: [:ea | s space; space; nextPutAll: ea summary; cr]] 
!

flushChangesFile
        "The changes file is second in the SourceFiles array"

        "(SourceFiles at: 2) flush"

    "Modified: / 11-09-2010 / 18:32:03 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

ifInteractive: aBlock

    ^self ifInteractive: aBlock else:[]

    "Created: / 06-03-2011 / 20:32:00 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

ifInteractive: interactiveBlock else: noninteractiveBlock

    MCInteractiveLoadingQuery query 
        ifTrue:[interactiveBlock value]
        ifFalse:[noninteractiveBlock value].

    "Created: / 06-03-2011 / 20:31:29 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

initialize
	super initialize.
	additions := OrderedCollection new.
	removals := OrderedCollection new.
	obsoletions := Dictionary new.

!

obsoletionFor: aDefinition
	^ obsoletions at: aDefinition ifAbsent: [nil]
!

orderDefinitionsForLoading: aCollection
	^ (self sorterForItems: aCollection) orderedItems
!

orderedAdditions
	^ additions
!

provisions
	^ provisions ifNil: [provisions := Set withAll: Smalltalk keys]
!

shouldWarnAboutErrors
	^ errorDefinitions isEmpty not and: [false "should make this a preference"]
!

sorterForItems: aCollection
	| sorter |
	sorter := MCDependencySorter items: aCollection.
	sorter addExternalProvisions: self provisions.
	^ sorter
!

tryToLoad: aDefinition
        [aDefinition loadOver: (self obsoletionFor: aDefinition)] on: Error do: [:ex |
            errorDefinitions add: aDefinition.

            Debugging == true ifTrue:[
                ex reject
            ].
            Transcript showCR:'error during load (to debug, set MCPackageLoader:Debugging to true): '.
            Transcript showCR:ex description.
        ].

    "Modified: / 11-09-2012 / 09:55:23 / cg"
!

tryToLoadAll: definitions label: label

    definitions do:[:e|self tryToLoad: e] displayingProgress: label.

    "Created: / 09-11-2010 / 17:17:41 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

useChangeSetNamed: baseName during: aBlock
        "Use the named change set, or create one with the given name."
        | changeHolder oldChanges "newChanges" |

        changeHolder := (ChangeSet respondsTo: #newChanges:)
                                                ifTrue: [ChangeSet]
                                                ifFalse: [Smalltalk].
        oldChanges := (ChangeSet respondsTo: #current)
                                                ifTrue: [ChangeSet current]
                                                ifFalse: [Smalltalk changes].

        "/JV @ 2010-09-11: Don't care about changes
        "/newChanges := (ChangeSorter changeSetNamed: baseName) ifNil: [ ChangeSet new name: baseName ].
        "/changeHolder newChanges: newChanges.
        "/[aBlock value] ensure: [changeHolder newChanges: oldChanges].
        "/ Class withoutUpdatingChangesDo: aBlock
        aBlock value.

    "Modified: / 08-11-2010 / 20:01:04 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 05-09-2011 / 15:56:36 / cg"
!

useNewChangeSetDuring: aBlock
	^self useNewChangeSetNamedLike: 'MC' during: aBlock
!

useNewChangeSetNamedLike: baseName during: aBlock
	^self useChangeSetNamed: (ChangeSet uniqueNameLike: baseName) during: aBlock
!

warnAboutDependencies
    "
    
    
        self notify: self dependencyWarning
    "

    "Modified: / 13-10-2010 / 15:44:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
!

warnAboutErrors

    | changes |

    errorDefinitions isNilOrEmptyCollection ifTrue:[^self].
    changes := ChangeSet new.
    errorDefinitions select:[:e|e notNil] thenDo:[:e|e addChangesTo:changes].

    changes := Tools::ChangeSetBrowser2
                openOn: changes
                label:'Error definitions'.

    "Created: / 08-11-2010 / 20:19:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-03-2011 / 20:39:05 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 20-08-2011 / 18:00:02 / cg"
!

warnAboutOverrides

    | changes confirmedChanges definitions |

    overrideDefinitions isNilOrEmptyCollection ifTrue:[^self].
    self ifInteractive:[
        changes := ChangeSet new.
        overrideDefinitions do:[:e|e addChangesTo:changes].
        self assert:(changes includes:nil) not.

        confirmedChanges := Tools::ChangeSetBrowser2
                    confirmChanges: changes
                    label:'Overridden definitions. Load anyway?'.
        confirmedChanges notEmpty ifTrue:[
            confirmedChanges := confirmedChanges flatten.
            definitions := confirmedChanges collect:[:e|e mcDefinition] thenSelect:[:e | e notNil].
            "/ we might get nil in a roundTrip 
            "/ (eg. for mcDef --addChangesTo:--> classChange+commentChange --mcDefinition--> mcDef+nil)
            "/ self assert:(definitions includes:nil) not.

            self tryToLoadAll: definitions label: 'Loading overrides...'.
        ]
    ] else:[
        self tryToLoadAll: overrideDefinitions label: 'Loading overrides...'.
    ]

    "Created: / 08-11-2010 / 20:19:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-03-2011 / 20:33:25 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 20-08-2011 / 19:31:40 / cg"
!

warnAboutUnloadables

    | changes confirmedChanges definitions |

    unloadableDefinitions isNilOrEmptyCollection ifTrue:[^self].
    self ifInteractive:[
        changes := ChangeSet new.
        unloadableDefinitions do:[:e|e addChangesTo:changes].
        self assert:(changes includes:nil) not.

        confirmedChanges := Tools::ChangeSetBrowser2
                    confirmChanges: changes
                    label:'Unsatisfied dependencies. Load anyway?'.
        confirmedChanges notEmpty ifTrue:[
            confirmedChanges := confirmedChanges flatten.
            definitions := confirmedChanges collect:[:e|e mcDefinition] thenSelect:[:e | e notNil].
            "/ we might get nil in a roundTrip 
            "/ (eg. for mcDef --addChangesTo:--> classChange+commentChange --mcDefinition--> mcDef+nil)
            "/ self assert:(definitions includes:nil) not.

            self tryToLoadAll: definitions label: 'Loading unloadables...'.
        ]
    ] else:[
        self tryToLoadAll: unloadableDefinitions label: 'Loading unloadables...'.
    ]

    "Created: / 08-11-2010 / 20:19:24 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 06-03-2011 / 20:36:11 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified: / 20-08-2011 / 19:31:22 / cg"
! !

!MCPackageLoader methodsFor:'public'!

installSnapshot: aSnapshot
	| patch |
	patch := aSnapshot patchRelativeToBase: MCSnapshot empty.
	patch applyTo: self.

!

load
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useNewChangeSetDuring: [self basicLoad]
!

loadWithName: baseName
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useChangeSetNamed: baseName during: [self basicLoad]
!

loadWithNameLike: baseName
	self analyze.
	unloadableDefinitions isEmpty ifFalse: [self warnAboutDependencies].
	self useNewChangeSetNamedLike: baseName during: [self basicLoad]
!

unloadPackage: aPackage
	self updatePackage: aPackage withSnapshot: MCSnapshot empty
!

updatePackage: aPackage withSnapshot: aSnapshot
        |  patch packageSnap |

        MCStXPackageQuery 
            answer: aPackage name 
            do:[
                packageSnap := aPackage snapshot.
                patch := aSnapshot patchRelativeToBase: packageSnap.
                patch applyTo: self.
                packageSnap definitions do: [:ea | self provisions addAll: ea provisions]
            ]

    "Modified: / 14-09-2010 / 22:09:54 / Jan Vrany <jan.vrany@fit.cvut.cz>"
    "Modified (format): / 07-09-2011 / 12:44:16 / cg"
! !

!MCPackageLoader class methodsFor:'documentation'!

version
    ^ '$Header$'
!

version_CVS
    ^ '$Header$'
!

version_SVN
    ^ '$Id$'
! !