for VisualWorks 7.9 on Mac OS X (macOS 10.14 Mojave or earlier) / Windows (Windows 7 or later)
for VisualWorks 8.1 on Mac OS X (macOS 10.14 Mojave or later) / Windows (Windows 7 or later)
SmalltalkプログラムをSmalltalkプログラムで作る、すなわち、Smalltalkメタプログラミングに挑戦しましょう。バンドルを作り、パッケージを作り、名前空間を作り、クラスを作り、プロトコルを作り、メソッドを作り、テストして、保存する、これら一連のSmalltalkプログラミングの過程それ自身をプログラミングしちゃおう！という試みになります。
Smalltalkはすべてがオブジェクトへのメッセージング（メッセージ送信）で成り立っているわけですから、これら一連のSmalltalkプログラミングの過程さえも、メッセージングにできるはずです。そりゃもう『目にうつる全てのことはメッセージ』ですから…。
メタプログラミングの題材として「My First MVC」を取り上げます。「私の初めてのモデル・ビュー・コントローラ」のプログラム作成過程を、メタプログラムに仕立て上げてゆくプログラミングになります。
さぁ！始めましょう。メタプログラムの実行結果をシステムブラウザで示してゆきます。
これから行ってゆくことのワークブック（Workbook：Workspaceの集合体）も用意しておきました。
$ curl -O http://www.cc.kyoto-su.ac.jp/~atsushi/Programs/VisualWorks/MetaProgrammingMyFirstMVC/Workbook_MyFirstMVC.zip % Total % Received % Xferd Average Speed Time Time Time Current Dload Upload Total Spent Left Speed 100 12862 100 12862 0 0 131k 0 --:--:-- --:--:-- --:--:-- 130k $ unzip Workbook_MyFirstMVC.zip Archive: Workbook_MyFirstMVC.zip creating: Workbook_MyFirstMVC/ inflating: Workbook_MyFirstMVC/Workbook_MyFirstMVC.st creating: Workbook_MyFirstMVC/Workspaces/ inflating: Workbook_MyFirstMVC/Workspaces/01_Bundle.st inflating: Workbook_MyFirstMVC/Workspaces/02_Packages.st inflating: Workbook_MyFirstMVC/Workspaces/03_NameSpace.st inflating: Workbook_MyFirstMVC/Workspaces/04_AJ.MyFirstModel.st inflating: Workbook_MyFirstMVC/Workspaces/05_AJ.MyFirstView.st inflating: Workbook_MyFirstMVC/Workspaces/06_AJ.MyFirstController.st inflating: Workbook_MyFirstMVC/Workspaces/07_AJ.MyFirstModel.image.st inflating: Workbook_MyFirstMVC/Workspaces/08_AJ.MyFirstModel.createView.st inflating: Workbook_MyFirstMVC/Workspaces/09_AJ.MyFirstModel.defaultViewClass.st inflating: Workbook_MyFirstMVC/Workspaces/10_AJ.MyFirstModel.class.example.st inflating: Workbook_MyFirstMVC/Workspaces/11_AJ.MyFirstModel.class.windowSpec.st inflating: Workbook_MyFirstMVC/Workspaces/12_AJ.MyFirstModel.class.menuBar.st inflating: Workbook_MyFirstMVC/Workspaces/13_AJ.MyFirstModel.class.popUpMenu.st inflating: Workbook_MyFirstMVC/Workspaces/14_AJ.MyFirstView.preferredExtent.st inflating: Workbook_MyFirstMVC/Workspaces/15_AJ.MyFirstView.defaultControllerClass.st inflating: Workbook_MyFirstMVC/Workspaces/16_AJ.MyFirstView.displayOn_.st inflating: Workbook_MyFirstMVC/Workspaces/17_AJ.MyFirstController.redButtonPressedEvent_.st inflating: Workbook_MyFirstMVC/Workspaces/18_AJ.MyFirstController.doSomething.st inflating: Workbook_MyFirstMVC/Workspaces/19_Test.st inflating: Workbook_MyFirstMVC/Workspaces/20_Save.st
Smalltalkのファイルブラウザから「Workbook_MyFirstMVC.st」をファイルイン（File In）してくださいませ。
これからやってゆくことのワークブック（Workbook：Workspaceの集合体）が開きます。
| aBundle |
aBundle := Smalltalk.Store.Registry bundleNamedOrCreate: 'AokiJuku'.
aBundle comment: 'AokiJuku: Programming in Summer 2019'.
^aBundle
==> {AokiJuku}
| aBundle aCollection aPackage |
aBundle := Smalltalk.Store.Registry bundleNamed: 'AokiJuku'.
aBundle ifNil: [^self error: 'fatal error'].
aCollection := Smalltalk.Core.OrderedCollection new.
aPackage := Smalltalk.Store.Registry packageNamedOrCreate: 'AJ-System'.
aPackage comment: 'AJ-System: System in AokiJuku'.
aCollection add: aPackage.
(aBundle containedItems includes: aPackage)
ifFalse: [aBundle addItem: aPackage].
aPackage := Smalltalk.Store.Registry packageNamedOrCreate: 'AJ-MyFirstMVC'.
aPackage
comment: 'AJ-MyFirstMVC: My First Model-View-Controller in AokiJuku'.
aCollection add: aPackage.
(aBundle containedItems includes: aPackage)
ifFalse: [aBundle addItem: aPackage].
^aCollection
==> OrderedCollection ([AJ-System] [AJ-MyFirstMVC])
| aPackage aNameSpace |
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-System'.
aPackage ifNil: [^self error: 'fatal error'].
aNameSpace := Smalltalk at: #AJ
ifAbsent:
[aNameSpace := Smalltalk
defineNameSpace: #AJ
private: false
imports: 'private Core.*'
category: ''.
aNameSpace yourself].
aNameSpace comment: 'AJ: NameSpace for AokiJuku'.
Smalltalk.Store.XChangeSet current moveWholeObject: aNameSpace
toPackage: aPackage.
^aNameSpace
==> AJ
| aReference aNameSpace aPackage aClass |
aReference := #{Smalltalk.AJ}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aNameSpace := aReference value.
(aNameSpace isKindOf: Smalltalk.Kernel.NameSpace)
ifFalse: [^self error: 'fatal error'].
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-System'.
aPackage ifNil: [^self error: 'fatal error'].
aClass := aNameSpace
defineClass: #MyFirstModel
superclass: #{UI.ApplicationModel}
indexedType: #none
private: false
instanceVariableNames: 'image'
classInstanceVariableNames: ''
imports: ''
category: ''.
aClass
comment: 'My First Model
Instance Variables:
image <Image> bind an image, default is screen captured image
'.
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-MyFirstMVC'.
Smalltalk.Store.XChangeSet current moveWholeObject: aClass
toPackage: aPackage.
^aClass
==> AJ.MyFirstModel
| aReference aNameSpace aPackage aClass |
aReference := #{Smalltalk.AJ}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aNameSpace := aReference value.
(aNameSpace isKindOf: Smalltalk.Kernel.NameSpace)
ifFalse: [^self error: 'fatal error'].
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-System'.
aPackage ifNil: [^self error: 'fatal error'].
aClass := aNameSpace
defineClass: #MyFirstView
superclass: #{UI.View}
indexedType: #none
private: false
instanceVariableNames: ''
classInstanceVariableNames: ''
imports: ''
category: ''.
aClass comment: 'My First View
'.
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-MyFirstMVC'.
Smalltalk.Store.XChangeSet current moveWholeObject: aClass
toPackage: aPackage.
^aClass
==> AJ.MyFirstView
| aReference aNameSpace aPackage aClass |
aReference := #{Smalltalk.AJ}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aNameSpace := aReference value.
(aNameSpace isKindOf: Smalltalk.Kernel.NameSpace)
ifFalse: [^self error: 'fatal error'].
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-System'.
aPackage ifNil: [^self error: 'fatal error'].
aClass := aNameSpace
defineClass: #MyFirstController
superclass: #{UI.ControllerWithMenu}
indexedType: #none
private: false
instanceVariableNames: ''
classInstanceVariableNames: ''
imports: ''
category: ''.
aClass comment: 'My First Controller
'.
aPackage := Smalltalk.Store.Registry packageNamed: 'AJ-MyFirstMVC'.
Smalltalk.Store.XChangeSet current moveWholeObject: aClass
toPackage: aPackage.
^aClass
==> AJ.MyFirstController
| aReference aClass aSelector |
aReference := #{AJ.MyFirstModel}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass
compile: 'image
image
ifNil:
[image := Graphics.Screen default
completeContentsOfArea: Graphics.Screen default bounds].
^image'
classified: #accessing
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #image
| aReference aClass aSelector |
aReference := #{AJ.MyFirstModel}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass
compile: 'createView
| aView aController |
aView := self defaultViewClass model: self.
aController := aView controller.
aController menuHolder: [self class popUpMenu].
^aView'
classified: #'interface opening'
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #createView
| aReference aClass aSelector |
aReference := #{AJ.MyFirstModel}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass
compile: 'defaultViewClass
^#{AJ.MyFirstView} value'
classified: #'view accessing'
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #defaultViewClass
| aReference aClass aSelector |
aReference := #{AJ.MyFirstModel}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass class
compile: 'example
"AJ.MyFirstModel example."
| aBuilder |
aBuilder := self open.
^aBuilder'
classified: #examples
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #example
| aReference aClass aSelector |
aReference := #{AJ.MyFirstModel}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass class
compile: 'windowSpec
"Tools.UIPainter new openOnClass: self andSelector: #windowSpec"
<resource: #canvas>
^#(#{UI.FullSpec}
#window:
#(#{UI.WindowSpec}
#label: ''My First MVC''
#min: #(#{Core.Point} 200 150 )
#max: #(#{Core.Point} 800 600 )
#bounds: #(#{Graphics.Rectangle} 520 300 920 600 )
#flags: 4
#menu: #menuBar )
#component:
#(#{UI.SpecCollection}
#collection: #(
#(#{UI.ArbitraryComponentSpec}
#layout: #(#{Graphics.LayoutFrame} 0 0 0 0 0 1 0 1 )
#name: #ViewHolder
#flags: 11
#component: #createView ) ) ) )'
classified: #'interface specs'
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #windowSpec
| aReference aClass aSelector |
aReference := #{AJ.MyFirstModel}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass class
compile: 'menuBar
"Tools.MenuEditor new openOnClass: self andSelector: #menuBar"
<resource: #menu>
^#(#{UI.Menu} #(
#(#{UI.MenuItem}
#rawLabel: ''File''
#submenu: #(#{UI.Menu} #(
#(#{UI.MenuItem}
#rawLabel: ''Quit''
#value: #closeRequest ) ) #(1 ) nil ) )
#(#{UI.MenuItem}
#rawLabel: ''Misc''
#submenu: #(#{UI.Menu} #(
#(#{UI.MenuItem}
#rawLabel: ''Inspect''
#value: #inspect ) ) #(1 ) nil ) ) ) #(2 ) nil ) decodeAsLiteralArray'
classified: #resources
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #menuBar
| aReference aClass aSelector |
aReference := #{AJ.MyFirstModel}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass class
compile: 'popUpMenu
"Tools.MenuEditor new openOnClass: self andSelector: #popUpMenu"
<resource: #menu>
^#(#{UI.Menu} #(
#(#{UI.MenuItem}
#rawLabel: ''do something ...''
#value: #doSomething ) ) #(1 ) nil ) decodeAsLiteralArray'
classified: #resources
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #popUpMenu
| aReference aClass aSelector |
aReference := #{AJ.MyFirstView}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass
compile: 'preferredExtent
^self model image extent'
classified: #'bounds accessing'
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #preferredExtent
| aReference aClass aSelector |
aReference := #{AJ.MyFirstView}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass
compile: 'defaultControllerClass
^#{AJ.MyFirstController} value'
classified: #'controller accessing'
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #defaultControllerClass
| aReference aClass aSelector |
aReference := #{AJ.MyFirstView}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass
compile: 'displayOn: aGraphicsContext
self model image displayOn: aGraphicsContext'
classified: #displaying
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #displayOn:
| aReference aClass aSelector |
aReference := #{AJ.MyFirstController}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass
compile: 'redButtonPressedEvent: event
| aLocus aGraphicsContext aBlock |
aLocus := OrderedCollection new.
aGraphicsContext := (self view graphicsContext)
capStyle: Graphics.GraphicsContext capRound;
joinStyle: Graphics.GraphicsContext joinRound;
paint: Graphics.ColorValue red;
lineWidth: 3;
yourself.
aBlock :=
[[self sensor redButtonPressed] whileTrue:
[| aPoint |
aPoint := self sensor cursorPoint.
aLocus add: aPoint.
aGraphicsContext displayPolyline: aLocus.
Core.Processor yield.
0.025 seconds wait].
self view displayOn: aGraphicsContext].
UI.Cursor crossHair showWhile: aBlock'
classified: #events
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #redButtonPressedEvent:
| aReference aClass aSelector |
aReference := #{AJ.MyFirstController}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
aSelector := aClass
compile: 'doSomething
| aRectangle anImage aGraphicsContext |
aRectangle := self view topComponent displayBox
intersect: Graphics.Screen default bounds.
anImage := Graphics.Screen default completeContentsOfArea: aRectangle.
aGraphicsContext := self view graphicsContext.
self sensor waitNoButton.
UI.Cursor hand showWhile:
[UI.InputState default cursorPoint: aRectangle center.
anImage
follow: [self sensor cursorPoint - anImage bounds center]
while: [self sensor noButtonPressed]
on: aGraphicsContext.
self view invalidateNow].
self sensor waitNoButton'
classified: #'menu processing'
attributes: ((Dictionary new)
add: #package -> 'AJ-MyFirstMVC';
yourself).
^aSelector
==> #doSomething
"AJ.MyFirstModel example."
| aReference aClass |
aReference := #{AJ.MyFirstModel}.
aReference bindingOrNil ifNil: [^self error: 'fatal error'].
aClass := aReference value.
(aClass isKindOf: Kernel.Class) ifFalse: [^self error: 'fatal error'].
^aClass example
==> an UIBuilder
| aBundle fileName |
aBundle := Smalltalk.Store.Registry bundleNamed: 'AokiJuku'.
aBundle ifNil: [^self error: 'fatal error'].
fileName := Dialog
requestNewFileName: #FileOutOnC << #packages >> 'File out on:'
default: aBundle name , '-MyFirstMVC' , '.st'.
fileName isEmpty ifTrue: [^nil].
aBundle fileOutOnFileNamed: fileName.
^fileName
==> ~/Desktop/AokiJuku-MyFirstMVC.st
