diff -r aee3347fc851 -r 4b4ee4d475e4 AbstractLauncherApplication.st --- a/AbstractLauncherApplication.st Sun Jan 24 15:25:57 2016 +0100 +++ b/AbstractLauncherApplication.st Sun Jan 24 22:05:48 2016 +0100 @@ -29,6 +29,18 @@ privateIn:AbstractLauncherApplication ! +ApplicationModel subclass:#PackageLoadDialog + instanceVariableNames:'hierarchicalListView packageIdByItem pathByItem packageDirPath + packageIcon greyPackageIcon folderIcon greyFolderIcon + alreadyLoadedString applicationIcon greyApplicationIcon root + itemsByPath getItemByPath myHierarchicalItemWithLabelAndIcon + filterHolder masterRoot infoTextHolder loadButton + loadAndBrowseButton selectedPackageHolder monticelloRoot' + classVariableNames:'PreviousPackageDialogItems PreviousPackageDialogExtent' + poolDictionaries:'' + privateIn:AbstractLauncherApplication +! + !AbstractLauncherApplication class methodsFor:'documentation'! copyright @@ -423,6 +435,17 @@ "Created: / 08-10-2014 / 23:42:52 / Jan Vrany " ! ! +!AbstractLauncherApplication class methodsFor:'utilities'! + +openLoadPackageDialog + "open a dialog showing wellknown packages (listed in the packages directory) + and offer to load the selected one(s). + TODO: make this a little app instead of an ad-hoc dialog, + add remote packages (central goody repository?)" + + PackageLoadDialog open +! ! + !AbstractLauncherApplication methodsFor:'drag & drop'! canDropObjects:aCollectionOfDropObjects @@ -1725,6 +1748,16 @@ "Modified: / 23.4.1998 / 18:37:46 / cg" ! +fileLoadPackage + "open a dialog showing wellknown packages (listed in the packages directory) + and offer to load the selected one(s). + TODO: make this a little app instead of an ad-hoc dialog, + add remote packages (central goody repository?), + add a description text view, showing more info about the package (from where?)" + + self class openLoadPackageDialog. +! + saveImageAs: aFileName "save image in aFilename. Sender has to handle SnapshotError" @@ -7067,6 +7100,642 @@ ) ! ! +!AbstractLauncherApplication::PackageLoadDialog class methodsFor:'documentation'! + +documentation +" + handwritten q&d dialog to load packages. + TODO: + rewrite using UI builder +" +! ! + +!AbstractLauncherApplication::PackageLoadDialog class methodsFor:'opening'! + +open + self new openLoadPackageDialog +! ! + +!AbstractLauncherApplication::PackageLoadDialog methodsFor:'opening'! + +openLoadPackageDialog + "open a dialog showing wellknown packages (listed in the packages directory) + and offer to load the selected one(s). + TODO: make this a little app instead of an ad-hoc dialog, + add remote packages (central goody repository?)" + + |list dialog filter v + browse selectionChangeAction + selectedPackageLabel infoView monticelloLabel| + + alreadyLoadedString := (resources string:' (already loaded)') allItalic. + + self initializeIcons. + + selectedPackageHolder := ValueHolder with:nil. + infoTextHolder := ValueHolder with:nil. + filterHolder := ValueHolder with:nil. + itemsByPath := Dictionary new. + packageIdByItem := IdentityDictionary new. + pathByItem := IdentityDictionary new. + + Class withoutUpdatingChangesDo:[ + myHierarchicalItemWithLabelAndIcon := + HierarchicalItemWithLabelAndIcon + subclass:#myHierarchicalItemWithLabelAndIcon + instanceVariableNames:'type info' + classVariableNames:'' + poolDictionaries:'' + category:nil + inEnvironment:nil. + myHierarchicalItemWithLabelAndIcon compile:'type ^ type'. + myHierarchicalItemWithLabelAndIcon compile:'type:aSymbol type := aSymbol'. + myHierarchicalItemWithLabelAndIcon compile:'info ^ info'. + myHierarchicalItemWithLabelAndIcon compile:'info:anObject info := anObject'. + ]. + + list := HierarchicalList new. + + masterRoot := myHierarchicalItemWithLabelAndIcon new. + masterRoot icon:(ToolbarIconLibrary stxHomeIcon). + masterRoot label:(resources string:'local '). + masterRoot type:#localRoot. + + root := myHierarchicalItemWithLabelAndIcon new. + root icon:folderIcon. + root label:((resources string:'[Compiled Packages]') asText allItalic colorizeAllWith:Color grey). + root type:#compiledPackagesRoot. + masterRoot add:root. + + monticelloRoot := myHierarchicalItemWithLabelAndIcon new. + monticelloLabel := ((resources string:'[Monticello Packages]') asText allItalic colorizeAllWith:Color grey). + monticelloRoot type:#monticelloRoot. + + (MCRepositoryGroup isNil or:[MCRepositoryGroup isLoaded not]) ifTrue:[ + monticelloRoot icon:greyFolderIcon. + monticelloRoot label:monticelloLabel, (' (Monticello Support not Loaded)' asText colorizeAllWith:Color grey). + ] ifFalse:[ + monticelloRoot icon:folderIcon. + monticelloRoot label:monticelloLabel. + self getMonticelloRepositories. + ]. + masterRoot add:monticelloRoot. + + self readPackageTree. + masterRoot expand. + root expand. + list root:masterRoot. + + PreviousPackageDialogItems notNil ifTrue:[ + PreviousPackageDialogItems keysAndValuesDo:[:path :prevItem | + |newItem| + + newItem := itemsByPath at:path ifAbsent:nil. + newItem notNil ifTrue:[ + prevItem isExpanded ifTrue:[ newItem expand ] + ]. + ]. + ]. + + selectionChangeAction := + [:selectionIndices | self selectionChangeAction:selectionIndices]. + + dialog := Dialog new. + dialog label:(resources string:'Load Package'). + dialog addButton:(loadButton := Button label:(resources string:'Load') action:[self loadAction:false]) beReturnButton. + dialog addButton:(loadAndBrowseButton := Button label:(resources string:'Load & Browse') action:[self loadAction:true]). + dialog addAbortButtonLabelled:(resources string:'Close'). + + loadButton enabled:false. + loadAndBrowseButton enabled:false. + + filter := EditField new. + filter emptyFieldReplacementText:(resources string:'Filter Pattern'). + filter immediateAccept:true. + filter model: filterHolder. + filterHolder onChangeEvaluate:[self filterChangedAction]. + dialog + addLabelledField:filter + label:(resources string:'Quick Find:') + adjust:#left tabable:true from:0.0 to:1.0 separateAtX:150. + + "/ dialog addComponent:filter. + + v := HVScrollableView for:HierarchicalListView. + hierarchicalListView := v scrolledView. + hierarchicalListView multipleSelectOk:true. + hierarchicalListView preferredExtent:(400 @ 300). + hierarchicalListView doubleClickAction:[:index | self loadAction:false. dialog okPressed]. + hierarchicalListView list:list. + hierarchicalListView action:selectionChangeAction. + hierarchicalListView menuHolder:[ self itemMenu]. + + dialog addComponent:v. + selectedPackageLabel := dialog addTextLabelOn:(selectedPackageHolder) adjust:#left. + infoView := dialog addTextBoxOn:infoTextHolder class:TextView withNumberOfLines:5 hScrollable:true vScrollable:true. + + dialog stickAtBottomWithVariableHeight:v. + dialog stickAtBottomWithFixHeight:selectedPackageLabel. + dialog stickAtBottomWithFixHeight:infoView. + + PreviousPackageDialogExtent notNil ifTrue:[ + dialog extent:PreviousPackageDialogExtent + ]. + + browse := false. + dialog openModelessAtPointer. + + "/ remember the expand/collapse status + PreviousPackageDialogItems := itemsByPath. + PreviousPackageDialogExtent := dialog extent. +! ! + +!AbstractLauncherApplication::PackageLoadDialog methodsFor:'private'! + +filterChangedAction + |matchingItems filterPattern isMatch firstMatchingItem| + + filterPattern := filterHolder value. + filterPattern isEmptyOrNil ifTrue:[ + "/ nothing + root recursiveDo:[:item | + item label:(item label copy asText allNonBold withoutAnyColorEmphasis). + ]. + ] ifFalse:[ + filterPattern := filterPattern asLowercase. + isMatch := filterPattern includesMatchCharacters. + + matchingItems := OrderedCollection new. + masterRoot recursiveDo:[:item | + |itemLabel itemPackage| + + itemLabel := item label. + itemPackage := packageIdByItem at:item ifAbsent:''. + + ((isMatch and:[itemLabel matches:filterPattern caseSensitive:false]) + or:[ (isMatch not and:[ itemLabel asLowercase includesString:filterPattern ]) + or:[ (isMatch and:[itemPackage matches:filterPattern caseSensitive:false]) + or:[ isMatch not and:[ itemPackage asLowercase includesString:filterPattern ]]]]) + ifTrue:[ + matchingItems add:item. + ] + ]. + matchingItems isEmpty ifTrue:[ + "/ nothing found + root recursiveDo:[:item | + item label:(item label copy asText allNonBold withoutAnyColorEmphasis). + ]. + Screen current beep. + ] ifFalse:[ + "/ collapse all and fully expand all matching items + masterRoot recursiveDo:[:item | + item collapse. + item label:(item label copy asText allNonBold colorizeAllWith:Color grey). + ]. + firstMatchingItem := nil. + matchingItems do:[:item | + item label:(item label copy asText allBold withoutAnyColorEmphasis). + item makeVisible. + firstMatchingItem := firstMatchingItem ? item. + ]. + hierarchicalListView makeLineVisible:firstMatchingItem listIndex. + ]. + ]. +! + +getItemByPath:path packageID:packageID + "/ ensures an item for a path and returns it. + "/ if not already present, the item is created as a folder + + |item parent subPackageID| + + item := path isEmpty + ifTrue:[root] + ifFalse:[ itemsByPath at:path ifAbsent:nil ]. + item isNil ifTrue:[ + parent := self getItemByPath:(path copyButLast) packageID:packageID. + item := myHierarchicalItemWithLabelAndIcon new + children:#(); + icon:greyFolderIcon; + label:path last. + parent add:item. + itemsByPath at:path put:item. + subPackageID := path size > 1 + ifTrue:[ path first , ':' , ((path copyFrom:2) asStringWith:$/) ] + ifFalse:[ path first ]. + packageIdByItem at:item put:subPackageID. + ]. + ^ item +! + +getMonticelloRepositories + (MCRepositoryGroup default repositories + asSortedCollection:[:a :b |a displayString < b displayString]) + do:[:each | + |reposItem| + + reposItem := myHierarchicalItemWithLabelAndIcon new. + reposItem icon:folderIcon. + reposItem label:each displayString , ((resources string:' [MC Repository]') asText allItalic colorizeAllWith:Color grey). + reposItem type:#monticelloRepository. + reposItem info:each. + monticelloRoot add:reposItem. + + each allPackageNames asSortedCollection do:[:eachPackage | + |packageItem| + + packageItem := myHierarchicalItemWithLabelAndIcon new. + packageItem icon:packageIcon. + packageItem label:eachPackage. + packageItem type:#monticelloPackage. + reposItem add:packageItem. + ] + ]. +! + +initializeIcons + folderIcon := ToolbarIconLibrary directoryOpen18x18Icon. + "/ folderHalfGreyIcon := ToolbarIconLibrary directoryOpenHalfGrey18x18Icon. + packageIcon := ToolbarIconLibrary packageOpen24x24Icon. + applicationIcon := ToolbarIconLibrary makeYellow22x22Icon1. + greyFolderIcon := folderIcon asGrayImageDepth:8. + greyPackageIcon := packageIcon asGrayImageDepth:8. + greyApplicationIcon := applicationIcon asGrayImageDepth:(applicationIcon depth min:8). +! + +itemMenu + |item m itemType package defClass| + + hierarchicalListView selectionValue notEmptyOrNil ifTrue:[ + item := hierarchicalListView selectionValue first. + + itemType := item type. + ( + #( #localRoot #monticelloRoot #compiledPackagesRoot ) includes:itemType + ) ifFalse:[ + + package := packageIdByItem at:item ifAbsent:nil. + package notNil ifTrue:[ + defClass := package asPackageId projectDefinitionClass. + ]. + + m := Menu new. + m addItem:(MenuItem + label: (resources string:'Load') + itemValue: + [ + package notNil ifTrue:[ + self loadPackageAndUpdate:package browse:false subPackages:false item:item. + "/ loadPackageAndUpdate value:package value:false value:item. + ]. + ] + enabled:package notNil). + m addItem:(MenuItem + label: (resources string:'Load with All SubPackages') + itemValue: + [ + package notNil ifTrue:[ + self loadPackageAndUpdate:package browse:false subPackages:true item:item. + "/ loadPackageAndUpdate value:package value:false value:item. + ]. + ] + enabled:package notNil). + m addSeparator. + m addItem:(MenuItem + label: (resources string:'Open File Browser on Project''s Folder') + itemValue: + [ + |dir| + + package notNil ifTrue:[ + dir := Smalltalk packageDirectoryForPackageId:package. + dir notNil ifTrue:[ + FileBrowser default openOn:dir. + ] ifFalse:[ + Dialog warn:(resources string:'Directory not present/readable: "%1"' with:dir) + ] + ]. + ] + enabled:package notNil). + m addSeparator. + m addItem:(MenuItem + label: (resources string:'Browse Project Definition') + itemValue: + [ + defClass notNil ifTrue:[ + SystemBrowser default openInClass:defClass class + ]. + ] + enabled:defClass notNil). + + item type == #monticelloPackage ifTrue:[ + m addItem:(MenuItem + label: (resources string:'Browse Monticello Package') + itemValue: [ + |repos| + + repos := item parent info. + MCRepositoryBrowser openOnRepository:repos forPackage:item label. + ]). + ]. + ]. + ]. + ^ m +! + +loadAction:doBrowse + "the button's load action" + + (hierarchicalListView selectionValue) do:[:eachSelectedItem | + |package repos| + + eachSelectedItem type == #monticelloRepository ifTrue:[ + repos := eachSelectedItem info. + MCRepositoryBrowser openOnRepository:repos forPackage:nil. + ] ifFalse:[ + eachSelectedItem type == #monticelloPackage ifTrue:[ + repos := eachSelectedItem parent info. + MCRepositoryBrowser openOnRepository:repos forPackage:eachSelectedItem label. + ] ifFalse:[ + package := packageIdByItem at:eachSelectedItem ifAbsent:nil. + package notNil ifTrue:[ + self loadPackageAndUpdate:package browse:doBrowse subPackages:false item:eachSelectedItem + ]. + ]. + ]. + ]. +! + +loadPackageAndUpdate:package browse:doBrowse subPackages:subPackages item:someItem + |defClass updateAction| + + self withWaitCursorDo:[ + updateAction := + [:whatChanged :parameter | + self updateAction:whatChanged parameter:parameter + ]. + + Smalltalk onChangeSend:#value:value: to:updateAction. + [ + [ + Smalltalk loadPackage:package + ] on:PackageLoadError do:[:ex | + |path| + + path := pathByItem at:someItem. + "/ try to load the file as is (i.e. not via package-id + (Dialog information:'package ID inconsistency - loading file directly...'). + Smalltalk fileIn:(packageDirPath asFilename / path). + ] + ] ensure:[ + Smalltalk retractInterestsFor:updateAction. + ]. + ]. + ((defClass := package asPackageId projectDefinitionClass) notNil + and:[ defClass isLoaded + and:[ defClass isFullyLoaded ]]) + ifFalse:[ + defClass isNil ifTrue:[ + Dialog warn:(resources string:'Load failed: definition class for packageID (%1) not present after package load.' with:package) + ] ifFalse:[ + defClass verbose:true. + defClass isLoaded. + defClass isFullyLoaded. + defClass verbose:false. + Dialog warn:(resources string:'Load failed: definition class /%1) not fully loaded after package load.' with:defClass name) + ] + ] ifTrue:[ + doBrowse ifTrue:[ + Tools::NewSystemBrowser openOnPackage:package + ]. + someItem icon == packageIcon ifTrue:[ + someItem icon:greyPackageIcon. + someItem label:(someItem label , alreadyLoadedString). + ] ifFalse:[ + someItem icon == applicationIcon ifTrue:[ + someItem icon:greyApplicationIcon. + someItem label:(someItem label , alreadyLoadedString). + ]. + ]. + ]. + + subPackages ifTrue:[ + someItem children do:[:eachChild | + |subPackageID| + + subPackageID := packageIdByItem at:eachChild. + self loadPackageAndUpdate:subPackageID browse:false subPackages:true item:eachChild. + ]. + ]. +! + +readPackageTree + packageDirPath := Smalltalk getSystemFileName:'packages'. + packageDirPath isNil ifTrue:[ + root label:root label,((resources string:' (no "packages" folder found)') colorizeAllWith:Color red). + ] ifFalse:[ + packageDirPath asFilename directoryContentsAsFilenames sort do:[:fn | + |item base nm path parentPath parent isLibrary isApplication isAlreadyLoaded + defClass target packageID| + + ((fn suffix = 'mcz') + or:[ fn isDirectory + or:[ (fn baseName startsWith:'.') + or:[ (fn baseName = 'README') ]]]) ifFalse:[ + base := fn withoutSuffix baseName. + (base startsWith:'lib') ifTrue:[ + nm := (base copyFrom:4). + fn suffix notEmptyOrNil ifTrue:[ + isLibrary := true. + isApplication := false. + ] ifFalse:[ + isLibrary := false. + isApplication := true. + ] + ] ifFalse:[ + nm := base. + isLibrary := false. + isApplication := true. + ]. + + path := nm asCollectionOfSubstringsSeparatedBy:$_. + "/ see if already loaded + + packageID := (path size > 1) + ifTrue:[ path first , ':' , ((path copyFrom:2) asStringWith:$/) ] + ifFalse:[ path first ]. + + isAlreadyLoaded := + (defClass := ProjectDefinition definitionClassForPackage:packageID) notNil + and:[ defClass isLoaded + and:[ defClass isFullyLoaded ]]. + + item := self getItemByPath:path packageID:packageID. + + target := fn contents first. + ((target startsWith:'lib ') or:[(target startsWith:'app ')]) ifTrue:[ + pathByItem at:item put:(target copyFrom:(target indexOfSeparator + 1)) withoutSeparators. + ]. + + "/ do not overwrite an app by a lib with the same name (happens in expecco/application) + (isApplication or:[ item icon isNil or:[item icon == folderIcon or:[item icon == greyFolderIcon]]]) ifTrue:[ + isAlreadyLoaded ifTrue:[ + item icon:(isApplication ifTrue:[greyApplicationIcon] ifFalse:[greyPackageIcon]). + item label:(item label , alreadyLoadedString) + ] ifFalse:[ + item icon:(isApplication ifTrue:[applicationIcon] ifFalse:[packageIcon]). + ]. + ]. + + "/ if it is not already loaded, make all parents non-grey + isAlreadyLoaded ifFalse:[ + path size-1 to:1 by:-1 do:[:n | + |parentPath parentItem| + + parentPath := path copyTo:n. + parentItem := self getItemByPath:parentPath packageID:packageID. + parentItem icon == greyFolderIcon ifTrue:[ + parentItem icon:folderIcon. +"/ ] ifFalse:[ +"/ parentItem icon == greyApplicationIcon ifTrue:[ +"/ parentItem icon:applicationIcon. +"/ ]. + ]. + ] + ]. + ]. + ]. + ]. +! + +selectionChangeAction:selectionIndices + |selectedItem p itemType info| + + loadButton enabled:(selectionIndices notEmpty). + loadAndBrowseButton enabled:(selectionIndices notEmpty). + + selectionIndices size == 1 ifTrue:[ + selectedItem := hierarchicalListView selectionValue first. + itemType := selectedItem type. + + itemType == #monticelloRepository ifTrue:[ + info := 'Monticello repository. Double click to browse its contents.'. + ] ifFalse:[ + itemType == #monticelloPackage ifTrue:[ + info := 'Monticello package. Double click to browse its contents.'. + ] ifFalse:[ + p := packageIdByItem at:selectedItem ifAbsent:nil. + p notNil ifTrue:[ + selectedPackageHolder value:(resources string:'Selected Package: "%1"' with:p allBold). + self showPackageInfoAction:p. + ] ifFalse:[ + selectedItem == masterRoot ifTrue:[ + info := 'Packages found on the local machine.' + ] ifFalse:[ + selectedItem == monticelloRoot ifTrue:[ + info := 'Monticello packages found on the local machine.' + ] ifFalse:[ + selectedItem == root ifTrue:[ + info := 'Local class library packages as found in the "packages" folder.' + ]. + ]. + ]. + ]. + ]. + info notNil ifTrue:[ infoTextHolder value:(resources string:info)]. + ]. + ] ifFalse:[ + selectedPackageHolder value:(resources string:'Selected %1 packages.' with:selectionIndices size). + ]. +! + +showPackageInfoAction:package + |projectDef comment info dir className fileName docChange| + + info := resources string:'Sorry, could not find any package documentation'. + projectDef := package asPackageId projectDefinitionClass. + projectDef notNil ifTrue:[ + comment := projectDef commentOrDocumentationString. + comment isNil ifTrue:[ + info := info, + (resources stringWithCRs:'\\The project''s definition class (%1)\has no documentation method.' with:projectDef class name). + ]. + ] ifFalse:[ + "/ try to find the package's source + dir := Smalltalk packageDirectoryForPackageId:package. + dir notNil ifTrue:[ + "/ is there a project definition class's source? + className := ProjectDefinition projectDefinitionClassNameForDefinitionOf:package. + fileName := dir / ((Smalltalk fileNameForClass:className),'.st'). + fileName exists ifTrue:[ + fileName readingFileDo:[:s | + ChangeSet + fromStream:s + while:[:change | + (change isMethodCodeChange + and:[ change selector == #documentation + and:[ change isForMeta ]]) ifTrue:[ + docChange := change. + false "/ stop reading + ] ifFalse:[ + true + ]. + ]. + ]. + docChange notNil ifTrue:[ + comment := Parser methodCommentFromSource:docChange source. + ] ifFalse:[ + info := info , + (resources stringWithCRs:'\\The project''s definition class (%1) is present,\but has no documentation method.\\In file: %2' + with:className + with:fileName pathName). + ]. + ] ifFalse:[ + info := info , + (resources stringWithCRs:'\\No definition class was found in the project.\In folder: %1' + with:dir pathName). + ]. + ]. + ]. + comment notEmptyOrNil ifTrue:[ + comment := comment asStringCollection. + [ comment size > 0 and:[comment first isEmpty]] whileTrue:[ comment removeFirst ]. + (comment conform:[:line | line isEmpty or:[line startsWith:' ']]) ifTrue:[ + comment := comment collect:[:line | + (line startsWith:' ') ifTrue:[ + line copyFrom:5 + ] ifFalse:[ + line + ]]. + ]. + info := comment asString. + ] ifFalse:[ + info := info colorizeAllWith:Color red. + ]. + infoTextHolder value:info. +! + +updateAction:whatChanged parameter:parameter + |item isLoaded packageID| + + "/ update the corresponding tree item + (whatChanged == #postPackageLoad or:[whatChanged == #postLoad]) ifTrue:[ + parameter notNil ifTrue:[ + packageID := parameter asSymbol. + item := self getItemByPath:(packageID splitByAny:':/') packageID:packageID. + item notNil ifTrue:[ + isLoaded := (ProjectDefinition definitionClassForPackage:packageID) notNil. + isLoaded ifTrue:[ + (item icon == applicationIcon or:[item icon == packageIcon]) ifTrue:[ + item icon:((item icon == applicationIcon) ifTrue:[greyApplicationIcon] ifFalse:[greyPackageIcon]). + item label:(item label , alreadyLoadedString) + ]. + ]. + ]. + ]. + ]. +! ! + !AbstractLauncherApplication class methodsFor:'documentation'! version