"
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:libwidg2' }"
Object subclass:#DoWhatIMeanSupport
instanceVariableNames:''
classVariableNames:''
poolDictionaries:''
category:'System-Support'
!
!DoWhatIMeanSupport 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
"
misc collected UI support (functional)
These used to be in the Smalltalk and SystemBrowser class;
however, they are only needed for programmers, and some of the stuff is useful in multiple
places.
Therefore is is:
1) not needed for standalone executables
2) published here to avoid multiple implementations
[author:]
Claus Gittinger (cg@exept.de)
"
! !
!DoWhatIMeanSupport class methodsFor:'code completion'!
codeCompletionForClass:cls codeView:codeView
|crsrPos char interval source node checkedNode|
cls isNil ifTrue:[
self information:'No class'.
^ self.
].
interval := codeView selectedInterval.
interval isEmpty ifTrue:[
crsrPos := codeView characterPositionOfCursor-1.
char := codeView characterAtCharacterPosition:crsrPos.
[crsrPos > 1 and:[char isSeparator or:['.' includes:char]]] whileTrue:[
crsrPos := crsrPos - 1.
char := codeView characterAtCharacterPosition:crsrPos.
].
interval := crsrPos to:crsrPos.
].
source := codeView contentsAsString string.
node := self findNodeForInterval:interval in:source allowErrors:true.
[node isNil] whileTrue:[
"/ expand to the left ...
interval start > 1 ifFalse:[
crsrPos := codeView characterPositionOfCursor.
self halt.
self information:'No parseNode found'.
^ self.
].
interval start:(interval start - 1).
node := self findNodeForInterval:interval in:source allowErrors:true.
].
node isVariable ifTrue:[
self codeCompletionForVariable:node inClass:cls codeView:codeView.
^ self.
].
checkedNode := node.
[checkedNode notNil] whileTrue:[
checkedNode isMessage ifTrue:[
"/ completion in a message-send
self codeCompletionForMessage:checkedNode inClass:cls codeView:codeView.
^ self
].
checkedNode isMethod ifTrue:[
"/ completion in a methods selector pattern
self codeCompletionForMethod:checkedNode inClass:cls codeView:codeView.
^ self.
].
checkedNode := checkedNode parent.
].
self information:'Node is neither variable nor message.'.
"Modified: / 04-07-2006 / 18:48:26 / fm"
"Modified: / 20-11-2006 / 12:30:59 / cg"
! !
!DoWhatIMeanSupport class methodsFor:'code completion-helpers'!
askUserForCompletion:what for:codeView from:allTheBest
allTheBest isEmpty ifTrue:[ ^ nil ].
allTheBest size == 1 ifTrue:[ ^ allTheBest first ].
allTheBest size < 20 ifTrue:[
|menu idx exitKey|
menu := PopUpMenu labels:allTheBest.
menu hideOnKeyFilter:[:key | |hide|
hide := ( #( CursorDown CursorUp Escape Return ) includes: key) not.
hide ifTrue:[
exitKey := key.
].
hide].
idx := menu startUp.
idx == 0 ifTrue:[
exitKey notNil ifTrue:[
codeView keyPress:exitKey x:0 y:0.
].
^ nil
].
^ allTheBest at:idx.
] ifFalse:[
^ Dialog
choose:(codeView application resources string:'Choose ',what)
fromList:allTheBest
lines:10
title:(codeView application resources string:'Code completion').
].
"Created: / 10-11-2006 / 14:00:53 / cg"
!
codeCompletionForMessage:node inClass:cls codeView:codeView
|selector receiver nm srchClass implClass
bestSelectors bestPrefixes best nodeVal info numArgs
newParts nSelParts oldLen newLen selectorParts|
selector := node selector.
receiver := node receiver.
receiver isVariable ifTrue:[
nm := receiver name.
nm = 'self' ifTrue:[
srchClass := cls
].
nm = 'super' ifTrue:[
srchClass := cls superclass
].
(Smalltalk includesKey:nm asSymbol) ifTrue:[
nodeVal := Smalltalk at:nm asSymbol.
nodeVal notNil ifTrue:[
srchClass := nodeVal class
]
]
].
receiver isLiteral ifTrue:[
srchClass := receiver value class
].
srchClass notNil ifTrue:[
bestSelectors := Parser findBestSelectorsFor:selector in:srchClass.
(bestSelectors includes:selector) ifTrue:[
bestSelectors := bestSelectors select:[:sel | sel size > selector size].
].
bestSelectors size > 0 ifTrue:[
bestPrefixes := bestSelectors select:[:sel | sel asLowercase startsWith:selector asLowercase].
bestPrefixes size > 0 ifTrue:[
bestSelectors := bestPrefixes
].
best := bestSelectors first.
bestSelectors size > 1 ifTrue:[
best = selector ifTrue:[
best := bestSelectors second.
].
bestSelectors size < 20 ifTrue:[
|idx|
idx := (PopUpMenu labels:bestSelectors) startUp.
idx == 0 ifTrue:[ ^ self].
best := bestSelectors at:idx.
] ifFalse:[
best := Dialog request:'Matching selectors:' initialAnswer:best list:bestSelectors.
best size == 0 ifTrue:[^ self].
].
] ifFalse:[
best := bestSelectors first.
].
implClass := srchClass whichClassIncludesSelector:best.
].
] ifFalse:[
"/ class not known
codeView topView withCursor:(Cursor questionMark) do:[
bestSelectors := Parser findBestSelectorsFor:selector.
].
bestSelectors := bestSelectors select:[:sel | sel startsWith:selector].
(bestSelectors includes:selector) ifTrue:[
bestSelectors := bestSelectors select:[:sel | sel size > selector size].
].
bestSelectors size > 0 ifTrue:[
best := bestSelectors first.
bestSelectors size > 1 ifTrue:[
best = selector ifTrue:[
best := bestSelectors second.
].
bestSelectors size < 20 ifTrue:[
|idx|
idx := (PopUpMenu labels:bestSelectors) startUp.
idx == 0 ifTrue:[ ^ self].
best := bestSelectors at:idx.
] ifFalse:[
best := Dialog request:'Matching selectors:' initialAnswer:best list:bestSelectors.
best size == 0 ifTrue:[^ self].
]
] ifFalse:[
best := bestSelectors first.
].
implClass := Smalltalk allClasses select:[:cls | (cls includesSelector:best) or:[cls class includesSelector:best]].
implClass size == 1 ifTrue:[
implClass := implClass first.
] ifFalse:[
implClass := nil
]
].
].
best notNil ifTrue:[
info := best storeString.
implClass notNil ifTrue:[
info := implClass name , ' >> ' , info.
].
self information:info.
best ~= selector ifTrue:[
numArgs := best numArgs.
selectorParts := node selectorParts.
nSelParts := selectorParts size.
newParts := best asCollectionOfSubstringsSeparatedBy:$:.
newParts := newParts select:[:part | part size > 0].
codeView
undoableDo:[
|stop|
numArgs > nSelParts ifTrue:[
stop := selectorParts last stop.
"/ append the rest ...
numArgs downTo:nSelParts+1 do:[:idx |
|newPart|
newPart := newParts at:idx.
(best endsWith:$:) ifTrue:[
newPart := newPart , ':'
].
(codeView characterAtCharacterPosition:stop) == $: ifFalse:[
newPart := ':' , newPart.
].
newPart := (codeView characterAtCharacterPosition:stop) asString , newPart.
codeView replaceFromCharacterPosition:stop to:stop with:newPart
]
].
nSelParts downTo:1 do:[:idx |
|newPart oldPartialToken start stop|
newPart := newParts at:idx.
oldPartialToken := selectorParts at:idx.
start := oldPartialToken start.
stop := oldPartialToken stop.
(best endsWith:$:) ifTrue:[
(codeView characterAtCharacterPosition:stop+1) == $: ifFalse:[
newPart := newPart , ':'
]
] ifFalse:[
(codeView characterAtCharacterPosition:stop) == $: ifTrue:[
newPart := newPart , ':'
] ifFalse:[
(codeView characterAtCharacterPosition:stop+1) isSeparator ifFalse:[
newPart := newPart , ' '
]
]
"/ codeView replaceFromCharacterPosition:start to:stop with:(newPart , ':').
"/ ] ifFalse:[
"/ codeView replaceFromCharacterPosition:start to:stop with:newPart.
].
codeView replaceFromCharacterPosition:start to:stop with:newPart.
oldLen := stop - start + 1.
newLen := newPart size.
codeView selectFromCharacterPosition:start+oldLen to:start+newLen-1.
].
codeView dontReplaceSelectionOnInput.
]
info:'completion'.
].
].
"Created: / 10-11-2006 / 13:18:27 / cg"
!
codeCompletionForMethod:node inClass:cls codeView:codeView
"completion in a methods selector pattern"
|crsrPos
selectorSoFar matchingSelectors
selectors distances best rest
allExistingMethods namesOfArguments
nameBag namesByCount|
crsrPos := codeView characterPositionOfCursor - 1.
selectorSoFar := ''.
node selectorParts doWithIndex:[:partToken :argNr|
|part|
part := partToken value.
selectorSoFar := selectorSoFar , part.
(crsrPos >= partToken start
and:[crsrPos <= partToken stop]) ifTrue:[
matchingSelectors := Smalltalk allClasses
inject:(Set new)
into:[:theSet :eachClass |
|md|
cls isMeta ifTrue:[
md := eachClass theMetaclass methodDictionary
] ifFalse:[
md := eachClass theNonMetaclass methodDictionary
].
theSet addAll:(md keys select:[:sel |sel startsWith:selectorSoFar]).
theSet.
].
selectors := matchingSelectors asOrderedCollection.
"/ if there is only one, and user has already entered it, he might want to complete the argument-name
(selectors size == 1
and:[selectors first = selectorSoFar]) ifTrue:[
allExistingMethods := (Smalltalk allImplementorsOf:selectorSoFar asSymbol)
collect:[:cls | cls compiledMethodAt:selectorSoFar asSymbol].
namesOfArguments := allExistingMethods collect:[:eachMethod | eachMethod methodArgNames].
nameBag := Bag new.
namesOfArguments do:[:eachNameVector | nameBag add:(eachNameVector at:argNr)].
namesByCount := nameBag valuesAndCounts sort:[:a :b | a value < b value].
"/ take the one which occurs most often
best := self askUserForCompletion:'argument' for:codeView from:(namesByCount collect:[:a | a key]).
codeView
undoableDo:[
(crsrPos+1) >= codeView contents size ifTrue:[
codeView paste:best.
] ifFalse:[
codeView insertString:best atCharacterPosition:crsrPos+1.
]
]
info:'completion'.
codeView cursorToCharacterPosition:(crsrPos + best size - 1).
] ifFalse:[
distances := selectors collect:[:each | each spellAgainst:selectorSoFar].
distances sortWith:selectors.
selectors reverse.
best := self askUserForCompletion:'selector' for:codeView from:selectors.
best isNil ifTrue:[^ self].
rest := best copyFrom:selectorSoFar size.
codeView
undoableDo:[
codeView
replaceFromCharacterPosition:crsrPos
to:crsrPos
with:rest
]
info:'completion'.
codeView cursorToCharacterPosition:(crsrPos + rest size - 1).
].
codeView cursorRight. "/ kludge to make it visible
].
].
"Modified: / 04-07-2006 / 18:48:26 / fm"
"Created: / 10-11-2006 / 13:46:44 / cg"
!
codeCompletionForVariable:node inClass:cls codeView:codeView
|nonMetaClass crsrPos nm
allVariables allDistances best nodeVal
char start stop oldLen newLen oldVar
getDistanceComputeBlockWithWeight addWithFactorBlock names allTheBest bestAssoc
globalFactor localFactor selectorOfMessageToNode tree|
nonMetaClass := cls theNonMetaclass.
nm := node name.
"/ if we are behind the variable and a space has already been entered,
"/ the user is probably looking for a message selector.
"/ If the variable represents a global, present its instance creation messages
crsrPos := codeView characterPositionOfCursor.
char := codeView characterAtCharacterPosition:crsrPos-1.
char isSeparator ifTrue:[
nodeVal := cls nameSpace at:nm asSymbol ifAbsent:[Smalltalk at:nm asSymbol].
nodeVal isBehavior ifTrue:[
|methods menu exitKey idx|
methods := nodeVal class methodDictionary values
select:[:m | |cat|
cat := m category asLowercase.
cat = 'instance creation'
].
menu := PopUpMenu labels:(methods collect:[:each | each selector]).
menu hideOnKeyFilter:[:key | |hide|
hide := ( #( CursorDown CursorUp Escape Return ) includes: key) not.
hide ifTrue:[
exitKey := key.
].
hide].
idx := menu startUp.
idx == 0 ifTrue:[
exitKey notNil ifTrue:[
codeView keyPress:exitKey x:0 y:0.
].
^ self
].
best := (methods at:idx) selector.
codeView
undoableDo:[
codeView insertString:best atCharacterPosition:crsrPos.
codeView cursorToCharacterPosition:crsrPos+best size.
]
info:'completion'.
^ self.
].
].
(node parent notNil and:[node parent isMessage]) ifTrue:[
node == node parent receiver ifTrue:[
selectorOfMessageToNode := node parent selector
]
].
nm isUppercaseFirst ifTrue:[
globalFactor := 2.
localFactor := 1.
] ifFalse:[
globalFactor := 1.
localFactor := 2.
].
getDistanceComputeBlockWithWeight :=
[:weight |
[:each |
|dist factor|
dist := each spellAgainst:nm.
factor := 1.
(each startsWith:nm) ifTrue:[
factor := 4 * nm size.
] ifFalse:[
(each asLowercase startsWith:nm asLowercase) ifTrue:[
factor := 3 * nm size.
].
].
dist := dist + (weight*factor).
each -> (dist * weight)
]
].
addWithFactorBlock :=
[:names :factor | |namesToAdd|
namesToAdd := names select:[:nameToAdd | nameToAdd ~= nm ].
namesToAdd := namesToAdd reject:[:each | allVariables includes:each ].
allVariables addAll:namesToAdd.
allDistances addAll:(namesToAdd collect:(getDistanceComputeBlockWithWeight value:factor)).
].
allVariables := OrderedCollection new.
allDistances := OrderedCollection new.
"/ locals in the block/method
names := node allVariablesOnScope.
"/ if there were no variables (due to a parse error)
"/ do another parse and see what we have
names isEmpty ifTrue:[
tree := self treeForCode:(codeView contentsAsString string) allowErrors:true.
"/ better if we already have a body (include locals then)
"/ otherwise, only the arguments are considered
names := (tree body ? tree) allVariablesOnScope.
].
addWithFactorBlock value:names value:(4 * localFactor).
"/ instance variables
addWithFactorBlock value:cls instVarNames value:(3 * localFactor).
"/ inherited instance variables
cls superclass notNil ifTrue:[
addWithFactorBlock value:cls superclass allInstVarNames value:(2.5 * localFactor).
].
selectorOfMessageToNode notNil ifTrue:[
|names responders nonResponders|
"/ responding to that messsage
"/ class variables
names := nonMetaClass classVarNames.
responders := names select:[:classVar | (nonMetaClass classVarAt:classVar) respondsTo:selectorOfMessageToNode].
nonResponders := names reject:[:classVar | (nonMetaClass classVarAt:classVar) respondsTo:selectorOfMessageToNode].
addWithFactorBlock value:responders value:(1.5 * globalFactor).
addWithFactorBlock value:nonResponders value:(0.5 * 1.5 * globalFactor).
nonMetaClass allSuperclassesDo:[:superClass |
names := superClass classVarNames.
responders := names select:[:classVar | (superClass classVarAt:classVar) respondsTo:selectorOfMessageToNode].
nonResponders := names reject:[:classVar | (superClass classVarAt:classVar) respondsTo:selectorOfMessageToNode].
addWithFactorBlock value:responders value:(1 * globalFactor).
addWithFactorBlock value:nonResponders value:(0.5 * 1 * globalFactor).
].
"/ globals
cls nameSpace ~~ Smalltalk ifTrue:[
names := cls topNameSpace keys.
names := names reject:[:nm | nm includes:$:].
names := names select:[:nm | nm isUppercaseFirst ].
responders := names select:[:nsVar | |c| c := cls topNameSpace at:nsVar. c isBehavior not or:[c isLoaded and:[c respondsTo:selectorOfMessageToNode]]].
nonResponders := names reject:[:nsVar | |c| c := cls topNameSpace at:nsVar. c isBehavior not or:[c isLoaded and:[c respondsTo:selectorOfMessageToNode]]].
addWithFactorBlock value:responders value:(1.5 * globalFactor).
addWithFactorBlock value:nonResponders value:(0.5 * 1.5 * globalFactor).
].
names := Smalltalk keys.
names := names reject:[:nm | nm includes:$:].
names := names select:[:nm | nm isUppercaseFirst ].
responders := names select:[:glblVar | |c| c := Smalltalk at:glblVar. c isBehavior not or:[c isLoaded and:[c respondsTo:selectorOfMessageToNode]]].
nonResponders := names reject:[:glblVar | |c| c := Smalltalk at:glblVar. c isBehavior not or:[c isLoaded and:[c respondsTo:selectorOfMessageToNode]]].
addWithFactorBlock value:responders value:(1.5 * globalFactor).
addWithFactorBlock value:nonResponders value:(0.5 * 1.5 * globalFactor).
] ifFalse:[
"/ class variables
addWithFactorBlock value:nonMetaClass classVarNames value:(1.5 * globalFactor).
cls superclass notNil ifTrue:[
addWithFactorBlock value:nonMetaClass superclass allClassVarNames value:(1 * globalFactor).
].
"/ globals
cls nameSpace ~~ Smalltalk ifTrue:[
names := cls nameSpace isNameSpace ifTrue:[cls nameSpace keys] ifFalse:[cls nameSpace privateClasses collect:[:c | c nameWithoutPrefix]].
names := names select:[:nm | nm isUppercaseFirst ].
addWithFactorBlock value:names value:(1.5 * globalFactor).
].
names := Smalltalk keys.
names := names select:[:nm | nm isUppercaseFirst ].
addWithFactorBlock value:names value:(1.5 * globalFactor).
].
"/ pseudos - assuming that thisContext is seldom used.
"/ also assuming, that nil is short so its usually typed in.
addWithFactorBlock value:#('self') value:(2.5 * localFactor).
addWithFactorBlock value:#('nil') value:(0.5 * localFactor).
addWithFactorBlock value:#('super' 'false') value:(2 * localFactor).
addWithFactorBlock value:#('thisContext') value:(1 * localFactor).
bestAssoc := allDistances at:1.
bestAssoc := allDistances inject:bestAssoc into:[:el :best | el value > best value
ifTrue:[el]
ifFalse:[best]
].
allDistances sort:[:a :b | a value > b value].
allTheBest := allDistances select:[:entry | entry value >= (bestAssoc value * 0.8)].
best := self askUserForCompletion:'variable' for:codeView from:(allTheBest collect:[:assoc | assoc key]).
best isNil ifTrue:[^ self].
"/ self showInfo:best.
start := node start.
stop := node stop.
oldVar := (codeView textFromCharacterPosition:start to:stop) asString string withoutSeparators.
codeView
undoableDo:[ codeView replaceFromCharacterPosition:start to:stop with:best ]
info:'completion'.
(best startsWith:oldVar) ifTrue:[
oldLen := stop - start + 1.
newLen := best size.
codeView selectFromCharacterPosition:start+oldLen to:start+newLen-1.
codeView dontReplaceSelectionOnInput
].
"Created: / 10-11-2006 / 13:16:33 / cg"
"Modified: / 16-11-2006 / 14:15:59 / cg"
!
findNodeForInterval:interval in:source
|tree node|
interval isEmpty ifTrue: [^ nil].
RBParser isNil ifTrue: [^ nil].
tree := RBParser
parseMethod:source
onError: [:str :err ":nodesSoFar" | ^ nil].
tree isNil ifTrue:[^ nil].
node := tree whichNodeIsContainedBy:interval.
node isNil ifTrue: [
node := tree bestNodeFor: interval
].
node isNil ifTrue: [
node := DoWhatIMeanSupport findNodeIn:tree forInterval:interval
].
^ node
"Modified: / 16-11-2006 / 19:04:03 / cg"
!
findNodeForInterval:interval in:source allowErrors:allowErrors
|tree "errCount"|
interval isEmpty ifTrue: [^ nil].
RBParser isNil ifTrue: [^ nil].
tree := RBParser
parseMethod:source
onError: [:str :err :nodesSoFar |
|nodes|
allowErrors ifTrue:[
nodes := nodesSoFar
collect:[:nd | nd whichNodeIntersects:interval]
thenSelect:[:nd | nd notNil ].
nodes size == 1 ifTrue:[
^ nodes first
].
].
^ nil]
rememberNodes:true.
"/ onError: [:str :err | errCount := (errCount?0) + 1. self halt.]
"/ proceedAfterError:true.
^ self findNodeForInterval:interval inParseTree:tree.
!
findNodeForInterval:interval inParseTree:parseTree
|node|
interval isEmpty ifTrue: [^ nil].
parseTree isNil ifTrue:[^ nil].
node := parseTree whichNodeIsContainedBy:interval.
node isNil ifTrue: [
node := self findNodeIn:parseTree forInterval:interval
].
^ node
"Modified: / 10-11-2006 / 13:13:58 / cg"
!
findNodeIn:tree forInterval:interval
|node wouldReturn|
node := nil.
tree nodesDo:[:each |
(each intersectsInterval:interval) ifTrue:[
(node isNil or:[node == each parent]) ifTrue:[
node := each
] ifFalse:[
(node parent notNil
and:[node parent isCascade and:[each parent isCascade]]) ifFalse:[^ nil]
]
] ifFalse:[
node notNil ifTrue:[
"/ already found one - beyond that one; leave
wouldReturn notNil ifTrue:[wouldReturn := node].
]
].
].
"/ (wouldReturn notNil and:[wouldReturn ~~ node]) ifTrue:[self halt].
^ node
"Modified: / 20-11-2006 / 12:31:12 / cg"
!
treeForCode:source allowErrors:allowErrors
|tree|
tree := RBParser
parseMethod:source
onError: [:str :err :nodesSoFar :parser|
allowErrors ifTrue:[
^ parser currentMethodNode
].
^ nil
]
proceedAfterError:false
rememberNodes:true.
^ tree
! !
!DoWhatIMeanSupport class methodsFor:'input completion support'!
classCategoryCompletion:aPartialCategory inEnvironment:anEnvironment
"given a partial class category name, return an array consisting of
2 entries: 1st: the best (longest) match
2nd: collection consisting of matching categories"
|matches best lcName|
matches := IdentitySet new.
"/ search for exact match
anEnvironment allClassesDo:[:aClass |
|category|
category := aClass category.
(category notNil and:[category startsWith:aPartialCategory]) ifTrue:[
matches add:category
]
].
matches isEmpty ifTrue:[
"/ search for case-ignoring match
lcName := aPartialCategory asLowercase.
anEnvironment allClassesDo:[:aClass |
|category|
category := aClass category.
(category notNil and:[category asLowercase startsWith:lcName]) ifTrue:[
matches add:category
].
].
].
matches isEmpty ifTrue:[
^ Array with:aPartialCategory with:(Array with:aPartialCategory)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
best := matches longestCommonPrefix.
^ Array with:best with:matches asArray
"
Smalltalk classCategoryCompletion:'Sys'
Smalltalk classCategoryCompletion:'System'
Smalltalk classCategoryCompletion:'System-BinaryStorage'
"
"Created: / 10-08-2006 / 13:06:45 / cg"
!
classNameEntryCompletionBlock
"this block can be used in a dialog to perform className completion"
^ self entryCompletionBlockFor:#'classnameCompletion:inEnvironment:'
"Modified: / 10-08-2006 / 13:22:02 / cg"
!
classnameCompletion:aPartialClassName filter:filterBlock inEnvironment:anEnvironment
"given a partial classname, return an array consisting of
2 entries: 1st: the best (longest) match
2nd: collection consisting of matching names"
|searchName matches matchedNamesWithoutPrefix ignCaseMatches best isMatchString cls nsPrefix
others lcSearchName tryToMatch idx words w1 w2 rslt bestMatch|
aPartialClassName isEmpty ifTrue:[
matches := Smalltalk allClassesForWhich:filterBlock.
^ Array with:aPartialClassName with:#()
].
(words := aPartialClassName asCollectionOfWords) size > 1 ifTrue:[
w1 := words first.
w2 := words second.
rslt := self classnameCompletion:w1 filter:filterBlock inEnvironment:anEnvironment.
bestMatch := rslt first.
matches := rslt second.
('class' copyTo:w2 size) = w2 ifTrue:[
matches := matches collect:[:m | m , ' class'].
bestMatch := bestMatch , ' class'.
].
^ Array with:bestMatch with:matches
].
(aPartialClassName startsWith:'Smalltalk::') ifTrue:[
nsPrefix := 'Smalltalk::'.
searchName := aPartialClassName copyFrom:'Smalltalk::' size + 1
] ifFalse:[
nsPrefix := ''.
searchName := aPartialClassName.
].
(searchName at:1) isLowercase ifTrue:[
searchName := searchName copy asUppercaseFirst
].
lcSearchName := searchName asLowercase.
isMatchString := searchName includesMatchCharacters.
matches := OrderedCollection new.
matchedNamesWithoutPrefix := Set new.
ignCaseMatches := OrderedCollection new.
others := OrderedCollection new.
tryToMatch := [:className :fullClassName|
|addIt lcClassName|
isMatchString ifTrue:[
addIt := searchName match:className
] ifFalse:[
addIt := className startsWith:searchName.
].
addIt ifTrue:[
matches add:(nsPrefix , fullClassName).
matchedNamesWithoutPrefix add:className.
] ifFalse:[
"/ try ignoring case
isMatchString ifTrue:[
addIt := searchName match:className ignoreCase:true
] ifFalse:[
lcClassName := className asLowercase.
addIt := lcClassName startsWith:lcSearchName.
addIt ifFalse:[
others add:className
]
].
addIt ifTrue:[
ignCaseMatches add:(nsPrefix , fullClassName).
matchedNamesWithoutPrefix add:className.
].
].
addIt
].
anEnvironment allClassesForWhich:filterBlock do:[:aClass |
|addIt fullClassName classNameWithoutPrefix|
aClass isMeta ifFalse:[
fullClassName := aClass name.
classNameWithoutPrefix := aClass nameWithoutPrefix.
addIt := tryToMatch value:fullClassName value:fullClassName.
addIt ifFalse:[
classNameWithoutPrefix ~~ fullClassName ifTrue:[
tryToMatch value:classNameWithoutPrefix value:fullClassName.
].
].
]
].
matches isEmpty ifTrue:[
matches := ignCaseMatches
].
"/ matches isEmpty ifTrue:[
"/ | nearBy |
"/ nearBy := SortedCollection new sortBlock:[:a :b | a key < b key].
"/ others do:[:className |
"/ |lcClassName dist cmpName|
"/
"/ lcClassName := className asLowercase.
"/ dist := lcClassName levenshteinTo:lcSearchName s:9 k:1 c:0 i:9 d:2.
"/
"/ cmpName := lcClassName copyTo:(lcSearchName size min:lcClassName size).
"/ dist := dist min:(cmpName levenshteinTo:lcSearchName s:9 k:1 c:0 i:9 d:2).
"/ cmpName := lcClassName copyTo:(lcSearchName size + 1 min:lcClassName size).
"/ dist := dist min:(cmpName levenshteinTo:lcSearchName s:9 k:1 c:0 i:9 d:2).
"/ dist < 4 ifTrue:[
"/ nearBy add:( dist -> (nsPrefix , className) ).
"/ ]
"/ ].
"/ matches := nearBy collect:[:eachPair | eachPair value].
"/ ].
matches isEmpty ifTrue:[
^ Array with:searchName with:(Array with:searchName)
].
matches size == 1 ifTrue:[
best := matches first.
^ Array with:best with:(matches asArray)
].
matches
sort:[:name1 :name2 |
"name1 comes before:name2 iff"
((name2 includes:$:) and:[(name1 includes:$:) not])
or:[ ((name1 includes:$:) == (name2 includes:$:))
and:[ (name1 size < name2 size)
or: [ name1 < name2 ]]
]
].
isMatchString ifTrue:[
best := searchName.
] ifFalse:[
best := matches longestCommonPrefix.
best size < aPartialClassName size "best size == 0" ifTrue:[
best := matchedNamesWithoutPrefix longestCommonPrefix.
].
best size == 0 ifTrue:[
"if tried again, return next match"
idx := ((matches indexOf:aPartialClassName) + 1) \\ matches size.
idx ~~ 1 ifTrue:[
^ Array with:(matches at:idx) with:(matches asArray)
].
].
best size < aPartialClassName size ifTrue:[
best := aPartialClassName.
].
].
cls := anEnvironment classNamed:best.
(cls isBehavior and:[cls isNameSpace]) ifTrue:[
(matches conform:[:each | each = best
or:[each startsWith:(best , '::')]])
ifTrue:[
best := best , '::'
].
].
^ Array with:best with:matches asArray
"
Smalltalk classnameCompletion:'Arr'
Smalltalk classnameCompletion:'Arra'
Smalltalk classnameCompletion:'arra'
Smalltalk classnameCompletion:'*rray'
"
"Created: / 10-08-2006 / 13:01:08 / cg"
!
classnameCompletion:aPartialClassName inEnvironment:anEnvironment
"given a partial classname, return an array consisting of
2 entries: 1st: the best (longest) match
2nd: collection consisting of matching names"
^ self
classnameCompletion:aPartialClassName
filter:[:cls | true]
inEnvironment:anEnvironment
"
Smalltalk classnameCompletion:'Arr'
Smalltalk classnameCompletion:'Arra'
Smalltalk classnameCompletion:'arra'
Smalltalk classnameCompletion:'*rray'
"
"Created: / 24-11-1995 / 17:24:45 / cg"
"Modified: / 10-08-2006 / 13:01:30 / cg"
!
entryCompletionBlockFor:completionSelector
"this block can be used in a dialog to perform className completion"
^ [:contents :field |
|s what m|
s := contents withoutSpaces.
field topView withCursor:(Cursor questionMark) do:[
what := self perform:completionSelector with:s with:Smalltalk.
].
field contents:(what first).
(what at:2) size ~~ 1 ifTrue:[
field device beep
]
].
"Created: / 10-08-2006 / 13:21:37 / cg"
!
globalNameCompletion:aPartialGlobalName inEnvironment:anEnvironment
"given a partial globalName, return an array consisting of
2 entries: 1st: the best (longest) match
2nd: collection consisting of matching names"
|searchName matches ignCaseMatches best isMatchString|
searchName := aPartialGlobalName.
searchName isEmpty ifTrue:[
^ Array with:searchName with:#()
].
(searchName at:1) isLowercase ifTrue:[
searchName := searchName copy asUppercaseFirst
].
isMatchString := searchName includesMatchCharacters.
matches := OrderedCollection new.
ignCaseMatches := OrderedCollection new.
anEnvironment keysDo:[:aGlobalName |
| addIt|
isMatchString ifTrue:[
addIt := searchName match:aGlobalName
] ifFalse:[
addIt := aGlobalName startsWith:searchName
].
addIt ifTrue:[
matches add:aGlobalName
] ifFalse:[
"/ try ignoring case
isMatchString ifTrue:[
addIt := searchName match:aGlobalName ignoreCase:true
] ifFalse:[
addIt := aGlobalName asLowercase startsWith:searchName asLowercase
].
addIt ifTrue:[
ignCaseMatches add:aGlobalName
]
]
].
matches isEmpty ifTrue:[
matches := ignCaseMatches
].
matches isEmpty ifTrue:[
^ Array with:searchName with:(Array with:searchName)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
isMatchString ifTrue:[
best := searchName.
] ifFalse:[
best := matches longestCommonPrefix.
].
^ Array with:best with:matches asArray
"
Smalltalk globalnameCompletion:'Arr'
Smalltalk globalnameCompletion:'Arra'
Smalltalk globalnameCompletion:'arra'
Smalltalk globalnameCompletion:'*rray'
"
"Created: / 10-08-2006 / 13:06:23 / cg"
!
methodProtocolCompletion:aPartialProtocolName inEnvironment:anEnvironment
"given a partial method protocol name, return an array consisting of
2 entries: 1st: the best (longest) match
2nd: collection consisting of matching protocols"
|matches best lcName|
matches := IdentitySet new.
"/ search for exact match
anEnvironment allClassesDo:[:aClass |
aClass instAndClassSelectorsAndMethodsDo:[:aSelector :aMethod |
|protocol|
protocol := aMethod category.
(protocol notNil and:[protocol startsWith:aPartialProtocolName]) ifTrue:[
matches add:protocol
]
].
].
matches isEmpty ifTrue:[
"/ search for case-ignoring match
lcName := aPartialProtocolName asLowercase.
anEnvironment allClassesDo:[:aClass |
aClass instAndClassSelectorsAndMethodsDo:[:aSelector :aMethod |
|protocol|
protocol := aMethod category.
(protocol asLowercase startsWith:lcName) ifTrue:[
matches add:protocol
]
].
].
].
matches isEmpty ifTrue:[
^ Array with:aPartialProtocolName with:(Array with:aPartialProtocolName)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
best := matches longestCommonPrefix.
^ Array with:best with:matches asArray
"
Smalltalk methodProtocolCompletion:'doc'
Smalltalk methodProtocolCompletion:'docu'
Smalltalk methodProtocolCompletion:'documenta'
"
"Created: / 10-08-2006 / 13:05:27 / cg"
!
nameSpaceCompletion:aPartialClassName inEnvironment:anEnvironment
"given a partial name, return an array consisting of
2 entries: 1st: the best (longest) match
2nd: collection consisting of matching names"
^ self
classnameCompletion:aPartialClassName
filter:[:cls | cls isNameSpace]
inEnvironment:anEnvironment
"
DoWhatIMeanSupport nameSpaceCompletion:'To' inEnvironment:Smalltalk
"
"Created: / 10-08-2006 / 13:02:16 / cg"
!
packageCompletion:aPartialPackage inEnvironment:anEnvironment
"given a partial package name, return an array consisting of
2 entries: 1st: the best (longest) match
2nd: collection consisting of matching packages"
|matches best lcName|
matches := IdentitySet new.
"/ search for exact match
anEnvironment allClassesDo:[:aClass |
|package|
package := aClass package.
(package notNil and:[package startsWith:aPartialPackage]) ifTrue:[
matches add:package
]
].
matches isEmpty ifTrue:[
"/ search for case-ignoring match
lcName := aPartialPackage asLowercase.
anEnvironment allClassesDo:[:aClass |
|package|
package := aClass package.
(package notNil and:[package asLowercase startsWith:lcName]) ifTrue:[
matches add:package
].
].
].
matches isEmpty ifTrue:[
^ Array with:aPartialPackage with:(Array with:aPartialPackage)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
best := matches longestCommonPrefix.
^ Array with:best with:matches asArray
"
DoWhatIMeanSupport packageCompletion:'stx:' inEnvironment:Smalltalk
DoWhatIMeanSupport packageCompletion:'stx:libw' inEnvironment:Smalltalk
"
"Created: / 10-08-2006 / 13:05:07 / cg"
!
packageNameEntryCompletionBlock
"this block can be used in a dialog to perform className completion"
^ self entryCompletionBlockFor:#'packageCompletion:inEnvironment:'
"Created: / 10-08-2006 / 13:22:31 / cg"
!
selectorCompletion:aPartialSymbolName inEnvironment:anEnvironment
"given a partial selector, return an array consisting of
2 entries: 1st: the longest match
2nd: collection consisting of matching implemented selectors"
|matches best lcSym|
matches := IdentitySet new.
"/ search for exact match
anEnvironment allClassesDo:[:aClass |
aClass instAndClassSelectorsAndMethodsDo:[:aSelector :aMethod |
(aSelector startsWith:aPartialSymbolName) ifTrue:[
matches add:aSelector
]
].
].
matches isEmpty ifTrue:[
"/ search for case-ignoring match
lcSym := aPartialSymbolName asLowercase.
anEnvironment allClassesDo:[:aClass |
aClass instAndClassSelectorsAndMethodsDo:[:aSelector :aMethod |
(aSelector asLowercase startsWith:lcSym) ifTrue:[
matches add:aSelector
]
].
].
].
matches isEmpty ifTrue:[
^ Array with:aPartialSymbolName with:(Array with:aPartialSymbolName)
].
matches size == 1 ifTrue:[
^ Array with:matches first with:(matches asArray)
].
matches := matches asSortedCollection.
best := matches longestCommonPrefix.
^ Array with:best with:matches asArray
"
Smalltalk selectorCompletion:'at:p'
Smalltalk selectorCompletion:'nextP'
Smalltalk selectorCompletion:'nextp'
"
"Modified: / 7.6.1996 / 08:44:33 / stefan"
"Modified: / 14.6.1998 / 15:54:03 / cg"
! !
!DoWhatIMeanSupport class methodsFor:'rename support'!
goodRenameDefaultFor:oldName lastOld:lastOldName lastNew:lastNewName
"generate a reasonable default for a rename operation.
(used for rename category etc.)"
|prefix suffix lastNewSize lastOldSize left right inserted deleted|
lastNewName isNil ifTrue:[ ^ nil].
lastNewSize := lastNewName size.
lastOldSize := lastOldName size.
(lastNewName endsWith:lastOldName) ifTrue:[
"last rename was
'foo' -> 'Xfoo'
then, a good default for
'bar' would be 'Xbar'
"
prefix := lastNewName copyTo:(lastNewSize - lastOldSize).
^ (prefix , oldName).
].
(lastOldName endsWith:lastNewName) ifTrue:[
"last rename was
'Xfoo' -> 'foo'
then, a good default for
'Xbar' would be 'bar'
"
prefix := lastOldName copyTo:(lastOldSize - lastNewSize).
(oldName startsWith:prefix) ifTrue:[
^ (oldName copyFrom:prefix size+1).
]
].
(lastOldName asLowercase = lastNewName asLowercase) ifTrue:[
(lastOldName first ~= lastNewName first) ifTrue:[
(lastOldName first isLowercase = oldName first isLowercase) ifTrue:[
"last rename was
'xfoo' -> 'Xfoo'
then, a good default for
'xbar' would be 'Xbar'
"
lastOldName first isLowercase ifTrue:[
^ oldName first asUppercase asString , (oldName copyFrom:2).
] ifFalse:[
^ oldName first asLowercase asString , (oldName copyFrom:2).
]
]
].
].
(lastOldName withoutSeparators = lastNewName) ifTrue:[
"last rename was
' foo ' -> 'foo'
then, a good default for
' bar ' would be 'bar'
"
^ oldName withoutSeparators.
].
(lastNewName startsWith:lastOldName) ifTrue:[
"last rename was
'foo' -> 'fooX'
then, a good default for
'bar' would be 'barX'
"
suffix := lastNewName copyLast:(lastNewSize - lastOldSize).
^ (oldName , suffix).
].
(lastOldName startsWith:lastNewName) ifTrue:[
"last rename was
'fooX' -> 'foo'
then, a good default for
'barX' would be 'bar'
"
suffix := lastOldName copyLast:(lastOldSize - lastNewSize).
(oldName endsWith:suffix) ifTrue:[
^ (oldName copyWithoutLast:suffix size).
]
].
prefix := lastOldName commonPrefixWith:lastNewName.
suffix := lastOldName commonSuffixWith:lastNewName.
(prefix size > 0) ifTrue:[
(suffix size > 0) ifTrue:[
prefix := prefix copyTo:(((lastNewName size - suffix size) min:(lastOldName size - suffix size)) min:prefix size).
"last rename was
'fooR' -> 'fooXR'
then, a good default for
'barR' would be 'barXR'
"
left := lastOldName copyTo:prefix size.
right := lastOldName copyLast:suffix size.
lastNewSize > lastOldSize ifTrue:[
inserted := (lastNewName copyFrom:(left size + 1)) copyWithoutLast:(right size).
inserted size > 0 ifTrue:[
^ (oldName copyTo:prefix size) , inserted , (oldName copyFrom:prefix size + 1)
].
].
(oldName endsWith:suffix) ifTrue:[
deleted := (lastOldName copyFrom:(prefix size + 1)) copyWithoutLast:(suffix size).
((oldName copyFrom:oldName size-suffix size-deleted size + 1) copyTo:deleted size) = deleted ifTrue:[
"last rename was
'fooXR' -> 'fooR'
then, a good default for
'barXS' would be 'barS'
"
^ (oldName copyTo:oldName size-suffix size-deleted size) , suffix
]
]
].
(oldName endsWith:(lastOldName copyFrom:prefix size+1)) ifTrue:[
"last rename was
'fooX' -> 'fooY'
then, a good default for
'barX' would be 'barY'
"
left := oldName copyWithoutLast:(lastOldName copyFrom:prefix size+1) size.
right := lastNewName copyFrom:prefix size+1.
^ left , right
]
].
^ nil
"
self goodRenameDefaultFor:'bar' lastOld:'foo' lastNew:'fooXX'
self goodRenameDefaultFor:'bar' lastOld:'foo' lastNew:'XXfoo'
self goodRenameDefaultFor:'barXX' lastOld:'fooXX' lastNew:'foo'
self goodRenameDefaultFor:'XXbar' lastOld:'XXfoo' lastNew:'foo'
self goodRenameDefaultFor:'barXX' lastOld:'fooXX' lastNew:'fooYY'
self goodRenameDefaultFor:'XXbar' lastOld:'XXfoo' lastNew:'foo'
self goodRenameDefaultFor:'bar2' lastOld:'foo1' lastNew:'foo01'
self goodRenameDefaultFor:'barXY' lastOld:'fooXY' lastNew:'fooY'
self goodRenameDefaultFor:'bar' lastOld:'foo' lastNew:'fXoo'
self goodRenameDefaultFor:'bar' lastOld:'foo' lastNew:'fXXXoo'
self goodRenameDefaultFor:'bar' lastOld:'foo' lastNew:'foXXXo'
self goodRenameDefaultFor:'bar001' lastOld:'foo001' lastNew:'foo002_001'
self goodRenameDefaultFor:'CoastCore-CSFoo' lastOld:'CoastCore-CSBar' lastNew:'Coast-Core-CSBar'
"
!
goodRenameDefaultForFile:oldName lastOld:lastOldName lastNew:lastNewName
"generate a reasonable default for a file rename operation.
(Try to rename multiple files in the new fileBrowser,
to see what this is doing)"
|prefix suffix t
lastOldWOSuffix lastNewWOSuffix oldWOSuffix lastOldRest oldRest lastNewRest
lastRemoved lastInserted default|
default := self goodRenameDefaultFor:oldName lastOld:lastOldName lastNew:lastNewName.
default notNil ifTrue:[ ^ default].
lastOldWOSuffix := lastOldName asFilename nameWithoutSuffix.
lastNewWOSuffix := lastNewName asFilename nameWithoutSuffix.
oldWOSuffix := oldName asFilename nameWithoutSuffix.
"/ suffix change ?
lastOldWOSuffix = lastNewWOSuffix ifTrue:[
lastOldName asFilename suffix ~= lastNewName asFilename suffix ifTrue:[
^ (oldName asFilename withSuffix:(lastNewName asFilename suffix)) pathName
].
].
default := self goodRenameDefaultFor:oldWOSuffix lastOld:lastOldWOSuffix lastNew:lastNewWOSuffix.
default notNil ifTrue:[
lastOldRest := lastOldName copyFrom:lastOldWOSuffix size + 1.
lastNewRest := lastNewName copyFrom:lastNewWOSuffix size + 1.
oldRest := oldName copyFrom:oldWOSuffix size + 1.
^ default , lastNewRest
].
prefix := lastOldWOSuffix commonPrefixWith:oldWOSuffix.
(lastNewWOSuffix startsWith:prefix) ifTrue:[
lastOldRest := lastOldWOSuffix copyFrom:prefix size + 1.
lastNewRest := lastNewWOSuffix copyFrom:prefix size + 1.
oldRest := oldWOSuffix copyFrom:prefix size + 1.
(lastNewRest endsWith:lastOldRest) ifTrue:[
t := lastNewRest copyWithoutLast:lastOldRest size.
^ ((prefix , t , oldRest) asFilename withSuffix:oldName asFilename suffix) name
].
].
suffix := lastOldWOSuffix commonSuffixWith:lastNewWOSuffix.
suffix size > 0 ifTrue:[
"/ last change changed something at the beginning
prefix := oldWOSuffix commonPrefixWith:lastOldWOSuffix.
prefix size > 0 ifTrue:[
"/ this name starts with the same characters
lastRemoved := lastOldWOSuffix copyWithoutLast:suffix size.
lastInserted := lastNewWOSuffix copyWithoutLast:suffix size.
(lastRemoved startsWith:lastInserted) ifTrue:[
oldWOSuffix size >= lastInserted size ifTrue:[
^ (oldWOSuffix copyTo:lastInserted size) , (oldName copyFrom:lastRemoved size + 1)
]
].
^ lastInserted , (oldName copyFrom:lastRemoved size + 1)
].
].
^ nil
"Modified: / 07-11-2006 / 13:58:39 / cg"
! !
!DoWhatIMeanSupport class methodsFor:'typing distance'!
isKey:k1 nextTo:k2
"return true, if k1 and k2 are adjacent keys on the keyboard.
This is used to specially priorize plausible typing errors of adjacent keys.
CAVEAT: hard coded us- and german keyboards here."
|keys|
"/ for now: hardcoded US keyboard (should be language dependent)
"/ (i.e. ask UserPreferences current ...)
UserPreferences current language == #de ifTrue:[
keys := #(
'1234567890-'
'*qwertzuiop'
'**asdfghjkl:'
'***yxcvbnm' ).
] ifFalse:[
keys := #(
'1234567890-'
'*qwertyuiop'
'**asdfghjkl:'
'***zxcvbnm' ).
].
^ self isKey:k1 nextTo:k2 onKeyboard:keys
"
self isKey:$a nextTo:$a
self isKey:$a nextTo:$s
self isKey:$a nextTo:$q
self isKey:$a nextTo:$w
self isKey:$a nextTo:$z
self isKey:$a nextTo:$x
"
!
isKey:k1 nextTo:k2 onKeyboard:keys
"return true, if k1 and k2 are adjacent keys on the keyboard defined by keys"
|row1 row2 col1 col2|
row1 := keys findFirst:[:eachRow | col1 := eachRow indexOf:k1. col1 ~~ 0].
row1 == 0 ifTrue:[^ false].
row2 := keys findFirst:[:eachRow | col2 := eachRow indexOf:k2. col2 ~~ 0].
row2 == 0 ifTrue:[^ false].
^ (row1-row2) abs <= 1 and:[(col1-col2) abs <= 1]
"
self isKey:$a nextTo:$q
self isKey:$a nextTo:$x
"
! !
!DoWhatIMeanSupport class methodsFor:'documentation'!
version
^ '$Header: /cvs/stx/stx/libwidg2/DoWhatIMeanSupport.st,v 1.26 2008-01-10 12:02:28 cg Exp $'
! !