[Pkg] Squeak3.10bc: Protocols-kph.13.mcz
squeak-dev-noreply at lists.squeakfoundation.org
squeak-dev-noreply at lists.squeakfoundation.org
Sat Dec 13 04:52:54 UTC 2008
A new version of Protocols was added to project Squeak3.10bc:
http://www.squeaksource.com/310bc/Protocols-kph.13.mcz
==================== Summary ====================
Name: Protocols-kph.13
Author: kph
Time: 13 December 2008, 4:52:52 am
UUID: fdd23690-6c50-45f3-8659-99433d3f0832
Ancestors: Protocols-md.12
Saved from SystemVersion
==================== Snapshot ====================
SystemOrganization addCategory: #'Protocols-Kernel'!
SystemOrganization addCategory: #'Protocols-Type Vocabularies'!
Object subclass: #ElementTranslation
instanceVariableNames: 'wording helpMessage naturalLanguageSymbol'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
----- Method: ElementTranslation>>helpMessage (in category 'access') -----
helpMessage
"Answer the helpMessage"
^ helpMessage!
Object subclass: #ObjectWithDocumentation
instanceVariableNames: 'authoringStamp properties elementSymbol naturalLanguageTranslations'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
!ObjectWithDocumentation commentStamp: '<historical>' prior: 0!
ObjectWithDocumentation - an abstract superclass for objects that allows maintenance of an authoring stamp, a body of documentation, and a properties dictionary.
The Properties implementation has not happened yet -- it would closely mirror the implemenation of properties in the MorphExtension, for example.!
ObjectWithDocumentation subclass: #ElementCategory
instanceVariableNames: 'categoryName keysInOrder elementDictionary'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
!ElementCategory commentStamp: '<historical>' prior: 0!
ElementCategory
Contains a list of elements that affords keyed access but also has an inherent order.
Add items to the category by sending it elementAt:put:.
Obtain the elements in order by sending #elementsInOrder
Obtain the value of an element at a given key by sending #elementAt:!
----- Method: ElementCategory>>addCategoryItem: (in category 'initialization') -----
addCategoryItem: anItem
"Add the item at the end, obtaining its key from itself (it must respond to #categoryName)"
self elementAt: anItem categoryName put: anItem!
----- Method: ElementCategory>>categoryName (in category 'category name') -----
categoryName
"Answer the formal name of the category"
^ categoryName!
----- Method: ElementCategory>>categoryName: (in category 'category name') -----
categoryName: aName
"Set the category name"
categoryName := aName!
----- Method: ElementCategory>>clear (in category 'initialization') -----
clear
"Clear the receiber's keysInOrder and elementDictionary"
keysInOrder := OrderedCollection new.
elementDictionary := IdentityDictionary new!
----- Method: ElementCategory>>copy (in category 'copying') -----
copy
"Answer a copy of the receiver"
^ super copy copyFrom: self!
----- Method: ElementCategory>>copyFrom: (in category 'copying') -----
copyFrom: donor
"Copy the receiver's contents from the donor"
keysInOrder := donor keysInOrder.
elementDictionary := donor copyOfElementDictionary!
----- Method: ElementCategory>>copyOfElementDictionary (in category 'copying') -----
copyOfElementDictionary
"Answer a copy of the element dictionary"
^ elementDictionary copy!
----- Method: ElementCategory>>elementAt: (in category 'elements') -----
elementAt: aKey
"Answer the element at the given key"
^ elementDictionary at: aKey ifAbsent: [nil]!
----- Method: ElementCategory>>elementAt:put: (in category 'elements') -----
elementAt: sym put: element
"Add symbol at the end of my sorted list (unless it is already present), and put the element in the dictionary"
(keysInOrder includes: sym) ifFalse: [keysInOrder add: sym].
^ elementDictionary at: sym put: element!
----- Method: ElementCategory>>elementSymbol (in category 'elements') -----
elementSymbol
"Answer the element symbol for the receiver. Here, the categoryName dominates"
^ categoryName!
----- Method: ElementCategory>>elementsInOrder (in category 'elements') -----
elementsInOrder
"Answer the elements in order"
^ keysInOrder collect: [:aKey | elementDictionary at: aKey]!
----- Method: ElementCategory>>fasterElementAt:put: (in category 'elements') -----
fasterElementAt: sym put: element
"Add symbol at the end of my sorted list and put the element in the dictionary. This variant adds the key at the end of the keys list without checking whether it already exists."
keysInOrder add: sym.
^ elementDictionary at: sym put: element!
----- Method: ElementCategory>>includesKey: (in category 'keys') -----
includesKey: aKey
"Answer whether the receiver's dictionary holds the given key"
^ elementDictionary includesKey: aKey!
----- Method: ElementCategory>>initWordingAndDocumentation (in category 'private') -----
initWordingAndDocumentation
"Initialize wording and documentation (helpMessage) for getters and setters"
self wording: self categoryName!
----- Method: ElementCategory>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
self clear!
----- Method: ElementCategory>>keysInOrder (in category 'keys') -----
keysInOrder
"Answer the keys in their sorted order"
^ keysInOrder copy!
----- Method: ElementCategory>>placeKey:afterKey: (in category 'elements') -----
placeKey: key1 afterKey: key2
"Place the first key after the second one in my keysInOrder ordering"
keysInOrder remove: key1.
keysInOrder add: key1 after: key2!
----- Method: ElementCategory>>placeKey:beforeKey: (in category 'elements') -----
placeKey: key1 beforeKey: key2
"Place the first key before the second one in my keysInOrder ordering"
keysInOrder remove: key1.
keysInOrder add: key1 before: key2!
----- Method: ElementCategory>>printOn: (in category 'printing') -----
printOn: aStream
"Append to the argument, aStream, a sequence of characters that identifies the receiver."
super printOn: aStream.
categoryName ifNotNil: [aStream nextPutAll: ' named ', categoryName asString]!
----- Method: ElementCategory>>removeElementAt: (in category 'elements') -----
removeElementAt: aKey
"Remove the element at the given key"
elementDictionary removeKey: aKey ifAbsent: [^ self].
keysInOrder remove: aKey ifAbsent: []!
----- Method: ElementCategory>>translated (in category 'translation') -----
translated
"answer the receiver translated to the current language"
^ self class new categoryName: categoryName asString translated asSymbol!
ObjectWithDocumentation subclass: #MethodInterface
instanceVariableNames: 'selector argumentVariables resultSpecification receiverType attributeKeywords defaultStatus'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
!MethodInterface commentStamp: '<historical>' prior: 0!
A MethodInterface describes the interface for a single method. The most generic form is not bound to any particular class or object but rather describes an idealized interface.
selector A symbol - the selector being described
argumentSpecifications A list of specifications for the formal arguments of the method
resultSpecification A characterization of the return value of the method
userLevel
attributeKeywords A list of symbols, comprising keywords that the user wishes to
see on the screen for this method
defaultStatus The status to apply to new instances of the class by default
(#ticking, #paused, #normal, etc.)
!
----- Method: MethodInterface class>>firingInterface (in category 'utilities') -----
firingInterface
"Answer an instance of the receiver representing #fire"
^ self new selector: #fire type: nil setter: nil!
----- Method: MethodInterface class>>isNullMarker: (in category 'utilities') -----
isNullMarker: aMarker
"Answer true if aMarker is nil or is one of the symbols in #(none #nil unused missing) -- to service a variety of historical conventions"
^ aMarker isNil or: [#(none #nil unused missing) includes: aMarker]
"
MethodInterface isNullMarker: nil
MethodInterface isNullMarker: #nil
MethodInterface isNullMarker: #none
MethodInterface isNullMarker: #znak
"!
----- Method: MethodInterface>>argumentVariables (in category 'initialization') -----
argumentVariables
"Answer the list of argumentVariables of the interface"
^ argumentVariables ifNil: [argumentVariables := OrderedCollection new]!
----- Method: MethodInterface>>argumentVariables: (in category 'initialization') -----
argumentVariables: variableList
"Set the argument variables"
argumentVariables := variableList!
----- Method: MethodInterface>>attributeKeywords (in category 'attribute keywords') -----
attributeKeywords
"Answer a list of attribute keywords associated with the receiver"
^ attributeKeywords ifNil: [attributeKeywords := OrderedCollection new]!
----- Method: MethodInterface>>companionSetterSelector (in category 'access') -----
companionSetterSelector
"If there is a companion setter selector, anwer it, else answer nil"
^ resultSpecification ifNotNil:
[resultSpecification companionSetterSelector]!
----- Method: MethodInterface>>conjuredUpFor:class: (in category 'initialization') -----
conjuredUpFor: aSelector class: aClass
"Initialize the receiver to have the given selector, obtaining whatever info one can from aClass. This basically covers the situation where no formal definition has been made."
| parts |
self initializeFor: aSelector.
self wording: aSelector.
receiverType := #unknown.
parts := aClass formalHeaderPartsFor: aSelector.
argumentVariables := (1 to: selector numArgs) collect:
[:anIndex | Variable new name: (parts at: (4 * anIndex)) type: #Object].
parts last isEmptyOrNil ifFalse: [self documentation: parts last].
!
----- Method: MethodInterface>>defaultStatus (in category 'status') -----
defaultStatus
"Answer the receiver's default defaultStatus"
^ defaultStatus!
----- Method: MethodInterface>>defaultStatus: (in category 'status') -----
defaultStatus: aStatus
"Set the receiver's defaultStatus as indicated"
defaultStatus := aStatus!
----- Method: MethodInterface>>elementSymbol (in category 'access') -----
elementSymbol
"Answer the element symbol, for the purposes of translation"
^ selector!
----- Method: MethodInterface>>flagAttribute: (in category 'attribute keywords') -----
flagAttribute: aSymbol
"Mark the receiver as having the given category-keyword"
(self attributeKeywords includes: aSymbol) ifFalse: [attributeKeywords add: aSymbol]!
----- Method: MethodInterface>>flagAttributes: (in category 'attribute keywords') -----
flagAttributes: attributeSymbolList
"Mark the receiver has being flagged with all the symbols in the list provided"
attributeSymbolList do: [:aSym | self flagAttribute: aSym]!
----- Method: MethodInterface>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver"
super initialize.
attributeKeywords := OrderedCollection new.
defaultStatus := #normal.
argumentVariables := OrderedCollection new
!
----- Method: MethodInterface>>initializeFor: (in category 'initialization') -----
initializeFor: aSelector
"Initialize the receiver to have the given selector"
selector := aSelector.
attributeKeywords := OrderedCollection new.
defaultStatus := #normal
!
----- Method: MethodInterface>>initializeFromEToyCommandSpec:category: (in category 'initialization') -----
initializeFromEToyCommandSpec: tuple category: aCategorySymbol
"tuple holds an old etoy command-item spec, of the form found in #additionsToViewerCategories methods. Initialize the receiver to hold the same information"
selector := tuple second.
receiverType := #Player.
selector numArgs = 1 ifTrue:
[argumentVariables := OrderedCollection with:
(Variable new name: (Player formalHeaderPartsFor: selector) fourth type: tuple fourth)].
aCategorySymbol ifNotNil: [self flagAttribute: aCategorySymbol].
self
wording: (ScriptingSystem wordingForOperator: selector);
helpMessage: tuple third!
----- Method: MethodInterface>>initializeFromEToySlotSpec: (in category 'initialization') -----
initializeFromEToySlotSpec: tuple
"tuple holds an old etoy slot-item spec, of the form found in #additionsToViewerCategories methods. Initialize the receiver to hold the same information"
| setter |
selector _ tuple seventh.
self
wording: (ScriptingSystem wordingForOperator: tuple second);
helpMessage: tuple third.
receiverType _ #Player.
resultSpecification _ ResultSpecification new.
resultSpecification resultType: tuple fourth.
(#(getNewClone getTurtleAt: getTurtleOf: "seesColor: isOverColor:") includes: selector)
ifTrue:
[self setNotToRefresh] "actually should already be nil"
ifFalse:
[self setToRefetch].
((tuple fifth == #readWrite) and: [((tuple size >= 9) and: [(setter _ tuple at: 9) ~~ #unused])]) ifTrue:
[resultSpecification companionSetterSelector: setter].
"An example of an old slot-item spec:
(slot numericValue 'A number representing the current position of the knob.' number readWrite Player getNumericValue Player setNumericValue:)
1 #slot
2 wording
3 balloon help
4 type
5 #readOnly or #readWrite
6 #Player (not used -- ignore)
7 getter selector
8 #Player (not used -- ignore)
9 setter selector
"
!
----- Method: MethodInterface>>initializeSetterFromEToySlotSpec: (in category 'initialization') -----
initializeSetterFromEToySlotSpec: tuple
"tuple holds an old etoy slot-item spec, of the form found in #additionsToViewerCategories methods. Initialize the receiver to represent the getter of this item"
selector := tuple ninth.
self
wording: ('set ', tuple second);
helpMessage: ('setter for', tuple third).
receiverType := #Player.
argumentVariables := Array with: (Variable new variableType: tuple fourth)
!
----- Method: MethodInterface>>isFlaggedAs: (in category 'attribute keywords') -----
isFlaggedAs: aSymbol
"Answer whether the receiver is flagged with the given trait"
^ self attributeKeywords includes: aSymbol!
----- Method: MethodInterface>>printOn: (in category 'printing') -----
printOn: aStream
"print the receiver on a stream. Overridden to provide details about wording, selector, result type, and companion setter."
super printOn: aStream.
aStream nextPutAll: ' - wording: ';
print: self wording;
nextPutAll: ' selector: ';
print: selector.
self argumentVariables size > 0 ifTrue:
[aStream nextPutAll: ' Arguments: '.
argumentVariables doWithIndex:
[:aVariable :anIndex |
aStream nextPutAll: 'argument #', anIndex printString, ' name = ', aVariable variableName asString, ', type = ', aVariable variableType]].
resultSpecification ifNotNil:
[aStream nextPutAll: ' result type = ', resultSpecification resultType asString.
resultSpecification companionSetterSelector ifNotNil:
[aStream nextPutAll: ' setter = ', resultSpecification companionSetterSelector asString]]
!
----- Method: MethodInterface>>receiverType (in category 'access') -----
receiverType
"Answer the receiver type"
^ receiverType ifNil: [receiverType := #unknown]!
----- Method: MethodInterface>>receiverType: (in category 'initialization') -----
receiverType: aType
"set the receiver type. Whether the receiverType earns its keep here is not yet well understood. At the moment, this is unsent"
receiverType := aType!
----- Method: MethodInterface>>releaseCachedState (in category 'initialize-release') -----
releaseCachedState
"Sent by player"!
----- Method: MethodInterface>>resultType (in category 'access') -----
resultType
"Answer the result type"
^ resultSpecification
ifNotNil:
[resultSpecification type]
ifNil:
[#unknown]!
----- Method: MethodInterface>>resultType: (in category 'initialization') -----
resultType: aType
"Set the receiver's resultSpecification to be a ResultType of the given type"
resultSpecification := ResultSpecification new.
resultSpecification resultType: aType!
----- Method: MethodInterface>>selector (in category 'access') -----
selector
"Answer the receiver's selector"
^ selector!
----- Method: MethodInterface>>selector:type:setter: (in category 'attribute keywords') -----
selector: aSelector type: aType setter: aSetter
"Set the receiver's fields as indicated. Values of nil or #none for the result type and the setter indicate that there is none"
selector := aSelector.
(MethodInterface isNullMarker: aType) ifFalse:
[resultSpecification := ResultSpecification new.
resultSpecification resultType: aType.
(MethodInterface isNullMarker: aSetter) ifFalse:
[resultSpecification companionSetterSelector: aSetter]]!
----- Method: MethodInterface>>setNotToRefresh (in category 'initialization') -----
setNotToRefresh
"Set the receiver up not to do periodic refresh."
resultSpecification ifNotNil: [resultSpecification refetchFrequency: nil]!
----- Method: MethodInterface>>setToRefetch (in category 'initialization') -----
setToRefetch
"Set the receiver up to expect a refetch, assuming it has a result specification"
resultSpecification ifNotNil: [resultSpecification refetchFrequency: 1]!
----- Method: MethodInterface>>typeForArgumentNumber: (in category 'access') -----
typeForArgumentNumber: anArgumentNumber
"Answer the data type for the given argument number"
| aVariable |
aVariable := self argumentVariables at: anArgumentNumber.
^ aVariable variableType!
----- Method: MethodInterface>>wantsReadoutInViewer (in category 'access') -----
wantsReadoutInViewer
"Answer whether the method represented by the receiver is one which should have a readout in a viewer"
^ resultSpecification notNil and:
[resultSpecification refetchFrequency notNil]!
----- Method: ObjectWithDocumentation>>documentation (in category 'accessing') -----
documentation
"Answer the receiver's documentation"
^self helpMessage!
----- Method: ObjectWithDocumentation>>documentation: (in category 'accessing') -----
documentation: somethingUsefulHopefully
"Set the receiver's documentation, in the current langauge"
self helpMessage: somethingUsefulHopefully!
----- Method: ObjectWithDocumentation>>editDescription (in category 'documentation') -----
editDescription
"Allow the user to see and edit the documentation for this object"
| reply helpMessage |
helpMessage := self documentation isNil
ifTrue: [String new]
ifFalse: [self documentation].
reply := UIManager default
multiLineRequest: 'Kindly edit the description' translated
centerAt: Sensor cursorPoint
initialAnswer: helpMessage
answerHeight: 200.
reply isEmptyOrNil
ifFalse: [self documentation: reply]!
----- Method: ObjectWithDocumentation>>elementSymbol (in category 'miscellaneous') -----
elementSymbol
"Answer the receiver's element symbol"
^ elementSymbol!
----- Method: ObjectWithDocumentation>>getterSetterHelpMessage (in category 'private') -----
getterSetterHelpMessage
"Returns a helpMessage that has been computed previously and needs to be translated and then formatted with the elementSymbol.
'get value of {1}' translated format: {elSym}"
^(self propertyAt: #getterSetterHelpMessage ifAbsent: [^nil])
translated format: {self elementSymbol}!
----- Method: ObjectWithDocumentation>>getterSetterHelpMessage: (in category 'private') -----
getterSetterHelpMessage: aString
"Sets a helpMessage that needs to be translated and then formatted with the elementSymbol.
'get value of {1}' translated format: {elSym}"
self propertyAt: #getterSetterHelpMessage put: aString!
----- Method: ObjectWithDocumentation>>helpMessage (in category 'accessing') -----
helpMessage
"Check if there is a getterSetterHelpMessage.
Otherwise try the normal help message or return nil."
^ self getterSetterHelpMessage
ifNil: [(self propertyAt: #helpMessage ifAbsent:
[self legacyHelpMessage ifNil: [^ nil]]) translated]!
----- Method: ObjectWithDocumentation>>helpMessage: (in category 'accessing') -----
helpMessage: somethingUsefulHopefully
"Set the receiver's documentation, in the current langauge"
self propertyAt: #helpMessage put: somethingUsefulHopefully!
----- Method: ObjectWithDocumentation>>initWordingAndDocumentation (in category 'private') -----
initWordingAndDocumentation
"Initialize wording and documentation (helpMessage) for getters and setters"
| elSym |
elSym := self elementSymbol.
elSym
ifNil: [^self].
((elSym beginsWith: 'get')
and: [elSym size > 3])
ifTrue: [
self wording: (elSym allButFirst: 3) withFirstCharacterDownshifted.
self getterSetterHelpMessage: 'get value of {1}']
ifFalse: [
((elSym beginsWith: 'set')
and: [elSym size > 4])
ifTrue: [
self wording: (elSym allButFirst: 3) withFirstCharacterDownshifted.
self getterSetterHelpMessage: 'set value of {1}']]!
----- Method: ObjectWithDocumentation>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
authoringStamp := Utilities changeStampPerSe
!
----- Method: ObjectWithDocumentation>>legacyHelpMessage (in category 'accessing') -----
legacyHelpMessage
"If I have a help message stashed in my legacy naturalTranslations slot, answer its translated rendition, else answer nil. If I *do* come across a legacy help message, transfer it to my properties dictionary."
| untranslated |
naturalLanguageTranslations isEmptyOrNil "only in legacy (pre-3.8) projects"
ifTrue: [^ nil].
untranslated := naturalLanguageTranslations first helpMessage ifNil: [^ nil].
self propertyAt: #helpMessage put: untranslated.
naturalLanguageTranslations removeFirst.
naturalLanguageTranslations isEmpty ifTrue: [naturalLanguageTranslations := nil].
^ untranslated translated!
----- Method: ObjectWithDocumentation>>migrateWordAndHelpMessage (in category 'migration') -----
migrateWordAndHelpMessage
"Migrate the English wording and help message to the new structure"
| englishElement |
self initWordingAndDocumentation.
(self properties includes: #wording)
ifFalse: [
englishElement := self naturalLanguageTranslations
detect: [:each | each language == #English] ifNone: [^nil].
self wording: englishElement wording.
self helpMessage: englishElement helpMessage]!
----- Method: ObjectWithDocumentation>>naturalLanguageTranslations (in category 'miscellaneous') -----
naturalLanguageTranslations
^naturalLanguageTranslations ifNil: [OrderedCollection new]!
----- Method: ObjectWithDocumentation>>properties (in category 'private') -----
properties
^properties ifNil: [properties := Dictionary new]!
----- Method: ObjectWithDocumentation>>propertyAt: (in category 'private') -----
propertyAt: key
^self propertyAt: key ifAbsent: [nil]!
----- Method: ObjectWithDocumentation>>propertyAt:ifAbsent: (in category 'private') -----
propertyAt: key ifAbsent: aBlock
^properties
ifNil: aBlock
ifNotNil: [properties at: key ifAbsent: aBlock]!
----- Method: ObjectWithDocumentation>>propertyAt:put: (in category 'private') -----
propertyAt: key put: aValue
self properties at: key put: aValue!
----- Method: ObjectWithDocumentation>>untranslatedHelpMessage (in category 'accessing') -----
untranslatedHelpMessage
"Check if there is a getterSetterHelpMessage.
Otherwise try the normal help message or return nil."
^(self propertyAt: #getterSetterHelpMessage ifAbsent: [nil])
ifNil: [(self propertyAt: #helpMessage ifAbsent: [nil])]!
----- Method: ObjectWithDocumentation>>untranslatedWording (in category 'accessing') -----
untranslatedWording
"Answer the receiver's wording"
^self propertyAt: #wording ifAbsent: [nil]!
----- Method: ObjectWithDocumentation>>wording (in category 'accessing') -----
wording
"Answer the receiver's wording"
| wording |
(wording := self propertyAt: #wording ifAbsent: [nil])
ifNotNil: [^wording translated].
self initWordingAndDocumentation.
^self propertyAt: #wording ifAbsent: ['']!
----- Method: ObjectWithDocumentation>>wording: (in category 'accessing') -----
wording: aString
"Set the receiver's wording, in the current langauge"
self propertyAt: #wording put: aString!
ObjectWithDocumentation subclass: #ResultSpecification
instanceVariableNames: 'type companionSetterSelector refetchFrequency'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
----- Method: ResultSpecification>>companionSetterSelector (in category 'companion setter') -----
companionSetterSelector
"Answer the companion setter, nil if none"
^ companionSetterSelector!
----- Method: ResultSpecification>>companionSetterSelector: (in category 'companion setter') -----
companionSetterSelector: aSetterSelector
"Set the receiver's companionSetterSelector as indicated"
companionSetterSelector := aSetterSelector!
----- Method: ResultSpecification>>refetchFrequency (in category 'refetch') -----
refetchFrequency
"Answer the frequency with which the receiver should be refetched by a readout polling values from it, as in a Viewer. Answer nil if not ever to be refetched automatically"
^ refetchFrequency!
----- Method: ResultSpecification>>refetchFrequency: (in category 'refetch') -----
refetchFrequency: aFrequency
"Set the refetch frequency"
refetchFrequency := aFrequency!
----- Method: ResultSpecification>>resultType (in category 'result type') -----
resultType
"Answer the reciever's result type"
^ type!
----- Method: ResultSpecification>>resultType: (in category 'result type') -----
resultType: aType
"Set the receiver's resultType as specified"
type := aType!
----- Method: ResultSpecification>>type (in category 'result type') -----
type
"Answer the reciever's type"
^ type!
ObjectWithDocumentation subclass: #Variable
instanceVariableNames: 'defaultValue floatPrecision variableName variableType'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
----- Method: Variable>>defaultValue (in category 'value') -----
defaultValue
"Answer the default value to be supplied to the receiver"
^ defaultValue!
----- Method: Variable>>name:type: (in category 'name') -----
name: aName type: aType
"Set the variable's name and type as indicated"
variableName := aName.
variableType := aType!
----- Method: Variable>>printOn: (in category 'name') -----
printOn: aStream
"Print the receiver on the stream"
super printOn: aStream.
aStream nextPutAll: ' named ', (self variableName ifNil: ['<unnamed>']), ' type = ', variableType printString, ' default val = ', defaultValue printString!
----- Method: Variable>>sample (in category 'value') -----
sample
"The closest we can come to an object for our type"
| ty clsName |
self defaultValue ifNotNil: [^ self defaultValue].
ty := self variableType.
"How translate a type like #player into a class?"
clsName := ty asString.
clsName at: 1 put: (clsName first asUppercase).
clsName := clsName asSymbol.
(Smalltalk includesKey: clsName) ifFalse: [self error: 'What type is this?'. ^ 5].
^ (Smalltalk at: clsName) initializedInstance!
----- Method: Variable>>variableName (in category 'name') -----
variableName
"Answer the variable name of the receiver"
^ variableName!
----- Method: Variable>>variableType (in category 'type') -----
variableType
"Anser the variable type of the receiver"
^ variableType!
----- Method: Variable>>variableType: (in category 'type') -----
variableType: aType
"Set the receiver's variable type as requested"
variableType := aType!
ObjectWithDocumentation subclass: #Vocabulary
instanceVariableNames: 'vocabularyName categories methodInterfaces object limitClass translationTable'
classVariableNames: 'LanguageTable LanguageSymbols AllStandardVocabularies'
poolDictionaries: ''
category: 'Protocols-Kernel'!
!Vocabulary commentStamp: '<historical>' prior: 0!
Vocabulary
vocabularyName a Symbol -- the formal name by which this vocabulary is known.
categories a list of ElementCategory objects: the categories that comprise the vocabulary
methodInterfaces an IdentityDictionary; keys are method selectors, values are MethodInterfaces
A Vocabulary can be either be *abstract*, i.e. associated with a *class*, or it can be *bound to an instance*. The form that is bound to an instance is still in its infancy however.
object in the *bound* form, an actual object is associated with the vocabulary
limitClass in the *bound* form, an actual limit class is assocaited with the vocabulary
AllMethodInterfaces This class variable is available to hold on to all method interfaces
defined in the system, regardless of class. Not deployed in
the first version of this code to be circulated externally.
AllVocabularies A dictionary associating symbols with actual abstract vocabulary instances
------
Hints on making a vocabulary for a new foreign language. You need build a method like #addGermanVocabulary. Execute
Transcript show: Vocabulary eToyVocabulary strings.
and copy the text from the transcript to the method you are building.
A cheap trick to get started is to use a web site that translates. Here is how. For an entry like:
(clearTurtleTrails 'clear pen trails' 'Clear all the pen trails in the interior.')
substitute exclamation points for single quotes by using Alt-shift-j. Most of the statements are imperatives.
(clearOwnersPenTrails !!clear all pen trails!! !!clear all pen trails in my containing play field!!)
This translates to
(ClearOwnersPenTrails!! reinigt allen Kugelschreiber verfolgt!! !! Reinigt allen Kugelschreiber Pfade in meinem enthaltenden Spiel Feld sind!!)
Which is laughable, and will certainly stimulate the author to improve it.
------!
Vocabulary subclass: #DataType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
!DataType commentStamp: 'sw 8/22/2002 15:01' prior: 0!
A Vocabulary representing typed data.!
DataType subclass: #BooleanType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
!BooleanType commentStamp: 'sw 1/5/2005 22:15' prior: 0!
A data type representing Boolean values, i.e., true or false.!
----- Method: BooleanType>>initialValueForASlotFor: (in category 'initial value') -----
initialValueForASlotFor: aPlayer
"Answer the value to give initially to a newly created slot of the given type in the given player"
^ true!
----- Method: BooleanType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
self vocabularyName: #Boolean!
----- Method: BooleanType>>setFormatForDisplayer: (in category 'tiles') -----
setFormatForDisplayer: aDisplayer
"Set up the displayer to have the right format characteristics"
aDisplayer useSymbolFormat.
aDisplayer growable: true
!
DataType subclass: #ColorType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
!ColorType commentStamp: 'sw 1/5/2005 22:15' prior: 0!
A data type representing a Color value.!
----- Method: ColorType>>initialValueForASlotFor: (in category 'initial value') -----
initialValueForASlotFor: aPlayer
"Answer the value to give initially to a newly created slot of the given type in the given player"
^ Color random!
----- Method: ColorType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
self vocabularyName: #Color.!
----- Method: ColorType>>updatingTileForTarget:partName:getter:setter: (in category 'tiles') -----
updatingTileForTarget: aTarget partName: partName getter: getter setter: setter
"Answer, for classic tiles, an updating readout tile for a part with the receiver's type, with the given getter and setter"
| readout |
readout _ UpdatingRectangleMorph new.
readout
getSelector: getter;
target: aTarget;
borderWidth: 1;
extent: 22 at 22.
((aTarget isKindOf: KedamaExamplerPlayer) and: [getter = #getColor]) ifTrue: [
readout getSelector: #getColorOpaque.
].
(setter isNil or: [#(unused none #nil) includes: setter]) ifFalse:
[readout putSelector: setter].
^ readout
!
----- Method: ColorType>>wantsArrowsOnTiles (in category 'tiles') -----
wantsArrowsOnTiles
"Answer whether this data type wants up/down arrows on tiles representing its values"
^ false!
----- Method: DataType>>initialValueForASlotFor: (in category 'initial value') -----
initialValueForASlotFor: aPlayer
"Answer the value to give initially to a newly created slot of the given type in the given player"
^ 'no value'!
----- Method: DataType>>representsAType (in category 'queries') -----
representsAType
"Answer whether this vocabulary represents an end-user-sensible data type"
"^ (self class == DataType) not" "i.e. subclasses yes, myself no"
"Assuming this is an abstract class"
^true!
DataType subclass: #FullVocabulary
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
!FullVocabulary commentStamp: '<historical>' prior: 0!
The vocabulary that it all-encompassing. Its categories consist of the union of all categories of a class and all its superclasses. The methods in each category consist of those with selectors that are associated with that category.!
----- Method: FullVocabulary>>allMethodsInCategory:forInstance:ofClass: (in category 'method list') -----
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
"Answer a list of all methods which are in the given category, on behalf of anObject"
| classToUse |
classToUse := aClass ifNil: [anObject class].
^ classToUse allMethodsInCategory: categoryName!
----- Method: FullVocabulary>>categoriesContaining:forClass: (in category 'queries') -----
categoriesContaining: aSelector forClass: aTargetClass
"Answer a list of category names (all symbols) of categories that contain
the given selector for the target object. Initially, this just returns one."
| classDefiningSelector catName |
classDefiningSelector := aTargetClass whichClassIncludesSelector: aSelector.
classDefiningSelector
ifNil: [^ OrderedCollection new].
catName := classDefiningSelector whichCategoryIncludesSelector: aSelector.
^ OrderedCollection with: catName!
----- Method: FullVocabulary>>categoryListForInstance:ofClass:limitClass: (in category 'category list') -----
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
"Answer the category list for the given object, considering only code implemented in mostGeneric and lower (or higher, depending on which way you're facing"
| classToUse |
classToUse := anObject ifNil: [aClass] ifNotNil: [anObject class].
^ mostGenericClass == classToUse
ifTrue:
[mostGenericClass organization categories]
ifFalse:
[classToUse allMethodCategoriesIntegratedThrough: mostGenericClass]!
----- Method: FullVocabulary>>categoryWithNameIn:thatIncludesSelector:forInstance:ofClass: (in category 'queries') -----
categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: targetInstance ofClass: targetClass
"Answer the name of a category, from among the provided
categoryNames, which defines the selector for the given class. Here, if
the category designated by the implementing class is acceptable it is the
one returned"
| aClass catName result |
(aClass := targetClass whichClassIncludesSelector: aSelector)
ifNotNil: [(categoryNames includes: (catName := aClass whichCategoryIncludesSelector: aSelector))
ifTrue: [catName ~~ #'as yet unclassified'
ifTrue: [^ catName]]].
result := super
categoryWithNameIn: categoryNames
thatIncludesSelector: aSelector
forInstance: targetInstance
ofClass: aClass.
^ result
ifNil: [#'as yet unclassified']!
----- Method: FullVocabulary>>encompassesAPriori: (in category 'queries') -----
encompassesAPriori: aClass
"Answer whether an object, by its very nature, is one that the receiver embraces"
^ true!
----- Method: FullVocabulary>>includesDefinitionForSelector: (in category 'queries') -----
includesDefinitionForSelector: aSelector
"Answer whether the given selector is known to the vocabulary. Unsent at the moment, may disappear."
^ true!
----- Method: FullVocabulary>>includesSelector: (in category 'queries') -----
includesSelector: aSelector
"Answer whether the given selector is known to the vocabulary"
^ true!
----- Method: FullVocabulary>>includesSelector:forInstance:ofClass:limitClass: (in category 'queries') -----
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
"Answer whether the vocabulary includes the given selector for the given class, only considering method implementations in mostGenericClass and lower"
| classToUse aClass |
classToUse := self classToUseFromInstance: anInstance ofClass: aTargetClass.
^ (aClass := classToUse whichClassIncludesSelector: aSelector)
ifNil:
[false]
ifNotNil:
[aClass includesBehavior: mostGenericClass]!
----- Method: FullVocabulary>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')
Vocabulary initialize
"
super initialize.
vocabularyName := #Object.
self documentation: '"Object" is all-encompassing vocabulary that embraces all methods understood by an object'.
self rigAFewCategories!
----- Method: FullVocabulary>>representsAType (in category 'queries') -----
representsAType
"Answer whether this vocabulary represents an end-user-sensible data type"
^ false!
----- Method: FullVocabulary>>rigAFewCategories (in category 'initialization') -----
rigAFewCategories
"Formerly used to rig generic categories, now seemingly disfunctional and in abeyance"
| aMethodCategory |
true ifTrue: [^ self].
self flag: #deferred.
"Vocabulary fullVocabulary rigAFewCategories "
#( (accessing 'Generally holds methods to read and write instance variables')
(initialization 'messages typically sent when an object is created, to set up its initial state'))
do:
[:pair |
aMethodCategory := ElementCategory new categoryName: pair first.
aMethodCategory documentation: pair second.
self addCategory: aMethodCategory]!
FullVocabulary subclass: #ScreenedVocabulary
instanceVariableNames: 'methodScreeningBlock categoryScreeningBlock'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
----- Method: ScreenedVocabulary>>allMethodsInCategory:forInstance:ofClass: (in category 'enumeration') -----
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
"Answer a list of all methods in the vocabulary which are in the given category, on behalf of the given class and object"
^ (super allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass) select:
[:aSelector | self includesSelector: aSelector]!
----- Method: ScreenedVocabulary>>categoryListForInstance:ofClass:limitClass: (in category 'enumeration') -----
categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass
"Answer the category list for the given object/class, considering only code implemented in mostGenericClass and lower"
^ (super categoryListForInstance: anObject ofClass: aClass limitClass: mostGenericClass) select:
[:aCategory | categoryScreeningBlock value: aCategory]!
----- Method: ScreenedVocabulary>>categoryScreeningBlock: (in category 'initialization') -----
categoryScreeningBlock: aBlock
"Set the receiver's categoryScreeningBlock to the block provided"
categoryScreeningBlock := aBlock!
----- Method: ScreenedVocabulary>>includesSelector: (in category 'queries') -----
includesSelector: aSelector
"Answer whether the given selector is known to the vocabulary"
^ methodScreeningBlock value: aSelector!
----- Method: ScreenedVocabulary>>includesSelector:forInstance:ofClass:limitClass: (in category 'queries') -----
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
"Answer whether the vocabulary includes the given selector for the given object, only considering method implementations in mostGenericClass and lower"
^ (super includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass) and:
[self includesSelector: aSelector]!
----- Method: ScreenedVocabulary>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
vocabularyName := #Public.
self documentation: '"Public" is vocabulary that excludes categories that start with "private" and methods that start with "private" or "pvt"'!
----- Method: ScreenedVocabulary>>methodScreeningBlock: (in category 'initialization') -----
methodScreeningBlock: aBlock
"Set the receiver's methodScreeningBlock to the block provided"
methodScreeningBlock := aBlock!
DataType subclass: #GraphicType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
----- Method: GraphicType>>initialValueForASlotFor: (in category 'initial value') -----
initialValueForASlotFor: aPlayer
"Answer the value to give initially to a newly created slot of the given type in the given player"
^ ScriptingSystem formAtKey: #PaintTab!
----- Method: GraphicType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
self vocabularyName: #Graphic.!
DataType subclass: #MenuType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
!MenuType commentStamp: 'sw 1/6/2005 03:45' prior: 0!
A type associated with menu-item values. An imperfect thing thus far, only usable in the doMenuItem etoy scripting phrase.!
----- Method: MenuType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
self vocabularyName: #Menu!
----- Method: MenuType>>representsAType (in category 'tiles') -----
representsAType
"Answer whether this vocabulary represents an end-user-sensible data type"
^false!
DataType subclass: #NumberType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
!NumberType commentStamp: 'sw 10/3/2002 02:18' prior: 0!
NumberType is a data type representing a numeric value.!
----- Method: NumberType>>initialValueForASlotFor: (in category 'initial value') -----
initialValueForASlotFor: aPlayer
"Answer the value to give initially to a newly created slot of the given type in the given player"
^ (1 to: 9) atRandom!
----- Method: NumberType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
| aMethodCategory aMethodInterface |
super initialize.
"Vocabulary replaceNumberVocabulary"
"Vocabulary addVocabulary: Vocabulary newNumberVocabulary"
self vocabularyName: #Number.
self documentation: 'Numbers are things that can do arithmetic, have their magnitudes compared, etc.'.
#((comparing 'Determining which of two numbers is larger'
(= < > <= >= ~= ~~))
(arithmetic 'Basic numeric operation'
(* + - / // \\ abs negated quo: rem:))
(testing 'Testing a number'
(even isDivisibleBy: negative odd positive sign))
(#'mathematical functions' 'Trigonometric and exponential functions'
(cos exp ln log log: raisedTo: sin sqrt squared tan raisedToInteger:))
(converting 'Converting a number to another form'
(@ asInteger asPoint degreesToRadians radiansToDegrees asSmallAngleDegrees asSmallPositiveDegrees))
(#'truncation and round off' 'Making a real number (with a decimal point) into an integer'
(ceiling floor roundTo: roundUpTo: rounded truncateTo: truncated))
) do:
[:item |
aMethodCategory := ElementCategory new categoryName: item first.
aMethodCategory documentation: item second.
item third do:
[:aSelector |
aMethodInterface := MethodInterface new conjuredUpFor: aSelector class: (Number whichClassIncludesSelector: aSelector).
aMethodInterface argumentVariables do:
[:var | var variableType: #Number].
(#(* + - / // \\ abs negated quo: rem:
cos exp ln log log: raisedTo: sin sqrt squared tan raisedToInteger:
asInteger degreesToRadians radiansToDegrees asSmallAngleDegrees asSmallPositiveDegrees)
includes: aSelector) ifTrue:
[aMethodInterface resultType: #Number].
(#( @ asPoint ) includes: aSelector) ifTrue:
[aMethodInterface resultType: #Point].
(#(= < > <= >= ~= ~~ even isDivisibleBy: negative odd positive) includes: aSelector) ifTrue:
[aMethodInterface resultType: #Boolean].
aMethodInterface setNotToRefresh.
self atKey: aSelector putMethodInterface: aMethodInterface.
aMethodCategory elementAt: aSelector put: aMethodInterface].
self addCategory: aMethodCategory].
"
(('truncation and round off' ceiling detentBy:atMultiplesOf:snap: floor roundTo: roundUpTo: rounded truncateTo: truncated)
('testing' basicType even isDivisibleBy: isInf isInfinite isNaN isNumber isZero negative odd positive sign strictlyPositive)
('converting' @ adaptToCollection:andSend: adaptToFloat:andSend: adaptToFraction:andSend: adaptToInteger:andSend: adaptToPoint:andSend: adaptToString:andSend: asInteger asNumber asPoint asSmallAngleDegrees asSmallPositiveDegrees degreesToRadians radiansToDegrees)
('intervals' to: to:by: to:by:do: to:do:)
('printing' defaultLabelForInspector isOrAreStringWith: newTileMorphRepresentative printOn: printStringBase: storeOn: storeOn:base: storeStringBase: stringForReadout)
('comparing' closeTo:)
('filter streaming' byteEncode:)
('as yet unclassified' reduce)"
!
DataType subclass: #SoundType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
----- Method: SoundType>>initialValueForASlotFor: (in category 'initial value') -----
initialValueForASlotFor: aPlayer
"Answer the value to give initially to a newly created slot of the given type in the given player"
^ 'croak'!
----- Method: SoundType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
self vocabularyName: #Sound!
DataType subclass: #StringType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
----- Method: StringType>>initialValueForASlotFor: (in category 'initial value') -----
initialValueForASlotFor: aPlayer
"Answer the value to give initially to a newly created slot of the given type in the given player"
^ 'abc'!
----- Method: StringType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
| aMethodCategory aMethodInterface |
super initialize.
self vocabularyName: #String.
#((accessing 'The basic info'
(at: at:put: size endsWithDigit findString: findTokens: includesSubString: indexOf: indexOf:startingAt: indexOf:startingAt:ifAbsent: lineCorrespondingToIndex: lineCount lineNumber: startsWithDigit numArgs))
(#'more accessing' 'More basic info'
(allButFirst allButFirst: allButLast allButLast: at:ifAbsent: atAllPut: atPin: atRandom: atWrap: atWrap:put: fifth first first: fourth from:to:put: last last: lastIndexOf: lastIndexOf:ifAbsent: middle replaceAll:with: replaceFrom:to:with: replaceFrom:to:with:startingAt: second sixth third))
(comparing 'Determining which comes first alphabeticly'
(< <= = > >= beginsWith: endsWith: endsWithAnyOf: howManyMatch: match:))
(testing 'Testing'
(includes: isEmpty ifNil: ifNotNil: isAllDigits isAllSeparators isString lastSpacePosition))
(converting 'Converting it to another form'
(asCharacter asDate asInteger asLowercase asNumber asString asStringOrText asSymbol asText asTime asUppercase asUrl capitalized keywords numericSuffix romanNumber reversed splitInteger surroundedBySingleQuotes withBlanksTrimmed withSeparatorsCompacted withoutTrailingBlanks withoutTrailingDigits asSortedCollection))
(copying 'Make another one like me'
(copy copyFrom:to: copyUpTo: copyUpToLast: shuffled))
(enumerating 'Passing over the letters'
(collect: collectWithIndex: do: from:to:do: reverseDo: select: withIndexDo: detect: detect:ifNone:))
) do: [:item |
aMethodCategory := ElementCategory new categoryName: item first.
aMethodCategory documentation: item second.
item third do:
[:aSelector |
aMethodInterface := MethodInterface new initializeFor: aSelector.
self atKey: aSelector putMethodInterface: aMethodInterface.
aMethodCategory elementAt: aSelector put: aMethodInterface].
self addCategory: aMethodCategory].
!
DataType subclass: #SymbolListType
instanceVariableNames: 'symbols'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
!SymbolListType commentStamp: 'sw 1/6/2005 17:52' prior: 0!
A type whose values range across a finite set of symbols, which are held in the "symbols" instance variable.!
SymbolListType subclass: #ButtonPhaseType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
----- Method: ButtonPhaseType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
self vocabularyName: #ButtonPhase.
symbols := #(buttonDown whilePressed buttonUp)!
----- Method: ButtonPhaseType>>representsAType (in category 'queries') -----
representsAType
"Answer whether this vocabulary represents an end-user-sensible data type"
^true!
----- Method: SymbolListType>>choices (in category 'tiles') -----
choices
"answer the list of choices to offer as variant values"
^ symbols copy!
----- Method: SymbolListType>>initialValueForASlotFor: (in category 'initial value') -----
initialValueForASlotFor: aPlayer
"Answer the value to give initially to a newly created slot of the given type in the given player"
^ self choices first!
----- Method: SymbolListType>>representsAType (in category 'tiles') -----
representsAType
"Answer whether this vocabulary represents an end-user-sensible data type"
^ #(BorderStyle ButtonPhase TrailStyle) includes: vocabularyName!
----- Method: SymbolListType>>symbols: (in category 'tiles') -----
symbols: symbolList
"Set the receiver's list of symbols as indicated"
symbols := symbolList!
DataType subclass: #UnknownType
instanceVariableNames: ''
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Type Vocabularies'!
----- Method: UnknownType>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
vocabularyName := #unknown!
----- Method: UnknownType>>representsAType (in category 'queries') -----
representsAType
"Answer whether this vocabulary represents an end-user-sensible data type"
^ false!
----- Method: Vocabulary class>>addStandardVocabulary: (in category 'standard vocabulary access') -----
addStandardVocabulary: aVocabulary
"Add a vocabulary to the list of standard vocabularies"
self allStandardVocabularies at: aVocabulary vocabularyName put: aVocabulary!
----- Method: Vocabulary class>>allStandardVocabularies (in category 'standard vocabulary access') -----
allStandardVocabularies
"Answer a list of the currently-defined vocabularies in my AllStandardVocabularies list"
"Vocabulary allStandardVocabularies"
^AllStandardVocabularies ifNil: [AllStandardVocabularies := IdentityDictionary new].
!
----- Method: Vocabulary class>>embraceAddedTypeVocabularies (in category 'class initialization') -----
embraceAddedTypeVocabularies
"If there are any type-vocabulary subclases not otherwise accounted for, acknowledge them at this time"
| vocabulary |
DataType allSubclasses do:
[:dataType |
vocabulary := dataType new.
vocabulary representsAType
ifTrue: [(self allStandardVocabularies includesKey: vocabulary vocabularyName)
ifFalse: [self addStandardVocabulary: vocabulary]]]!
----- Method: Vocabulary class>>fullVocabulary (in category 'universal vocabularies') -----
fullVocabulary
"Answer the full vocabulary in my AllStandardVocabularies list, creating it if necessary"
^ self allStandardVocabularies at: #Full ifAbsentPut: [FullVocabulary new]!
----- Method: Vocabulary class>>gettersForbiddenFromWatchers (in category 'eToy vocabularies') -----
gettersForbiddenFromWatchers
"Answer getters that should not have watchers launched to them"
^ #(colorSees copy isOverColor: seesColor: newClone getNewClone color:sees: touchesA: overlaps: overlapsAny:)!
----- Method: Vocabulary class>>initialize (in category 'class initialization') -----
initialize
"Initialize a few standard vocabularies and place them in the AllVocabularies list. Call this to update all vocabularies."
self initializeStandardVocabularies.
self embraceAddedTypeVocabularies.
"Vocabulary initialize"
!
----- Method: Vocabulary class>>initializeSilently (in category 'class initialization') -----
initializeSilently
"Initialize a few standard vocabularies and place them in the AllVocabularies list."
self initializeStandardVocabularies.
self embraceAddedTypeVocabularies.
"Vocabulary initializeSilently"
!
----- Method: Vocabulary class>>initializeStandardVocabularies (in category 'class initialization') -----
initializeStandardVocabularies
"Initialize a few standard vocabularies and place them in the AllStandardVocabularies list."
AllStandardVocabularies _ nil.
self addStandardVocabulary: EToyVocabulary new.
self addStandardVocabulary: EToyVectorVocabulary new.
self addStandardVocabulary: self newPublicVocabulary.
self addStandardVocabulary: FullVocabulary new.
self addStandardVocabulary: self newQuadVocabulary.
self addStandardVocabulary: ColorType new.
self addStandardVocabulary: BooleanType new.
self addStandardVocabulary: GraphicType new.
self addStandardVocabulary: PlayerType new.
self addStandardVocabulary: SoundType new.
self addStandardVocabulary: StringType new.
self addStandardVocabulary: MenuType new.
self addStandardVocabulary: UnknownType new.
self addStandardVocabulary: ScriptNameType new.
self addStandardVocabulary: (SymbolListType new symbols: #(simple raised inset complexFramed complexRaised complexInset complexAltFramed complexAltRaised complexAltInset); vocabularyName: #BorderStyle; yourself).
self addStandardVocabulary: (SymbolListType new symbols: #(lines arrows arrowheads dots); vocabularyName: #TrailStyle; yourself).
self addStandardVocabulary: (SymbolListType new symbols: #(leftToRight rightToLeft topToBottom bottomToTop); vocabularyName: #ListDirection; yourself).
self addStandardVocabulary: (SymbolListType new symbols: #(topLeft bottomRight center justified); vocabularyName: #ListCentering; yourself).
self addStandardVocabulary: (SymbolListType new symbols: #(buttonDown whilePressed buttonUp); vocabularyName: #ButtonPhase; yourself).
self addStandardVocabulary: (SymbolListType new symbols: #(rotate #'do not rotate' #'flip left right' #'flip up down'); vocabularyName: #RotationStyle; yourself).
self addStandardVocabulary: (SymbolListType new symbols: #(rigid spaceFill shrinkWrap); vocabularyName: #Resizing; yourself).
self addStandardVocabulary: self newSystemVocabulary. "A custom vocabulary for Smalltalk -- still under development)"
self numberVocabulary. "creates and adds it"
self wonderlandVocabulary. "creates and adds it"
self vocabularyForClass: Time. "creates and adds it"
self addStandardVocabulary: (KedamaPatchType new vocabularyName: #Patch; yourself).
self addStandardVocabulary: (SymbolListType new symbols: #(wrap stick bouncing); vocabularyName: #EdgeMode; yourself).
self addStandardVocabulary: (SymbolListType new symbols: #(logScale linear color); vocabularyName: #PatchDisplayMode; yourself).
"Vocabulary initialize"!
----- Method: Vocabulary class>>instanceWhoRespondsTo: (in category 'queries') -----
instanceWhoRespondsTo: aSelector
"Find the most likely class that responds to aSelector. Return an instance
of it. Look in vocabularies to match the selector."
"Most eToy selectors are for Players"
| mthRefs |
((self vocabularyNamed: #eToy)
includesSelector: aSelector)
ifTrue: [aSelector == #+
ifFalse: [^ Player new costume: Morph new]].
"Numbers are a problem"
((self vocabularyNamed: #Number)
includesSelector: aSelector)
ifTrue: [^ 1].
"Is a Float any different?"
"String Point Time Date"
#()
do: [:nn | ((self vocabularyNamed: nn)
includesSelector: aSelector)
ifTrue: ["Ask Scott how to get a prototypical instance"
^ (Smalltalk at: nn) new]].
mthRefs := self systemNavigation allImplementorsOf: aSelector.
"every one who implements the selector"
mthRefs
sortBlock: [:a :b | (Smalltalk at: a classSymbol) allSuperclasses size < (Smalltalk at: b classSymbol) allSuperclasses size].
mthRefs size > 0
ifTrue: [^ (Smalltalk at: mthRefs first classSymbol) new].
^ Error new!
----- Method: Vocabulary class>>newNumberVocabulary (in category 'type vocabularies') -----
newNumberVocabulary
"Answer a Vocabulary object representing the Number vocabulary to the list of AllVocabularies"
^ NumberType new!
----- Method: Vocabulary class>>newPublicVocabulary (in category 'universal vocabularies') -----
newPublicVocabulary
| aVocabulary |
"Answer a public vocabulary"
aVocabulary := ScreenedVocabulary new.
aVocabulary vocabularyName: #Public.
aVocabulary documentation: '"Public" is vocabulary that excludes categories that start with "private" and methods that start with "private" or "pvt"'.
aVocabulary categoryScreeningBlock: [:aCategoryName | (aCategoryName beginsWith: 'private') not].
aVocabulary methodScreeningBlock: [:aSelector |
((aSelector beginsWith: 'private') or: [aSelector beginsWith: 'pvt']) not].
^ aVocabulary
!
----- Method: Vocabulary class>>newQuadVocabulary (in category 'testing and demo') -----
newQuadVocabulary
"Answer a Quad vocabulary -- something to mess with, to illustrate and explore ideas. Applies to Quadrangles only."
| aVocabulary |
aVocabulary := Vocabulary new vocabularyName: #Quad.
aVocabulary documentation: 'A highly restricted test vocabulary that can be used with Quadrangle objects'.
aVocabulary initializeFromTable: #(
(borderColor borderColor: () Color (basic color) 'The color of the border' unused updating)
(borderWidth borderWidth: () Number (basic geometry) 'The width of the border' unused updating)
(insideColor insideColor: () Color (basic color) 'The color of the quadrangle' unused updating)
(display none () none (basic display) 'Display the quadrangle directly on the screen')
(width none () Number (geometry) 'The width of the object' unused updating)
(left setLeft: () Number (geometry) 'The left edge' unused updating)
(right setRight: () Number (geometry) 'The right edge' unused updating)
(width setWidth: () Number (geometry) 'The width of the object' unused updating)
(height setHeight: () Number (geometry) 'The height of the object' unused updating)
(hasPositiveExtent none () Boolean (tests) 'Whether the corner is to the lower-right of the origin' unused updating)
(isTall none () Boolean (tests) 'Whether the height is greater than the width' unused updating)).
^ aVocabulary
"Vocabulary initialize"
"Quadrangle exampleInViewer"!
----- Method: Vocabulary class>>newSystemVocabulary (in category 'eToy vocabularies') -----
newSystemVocabulary
"Answer a Vocabulary object representing significant requests one can make to the Smalltalk object"
| aVocabulary |
aVocabulary := self new.
aVocabulary vocabularyName: #System.
aVocabulary documentation: 'Useful messages you might want to send to the current Smalltalk image'.
aVocabulary initializeFromTable: #(
(aboutThisSystem none () none (basic queries) 'put up a message describing the system' unused)
(saveAsNewVersion none () none (services) 'advance to the next available image-version number and save the image under that new name' unused znak)
(datedVersion none () String (queries) 'the version of the Squeak system')
(endianness none () String (queries) 'big or little - the byte-ordering of the hardware Squeak is currently running on')
(exitToDebugger none () none (dangerous) 'exits to the host debugger. Do not use this -- I guarantee you will be sorry.')
(bytesLeft none () Number (basic services) 'perform a garbage collection and answer the number of bytes of free space remaining in the system')
"(browseAllCallsOn: none ((aSelector String)) none (#'queries') 'browse all calls on a selector')
(browseAllImplementorsOf: none ((aSelector String)) none (#'queries') 'browse all implementors of a selector')"
"(allMethodsWithSourceString:matchCase: none ((aString String) (caseSensitive Boolean)) none (queries) 'browse all methods that have the given source string, making the search case-sensitive or not depending on the argument provided.')
(browseMethodsWithString:matchCase: none ((aString String) (caseSensitive Boolean)) none (queries) 'browse all methods that contain the given string in any string literal, making the search case-sensitive or not depending on the argument provided.')
(browseAllImplementorsOf:localTo: none ((aSelector String) (aClass Class)) none (#'queries') 'browse all implementors of a selector that are local to a class')"
).
"(isKindOf: none ((aClass Class)) Boolean (#'class membership') 'answer whether the receiver''s superclass chain includes aClass')"
^ aVocabulary
"Vocabulary initialize"
"Vocabulary addStandardVocabulary: Vocabulary newSystemVocabulary"
"SmalltalkImage current basicInspect"
"SmalltalkImage current beViewed"
!
----- Method: Vocabulary class>>newTestVocabulary (in category 'testing and demo') -----
newTestVocabulary
"Answer a Test vocabulary -- something to mess with, to illustrate and explore ideas."
| aVocabulary |
aVocabulary := Vocabulary new vocabularyName: #Test.
aVocabulary documentation: 'An illustrative vocabulary for testing'.
aVocabulary initializeFromTable: #(
(isKindOf: none ((aClass Class)) Boolean (#'class membership') 'answer whether the receiver''s superclass chain includes aClass')
(class none none Class (#'class membership' wimpy) 'answer the the class to which the receiver belongs')
(respondsTo: none ((aSelector Symbol)) Boolean (#'class membership') 'answer whether the receiver responds to the given selector')
(as: none ((aClass Class)) Object (conversion) 'answer the receiver converted to be a member of aClass')).
^ aVocabulary
"
#((#'class membership' 'Whether an object can respond to a given message, etc.' (isKindOf: class respondsTo:))
(conversion 'Messages to convert from one kind of object to another' (as: asString))
(copying 'Messages for making copies of objects' (copy copyFrom:))
(equality 'Testing whether two objects are equal' ( = ~= == ~~))
(dependents 'Support for dependency notification' (addDependent: removeDependent: release))) do:
[:item |
aMethodCategory := ElementCategory new categoryName: item first.
aMethodCategory documentation: item second.
item third do:
[:aSelector |
aMethodInterface := MethodInterface new initializeFor: aSelector.
aVocabulary atKey: aSelector putMethodInterface: aMethodInterface.
aMethodCategory elementAt: aSelector put: aMethodInterface].
aVocabulary addCategory: aMethodCategory]."
!
----- Method: Vocabulary class>>newTimeVocabulary (in category 'standard vocabulary access') -----
newTimeVocabulary
"Answer a Vocabulary object representing me"
| aVocabulary aMethodCategory aMethodInterface |
"Vocabulary newTimeVocabulary"
"Vocabulary addStandardVocabulary: Vocabulary newTimeVocabulary"
aVocabulary := self new vocabularyName: #Time.
aVocabulary documentation: 'Time knows about hours, minutes, and seconds. For long time periods, use Date'.
#((accessing 'The basic info'
(hours minutes seconds))
(arithmetic 'Basic numeric operations'
(addTime: subtractTime: max: min: min:max:))
(comparing 'Determining which is larger'
(= < > <= >= ~= between:and:))
(testing 'Testing'
(ifNil: ifNotNil:))
(printing 'Return a string for this Time'
(hhmm24 print24 intervalString printMinutes printOn:))
(converting 'Converting it to another form'
(asSeconds asString))
(copying 'Make another one like me'
(copy))
) do: [:item |
aMethodCategory := ElementCategory new categoryName: item first.
aMethodCategory documentation: item second.
item third do:
[:aSelector |
aMethodInterface := MethodInterface new initializeFor: aSelector.
aVocabulary atKey: aSelector putMethodInterface: aMethodInterface.
aMethodCategory elementAt: aSelector put: aMethodInterface].
aVocabulary addCategory: aMethodCategory].
#(#addTime: subtractTime: max: min: = < > <= >= ~= ) do: [:sel |
(aVocabulary methodInterfaceAt: sel ifAbsent: [self error: 'fix this method'])
argumentVariables: (OrderedCollection with:
(Variable new name: nil type: aVocabulary vocabularyName))].
^ aVocabulary!
----- Method: Vocabulary class>>numberVocabulary (in category 'type vocabularies') -----
numberVocabulary
"Answer the standard vocabulary representing numbers, creating it if necessary"
^self allStandardVocabularies at: #Number ifAbsentPut: [self newNumberVocabulary]!
----- Method: Vocabulary class>>quadVocabulary (in category 'testing and demo') -----
quadVocabulary
"Answer the Quad vocabulary lurking in my AllStandardVocabularies list, creating it if necessary"
"Vocabulary quadVocabulary"
^ self allStandardVocabularies at: #Quad ifAbsentPut: [self newQuadVocabulary]!
----- Method: Vocabulary class>>testVocabulary (in category 'testing and demo') -----
testVocabulary
"Answer the Test vocabulary lurking in my AllStandardVocabularies list, creating it if necessary"
"Vocabulary testVocabulary"
^ self allStandardVocabularies at: #Test ifAbsentPut: [self newTestVocabulary]!
----- Method: Vocabulary class>>typeChoices (in category 'type vocabularies') -----
typeChoices
"Answer a list of all user-choosable data types"
| aList |
(aList _ self allStandardVocabularies
select:
[:aVocab | aVocab representsAType]
thenCollect:
[:aVocab | aVocab vocabularyName]).
Preferences allowEtoyUserCustomEvents ifFalse: [aList remove: #CustomEvents ifAbsent: []].
^ aList asSortedArray!
----- Method: Vocabulary class>>vocabularyForClass: (in category 'type vocabularies') -----
vocabularyForClass: aClass
"Answer the standard vocabulary for that class. Create it if not present and init message exists. Answer nil if none exists and no init message present."
| initMsgName newTypeVocab |
(self allStandardVocabularies includesKey: aClass name)
ifTrue: [^self allStandardVocabularies at: aClass name].
initMsgName := ('new', aClass name, 'Vocabulary') asSymbol.
^(self respondsTo: initMsgName)
ifTrue: [
newTypeVocab := self perform: initMsgName.
self addStandardVocabulary: newTypeVocab.
newTypeVocab]
ifFalse: [nil]!
----- Method: Vocabulary class>>vocabularyForType: (in category 'type vocabularies') -----
vocabularyForType: aType
"Answer a vocabulary appropriate to the given type, which is normally going to be a symbol such as #Number or #Color. Answer the Unknown vocabulary as a fall-back"
| ucSym |
(aType isKindOf: Vocabulary) ifTrue: [^ aType].
ucSym := aType capitalized asSymbol.
^self allStandardVocabularies at: ucSym ifAbsent: [self vocabularyNamed: #unknown]!
----- Method: Vocabulary class>>vocabularyFrom: (in category 'standard vocabulary access') -----
vocabularyFrom: aNameOrVocabulary
"Answer the standard vocabulary of the given name, or nil if none found, For backward compatibilitythe parameter might be an actual vocabulary, in which case return it"
(aNameOrVocabulary isKindOf: Vocabulary) ifTrue: [^ aNameOrVocabulary].
^ self vocabularyNamed: aNameOrVocabulary!
----- Method: Vocabulary class>>vocabularyNamed: (in category 'standard vocabulary access') -----
vocabularyNamed: aName
"Answer the standard vocabulary of the given name, or nil if none found"
^ self allStandardVocabularies at: aName asSymbol ifAbsent: []!
----- Method: Vocabulary>>addCategory: (in category 'initialization') -----
addCategory: aCategory
"Add the given category to my categories list"
categories add: aCategory!
----- Method: Vocabulary>>addCategoryNamed: (in category 'initialization') -----
addCategoryNamed: aCategoryName
"Add a category of the given name to my categories list,"
categories add: (ElementCategory new categoryName: aCategoryName asSymbol)!
----- Method: Vocabulary>>addFromTable: (in category 'initialization') -----
addFromTable: aTable
"Add each method-specification tuples, each of the form:
(1) selector
(2) companion setter selector (#none or nil indicate none)
(3) argument specification array, each element being an array of the form
<arg name> <arg type>
(4) result type, (#none or nil indicate none)
(5) array of category symbols, i.e. the categories in which this element should appear.
(6) help message. (optional)
(7) wording (optional)
(8) auto update flag (optional) - if #updating, set readout to refetch automatically
Make new categories as needed.
Consult Vocabulary class.initializeTestVocabulary for an example of use"
| aMethodCategory aMethodInterface aSelector doc wording |
aTable do:
[:tuple | tuple fifth do: [:aCategorySymbol |
(aMethodCategory := self categoryAt: aCategorySymbol) ifNil: [
aMethodCategory := ElementCategory new categoryName: aCategorySymbol.
self addCategory: aMethodCategory].
aMethodInterface := MethodInterface new.
aSelector := tuple first.
aMethodInterface selector: aSelector type: tuple fourth setter: tuple second.
aMethodCategory elementAt: aSelector put: aMethodInterface.
self atKey: aSelector putMethodInterface: aMethodInterface.
((tuple third ~~ #none) and: [tuple third isEmptyOrNil not])
ifTrue:
[aMethodInterface argumentVariables: (tuple third collect:
[:pair | Variable new name: pair first type: pair second])].
doc := (tuple size >= 6 and: [(#(nil none unused) includes: tuple sixth) not])
ifTrue:
[tuple sixth]
ifFalse:
[nil].
wording := (tuple size >= 7 and: [(#(nil none unused) includes: tuple seventh) not])
ifTrue:
[tuple seventh]
ifFalse:
[aSelector].
aMethodInterface
wording: wording;
helpMessage: doc.
tuple size >= 8 ifTrue:
[aMethodInterface setToRefetch]]].
!
----- Method: Vocabulary>>allCategoryName (in category 'queries') -----
allCategoryName
"Answer the name by which the 'all' category is known. This is redundant with two other things, including ClassOrganizer allCategory, at the moment -- should be cleaned up someday."
^ '-- all --' asSymbol!
----- Method: Vocabulary>>allMethodsInCategory: (in category 'queries') -----
allMethodsInCategory: categoryName
"Answer a list of methods in the category of the given name"
^ self allMethodsInCategory: categoryName forInstance: object ofClass: object class!
----- Method: Vocabulary>>allMethodsInCategory:forInstance:ofClass: (in category 'queries') -----
allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass
"Answer a list of all methods in the etoy interface which are in the given category, on behalf of aClass and possibly anObject. Note that there is no limitClass at play here."
| aCategory |
categoryName ifNil: [^ OrderedCollection new].
categoryName = self allCategoryName ifTrue:
[^ methodInterfaces collect: [:anInterface | anInterface selector]].
aCategory := categories detect: [:cat | cat categoryName == categoryName asSymbol] ifNone: [^ OrderedCollection new].
^ aCategory elementsInOrder collect: [:anElement | anElement selector] thenSelect:
[:aSelector | aClass canUnderstand: aSelector]!
----- Method: Vocabulary>>allSelectorsInVocabulary (in category 'queries') -----
allSelectorsInVocabulary
"Answer a list of all selectors in the vocabulary"
^ methodInterfaces collect: [:m | m selector]!
----- Method: Vocabulary>>asSymbol (in category 'queries') -----
asSymbol
"Answer a symbol representing the receiver"
^ self vocabularyName!
----- Method: Vocabulary>>atKey:putMethodInterface: (in category 'queries') -----
atKey: aKey putMethodInterface: anInterface
"Place the given interface at the given key."
methodInterfaces at: aKey put: anInterface!
----- Method: Vocabulary>>categories (in category 'queries') -----
categories
"Answer a list of the categories in the receiver"
^ categories!
----- Method: Vocabulary>>categoriesContaining:forClass: (in category 'queries') -----
categoriesContaining: aSelector forClass: aClass
"Answer a list of categories that include aSelector"
^ self categories select:
[:aCategory | aCategory includesKey: aSelector]!
----- Method: Vocabulary>>categoryAt: (in category 'queries') -----
categoryAt: aSymbol
"Answer the category which has the given symbol as its categoryName, else nil if none found"
^ categories detect: [:aCategory | aCategory categoryName == aSymbol] ifNone: [nil]!
----- Method: Vocabulary>>categoryCommentFor: (in category 'queries') -----
categoryCommentFor: aCategoryName
"Answer diocumentation for the given category name, a symbol"
categories do:
[:cat | cat categoryName == aCategoryName ifTrue: [^ cat documentation]].
aCategoryName = self allCategoryName ifTrue:
[^ 'Shows all methods, whatever other categories they may belong to'].
#(
(all 'Danger!! An old designation that usually does NOT include all of anything!!')
('as yet unclassified' 'Methods not yet given a specific classification in some class in which they are implemented')
(private 'Methods that should only be called by self'))
do:
[:pair | pair first = aCategoryName ifTrue: [^ pair second]].
^ aCategoryName, ' is a category that currently has no documentation'
!
----- Method: Vocabulary>>categoryList (in category 'queries') -----
categoryList
"Answer the category list considering only code implemented in my
limitClass and lower. This variant is used when the limitClass and
targetObjct are known"
| classToUse foundAMethod classThatImplements |
classToUse := object class.
^ categories
select: [:aCategory |
foundAMethod := false.
aCategory elementsInOrder
do: [:aSpec |
classThatImplements := classToUse whichClassIncludesSelector: aSpec selector.
(classThatImplements notNil
and: [classThatImplements includesBehavior: limitClass])
ifTrue: [foundAMethod := true]].
foundAMethod]
thenCollect: [:aCategory | aCategory categoryName]!
----- Method: Vocabulary>>categoryListForInstance:ofClass:limitClass: (in category 'queries') -----
categoryListForInstance: targetObject ofClass: aClass limitClass: mostGenericClass
"Answer the category list for the given instance (may be nil) of the
given class, considering only code implemented in mostGenericClass and
lower "
| classToUse foundAMethod classThatImplements |
classToUse := targetObject
ifNil: [aClass]
ifNotNil: [targetObject class].
^ categories
select: [:aCategory |
foundAMethod := false.
aCategory elementsInOrder
do: [:aSpec |
classThatImplements := classToUse whichClassIncludesSelector: aSpec selector.
(classThatImplements notNil
and: [classThatImplements includesBehavior: mostGenericClass])
ifTrue: [foundAMethod := true]].
foundAMethod]
thenCollect: [:aCategory | aCategory categoryName]!
----- Method: Vocabulary>>categoryWhoseTranslatedWordingIs: (in category 'queries') -----
categoryWhoseTranslatedWordingIs: aWording
"Answer the category whose translated is the one provided, or nil if none"
^ self categories detect: [:aCategory | aCategory wording = aWording] ifNone: [nil]
!
----- Method: Vocabulary>>categoryWithNameIn:thatIncludesSelector:forInstance:ofClass: (in category 'queries') -----
categoryWithNameIn: categoryNames thatIncludesSelector: aSelector forInstance: targetInstance ofClass: targetClass
"Answer the name of a category, from among the provided categoryNames, which defines the selector for the given class. Note reimplementor"
| itsName |
self categories do:
[:aCategory | ((categoryNames includes: (itsName := aCategory categoryName)) and: [aCategory includesKey: aSelector])
ifTrue:
[^ itsName]].
^ nil!
----- Method: Vocabulary>>categoryWordingAt: (in category 'queries') -----
categoryWordingAt: aSymbol
"Answer the wording for the category at the given symbol"
| result |
result := self categoryAt: aSymbol.
^result
ifNotNil: [result wording]
ifNil: [aSymbol]!
----- Method: Vocabulary>>classToUseFromInstance:ofClass: (in category 'queries') -----
classToUseFromInstance: anInstance ofClass: aClass
"A small convenience to assist in complications arising because an instance is sometimes provided and sometimes not"
^ anInstance ifNotNil: [anInstance class] ifNil: [aClass]
!
----- Method: Vocabulary>>encompassesAPriori: (in category 'queries') -----
encompassesAPriori: aClass
"Answer whether the receiver a priori encompasses aClass -- see implementors"
^ false!
----- Method: Vocabulary>>includesDefinitionForSelector: (in category 'queries') -----
includesDefinitionForSelector: aSelector
"Answer whether the given selector is known to the vocabulary. This is independent of whether its definition lies within the range specified by my limitClass. Answer whether the given selector is known to the vocabulary. Unsent at the moment, may disappear."
^ methodInterfaces includesKey: aSelector!
----- Method: Vocabulary>>includesSelector: (in category 'queries') -----
includesSelector: aSelector
"Answer whether the given selector is known to the vocabulary"
^ methodInterfaces includesKey: aSelector!
----- Method: Vocabulary>>includesSelector:forInstance:ofClass:limitClass: (in category 'queries') -----
includesSelector: aSelector forInstance: anInstance ofClass: aTargetClass limitClass: mostGenericClass
"Answer whether the vocabulary includes the given selector for the given class (and instance, if provided), only considering method implementations in mostGenericClass and lower"
| classToUse aClass |
(methodInterfaces includesKey: aSelector) ifFalse: [^ false].
classToUse := self classToUseFromInstance: anInstance ofClass: aTargetClass.
^ (aClass := classToUse whichClassIncludesSelector: aSelector)
ifNil:
[false]
ifNotNil:
[(aClass includesBehavior: mostGenericClass) and:
[(self someCategoryThatIncludes: aSelector) notNil]]
!
----- Method: Vocabulary>>initialize (in category 'initialization') -----
initialize
"Initialize the receiver (automatically called when instances are created via 'new')"
super initialize.
vocabularyName := #unnamed.
categories := OrderedCollection new.
methodInterfaces := IdentityDictionary new!
----- Method: Vocabulary>>initializeFor: (in category 'initialization') -----
initializeFor: anObject
"Initialize the receiver to bear a vocabulary suitable for anObject"
object := anObject.
vocabularyName := #unnamed.
categories := OrderedCollection new.
methodInterfaces := IdentityDictionary new.
self documentation: 'A vocabulary that has not yet been documented'.
!
----- Method: Vocabulary>>initializeFromTable: (in category 'initialization') -----
initializeFromTable: aTable
"Initialize the receiver from a list of method-specification tuples, each of the form:
(1) selector
(2) companion setter selector (#none or nil indicate none)
(3) argument specification array, each element being an array of the form
<arg name> <arg type>
(4) result type, (#none or nil indicate none)
(5) array of category symbols, i.e. the categories in which this element should appear.
(6) help message. (optional)
(7) wording (optional)
(8) auto update flag (optional) - if #updating, set readout to refetch automatically
Consult Vocabulary class.initializeTestVocabulary for an example of use"
| aMethodCategory categoryList aMethodInterface aSelector doc wording |
categoryList := Set new.
aTable do:
[:tuple | categoryList addAll: tuple fifth].
categoryList := categoryList asSortedArray.
categoryList do:
[:aCategorySymbol |
aMethodCategory := ElementCategory new categoryName: aCategorySymbol.
aTable do:
[:tuple | (tuple fifth includes: aCategorySymbol) ifTrue:
[aMethodInterface := MethodInterface new.
aSelector := tuple first.
aMethodInterface selector: aSelector type: tuple fourth setter: tuple second.
aMethodCategory elementAt: aSelector put: aMethodInterface.
self atKey: aSelector putMethodInterface: aMethodInterface.
((tuple third ~~ #none) and: [tuple third isEmptyOrNil not])
ifTrue:
[aMethodInterface argumentVariables: (tuple third collect:
[:pair | Variable new name: pair first type: pair second])].
doc := (tuple size >= 6 and: [(#(nil none unused) includes: tuple sixth) not])
ifTrue:
[tuple sixth]
ifFalse:
[nil].
wording := (tuple size >= 7 and: [(#(nil none unused) includes: tuple seventh) not])
ifTrue:
[tuple seventh]
ifFalse:
[aSelector asString].
aMethodInterface
wording: wording;
helpMessage: doc.
tuple size >= 8 ifTrue:
[aMethodInterface setToRefetch]]].
self addCategory: aMethodCategory]!
----- Method: Vocabulary>>methodInterfaceAt:ifAbsent: (in category 'queries') -----
methodInterfaceAt: aSelector ifAbsent: aBlock
"Answer the vocabulary's method interface for the given selector; if absent, return the result of evaluating aBlock"
^ methodInterfaces at: aSelector ifAbsent: [aBlock value]!
----- Method: Vocabulary>>methodInterfaceForSelector:class: (in category 'queries') -----
methodInterfaceForSelector: aSelector class: aClass
"Answer a method interface for the selector"
^ self methodInterfaceAt: aSelector ifAbsent:
[MethodInterface new conjuredUpFor: aSelector class: aClass]!
----- Method: Vocabulary>>methodInterfacesDo: (in category 'queries') -----
methodInterfacesDo: aBlock
"Evaluate aBlock on behalf, in turn, of each of my methodInterfaces"
methodInterfaces do: aBlock
!
----- Method: Vocabulary>>methodInterfacesInCategory:forInstance:ofClass:limitClass: (in category 'queries') -----
methodInterfacesInCategory: categoryName forInstance: anObject ofClass: aClass limitClass: aLimitClass
"Answer a list of method interfaces of all methods in the given category, provided they are implemented no further away than aLimitClass."
| defClass |
^ ((self allMethodsInCategory: categoryName forInstance: anObject ofClass: aClass) collect:
[:sel | methodInterfaces at: sel ifAbsent:
[MethodInterface new conjuredUpFor: sel class: aClass]]) select:
[:aMethodInterface |
defClass := aClass whichClassIncludesSelector: aMethodInterface selector.
(defClass notNil and: [defClass includesBehavior: aLimitClass])]!
----- Method: Vocabulary>>phraseSymbolsToSuppress (in category 'method list') -----
phraseSymbolsToSuppress
"Answer a dictatorially-imposed list of phrase-symbols that are to be suppressed from viewers, even if they otherwise show up. Note that EToyVocabulary reimplements"
^ #()!
----- Method: Vocabulary>>printOn: (in category 'printing') -----
printOn: aStream
"Append to the argument, aStream, a sequence of characters that identifies the receiver."
super printOn: aStream.
vocabularyName ifNotNil: [aStream nextPutAll: ' named "', vocabularyName, '"']!
----- Method: Vocabulary>>renameCategoryFrom:to: (in category 'initialization') -----
renameCategoryFrom: oldName to: newName
"Rename the category currently known by oldName to be newName. No senders at present but once a UI is establshed for renaming categories, this will be useful."
| aCategory |
(aCategory := self categoryAt: oldName) ifNil: [^ self].
aCategory categoryName: newName!
----- Method: Vocabulary>>representsAType (in category 'queries') -----
representsAType
"Answer whether this vocabulary represents an end-user-sensible data type"
^ false!
----- Method: Vocabulary>>setCategoryStrings: (in category 'private') -----
setCategoryStrings: categoryTriplets
"Establish the category strings as per (internalCategorySymbol newCategoryWording balloon-help)"
| category |
categoryTriplets do:
[:triplet |
(category := self categoryAt: triplet first) ifNotNil: [
category wording: triplet second.
category helpMessage: triplet third]]!
----- Method: Vocabulary>>someCategoryThatIncludes: (in category 'queries') -----
someCategoryThatIncludes: aSelector
"Answer the name of a category that includes the selector, nil if none"
^ categories detect: [:c | c includesKey: aSelector] ifNone: [nil]!
----- Method: Vocabulary>>strings (in category 'initialization') -----
strings
| strm |
"Get started making a vocabulary for a foreign language. That is, build a method like #addGermanVocabulary, but for another language.
Returns this vocabulary in the same form used as the input used for foreign languages. To avoid string quote problems, execute
Transcript show: Vocabulary eToyVocabulary strings.
and copy the text from the transcript to the method you are building."
"selector wording documentation"
strm := WriteStream on: (String new: 400).
methodInterfaces keys asSortedCollection do: [:sel |
strm cr; nextPut: $(;
nextPutAll: sel; tab; tab; tab; nextPut: $';
nextPutAll: (methodInterfaces at: sel) wording;
nextPut: $'; tab; tab; tab; nextPut: $';
nextPutAll: (methodInterfaces at: sel) documentation;
nextPut: $'; nextPut: $)].
^ strm contents!
----- Method: Vocabulary>>translatedWordingFor: (in category 'translation') -----
translatedWordingFor: aSymbol
"If I have a translated wording for aSymbol, return it, else return aSymbol. Caveat: at present, this mechanism is only germane for *assignment-operator wordings*"
#(: Incr: Decr: Mult:) with: #('' 'increase by' 'decrease by' 'multiply by') do:
[:a :b | aSymbol = a ifTrue: [^ b translated]].
^ aSymbol translated!
----- Method: Vocabulary>>translatedWordingsFor: (in category 'translation') -----
translatedWordingsFor: symbolList
"Answer a list giving the translated wordings for the input list. Caveat: at present, this mechanism is only germane for *categories*"
^ symbolList collect: [:sym | self translatedWordingFor: sym]
!
----- Method: Vocabulary>>translationKeyFor: (in category 'translation') -----
translationKeyFor: translatedWording
self flag: #yo.
^ translatedWording.
!
----- Method: Vocabulary>>translationTable (in category 'translation') -----
translationTable
^translationTable ifNil: [ElementCategory new]!
----- Method: Vocabulary>>vocabularyName (in category 'queries') -----
vocabularyName
"Answer the name of the vocabulary"
^ vocabularyName!
----- Method: Vocabulary>>vocabularyName: (in category 'initialization') -----
vocabularyName: aName
"Set the name of the vocabulary as indicated"
vocabularyName := aName!
MessageSend subclass: #MethodCall
instanceVariableNames: 'lastValue methodInterface timeStamp'
classVariableNames: ''
poolDictionaries: ''
category: 'Protocols-Kernel'!
!MethodCall commentStamp: '<historical>' prior: 0!
A MethodCall is a resendable message-send, complete with receiver, instantiated arguments, and a memory of when it was last evaluated and what the last value was.
The methodInterface with which it is associated can furnish argument names, documentation, and other information.!
----- Method: MethodCall>>ephemeralMethodInterface (in category 'method interface') -----
ephemeralMethodInterface
"Answer a methodInterface for me. If I have one stored, answer it; if
not, conjure up an interface and answer it but do NOT store it
internally. You can call this directly if you need a method interface
for me but do not want any conjured-up interface to persist."
^ methodInterface
ifNil: [MethodInterface new
conjuredUpFor: selector
class: (self receiver class whichClassIncludesSelector: selector)]!
----- Method: MethodCall>>evaluate (in category 'evaluation') -----
evaluate
"Evaluate the receiver, and if value has changed, signal value-changed"
| result |
result := arguments isEmptyOrNil
ifTrue: [self receiver perform: selector]
ifFalse: [self receiver perform: selector withArguments: arguments asArray].
timeStamp := Time dateAndTimeNow.
result ~= lastValue ifTrue:
[lastValue := result.
self changed: #value]
!
----- Method: MethodCall>>everEvaluated (in category 'evaluation') -----
everEvaluated
"Answer whether this method call has ever been evaluated"
^ timeStamp notNil!
----- Method: MethodCall>>lastValue (in category 'evaluation') -----
lastValue
"Answer the last value I remember obtaining from an evaluation"
^ lastValue!
----- Method: MethodCall>>methodInterface (in category 'method interface') -----
methodInterface
"Answer the receiver's methodInterface, conjuring one up on the spot (and remembering) if not present"
^ methodInterface ifNil:
[methodInterface := self ephemeralMethodInterface]!
----- Method: MethodCall>>methodInterface: (in category 'method interface') -----
methodInterface: anInterface
"Set my methodInterface"
methodInterface := anInterface!
----- Method: MethodCall>>methodInterfaceOrNil (in category 'method interface') -----
methodInterfaceOrNil
"Answer my methodInterface, whether it is nil or not"
^ methodInterface!
----- Method: MethodCall>>receiver:methodInterface: (in category 'initialization') -----
receiver: aReceiver methodInterface: aMethodInterface
"Initialize me to have the given receiver and methodInterface"
| aResultType |
receiver := aReceiver.
selector := aMethodInterface selector.
methodInterface := aMethodInterface.
arguments := aMethodInterface defaultArguments.
self flag: #noteToTed.
"the below can't really survive, I know. The intent is that if the method has a declared result type, we want the preferred readout type to be able to handle the initial #lastValue even if the MethodCall has not been evaluated yet; thus we'd rather have a boolean value such as true rather than a nil here if we're showing a boolean readout such as a checkbox, and likewise for color-valued and numeric-valued readouts etc, "
(aResultType := methodInterface resultType) ~~ #unknown ifTrue:
[lastValue := (Vocabulary vocabularyForType: aResultType) initialValueForASlotFor: aReceiver] !
----- Method: MethodCall>>receiver:methodInterface:initialArguments: (in category 'initialization') -----
receiver: aReceiver methodInterface: aMethodInterface initialArguments: initialArguments
"Set up a method-call for the given receiver, method-interface, and initial arguments"
receiver := aReceiver.
selector := aMethodInterface selector.
methodInterface := aMethodInterface.
arguments := initialArguments ifNotNil: [initialArguments asArray]
!
----- Method: MethodCall>>setArgumentNamed:toValue: (in category 'argument access') -----
setArgumentNamed: aName toValue: aValue
"Set the argument of the given name to the given value"
| anIndex |
anIndex := self methodInterface argumentVariables findFirst:
[:aVariable | aVariable variableName = aName].
anIndex > 0
ifTrue:
[arguments at: anIndex put: aValue]
ifFalse:
[self error: 'argument missing'].
self changed: #argumentValue!
----- Method: MethodCall>>valueOfArgumentNamed: (in category 'initialization') -----
valueOfArgumentNamed: aName
"Answer the value of the given arguement variable"
| anIndex |
anIndex := self methodInterface argumentVariables findFirst:
[:aVariable | aVariable variableName = aName].
^ anIndex > 0
ifTrue:
[arguments at: anIndex]
ifFalse:
[self error: 'variable not found']!
More information about the Packages
mailing list