cocoa.subclassing: cleaner CLASS: syntax; ui.backend.cocoa: ignore events delivered...

diff --git a/basis/cocoa/cocoa-tests.factor b/basis/cocoa/cocoa-tests.factor
index eefc04e2a169a80f6f2e4f471312ea041df51406..fee8c60c216e441e12531ac5c07702d0efaee376 100644 (file)
--- a/basis/cocoa/cocoa-tests.factor
+++ b/basis/cocoa/cocoa-tests.factor
@@ -4,14 +4,12 @@ tools.test memory compiler.units math core-graphics.types ;
 FROM: alien.c-types => int void ;
 IN: cocoa.tests
 
-CLASS: {
-    { +superclass+ "NSObject" }
-    { +name+ "Foo" }
-}
-
-METHOD: void foo: NSRect rect [
-    gc rect "x" set
-] ;
+CLASS: Foo < NSObject
+[
+    METHOD: void foo: NSRect rect [
+        gc rect "x" set
+    ]
+]
 
 : test-foo ( -- )
     Foo -> alloc -> init
@@ -25,12 +23,10 @@ test-foo
 [ 101.0 ] [ "x" get CGRect-w ] unit-test
 [ 102.0 ] [ "x" get CGRect-h ] unit-test
 
-CLASS: {
-    { +superclass+ "NSObject" }
-    { +name+ "Bar" }
-}
-
-METHOD: NSRect bar [ test-foo "x" get ] ;
+CLASS: Bar < NSObject
+[
+    METHOD: NSRect bar [ test-foo "x" get ]
+]
 
 Bar [
     -> alloc -> init
@@ -44,14 +40,12 @@ Bar [
 [ 102.0 ] [ "x" get CGRect-h ] unit-test
 
 ! Make sure that we can add methods
-CLASS: {
-    { +superclass+ "NSObject" }
-    { +name+ "Bar" }
-}
-
-METHOD: NSRect bar [ test-foo "x" get ]
+CLASS: Bar < NSObject
+[
+    METHOD: NSRect bar [ test-foo "x" get ]
 
-METHOD: int babb: int x [ x sq ] ;
+    METHOD: int babb: int x [ x sq ]
+]
 
 [ 144 ] [
     Bar [

diff --git a/basis/cocoa/subclassing/subclassing-docs.factor b/basis/cocoa/subclassing/subclassing-docs.factor
index 2e1d9731694a6aa50ae6d3851074eb5b0b2fb91e..2c83e60ddeb65bb8f4536ce1ef4045164e0f903d 100644 (file)
--- a/basis/cocoa/subclassing/subclassing-docs.factor
+++ b/basis/cocoa/subclassing/subclassing-docs.factor
@@ -1,41 +1,10 @@
 USING: help.markup help.syntax strings alien hashtables ;
 IN: cocoa.subclassing
 
-HELP: define-objc-class
-{ $values { "imeth" "a sequence of instance method definitions" } { "hash" hashtable } }
-{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
-    { $list
-        { { $link +name+ } " - a string naming the new class. Required." }
-        { { $link +superclass+ } " - a string naming the superclass. Required." }
-        { { $link +protocols+ } " - an array of strings naming protocols implemented by the superclass. Optional." }
-    }
-"Every element of " { $snippet "imeth" } " defines an instance method, and is an array having the shape "
-{ $snippet "{ name return args quot }" }
-".:"
-{ $table
-    { "name" { "a selector name" } }
-    { "name" { "a C type name; see " { $link "c-data" } } }
-    { "args" { "a sequence of C type names; see " { $link "c-data" } } }
-    { "quot" { "a quotation to be run as a callback when the method is invoked; see " { $link alien-callback } } }
-}
-"The quotation is run with the following values on the stack:"
-{ $list
-    { "the receiver of the message; an " { $link alien } " pointing to an instance of this class" }
-    { "the selector naming the message; in most cases this value can be ignored" }
-    "arguments passed to the message, if any"
-}
-"There is no way to define instance variables or class methods using this mechanism. However, instance variables can be simulated by using the receiver to key into an assoc." } ;
-
 HELP: CLASS:
-{ $syntax "CLASS: spec imeth... ;" }
-{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
-{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
-{ $list
-    { { $link +name+ } " - a string naming the new class. Required." }
-    { { $link +superclass+ } " - a string naming the superclass. Required." }
-    { { $link +protocols+ } " - an array of strings naming protocols implemented by the superclass. Optional." }
-}
-"Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
+{ $syntax "CLASS: name < superclass protocols... [ imeth... ]" }
+{ $values { "name" "a new class name" } { "superclass" "a superclass name" } { "protocols" "zero or more protocol names" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
+{ $description "Defines a new Objective C class. Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
 $nl
 "This word is preferred to calling " { $link define-objc-class } ", because it creates a class word in the " { $vocab-link "cocoa.classes" } " vocabulary at parse time, allowing code to refer to the class word in the same source file where the class is defined." } ;
 
@@ -49,8 +18,6 @@ HELP: METHOD:
 ARTICLE: "objc-subclassing" "Subclassing Objective C classes"
 "Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
 { $subsections POSTPONE: CLASS: POSTPONE: METHOD: }
-"This word is actually syntax sugar for an ordinary word:"
-{ $subsections define-objc-class }
 "Objective C class definitions are saved in the image. If the image is saved and Factor is restarted with the saved image, custom class definitions are made available to the Objective C runtime when they are first accessed from within Factor." ;
 
 IN: cocoa.subclassing

diff --git a/basis/cocoa/subclassing/subclassing.factor b/basis/cocoa/subclassing/subclassing.factor
index 4c5099e04be262fe49c00c6ae2f8dd34461c5eb5..b88d3afd7b0b89d784d66e9e53a1d2505fde817c 100644 (file)
--- a/basis/cocoa/subclassing/subclassing.factor
+++ b/basis/cocoa/subclassing/subclassing.factor
@@ -29,7 +29,7 @@ IN: cocoa.subclassing
 : add-protocols ( protocols class -- )
     '[ [ _ ] dip objc-protocol add-protocol ] each ;
 
-: (define-objc-class) ( imeth protocols superclass name -- )
+: (define-objc-class) ( methods protocols superclass name -- )
     [ objc-class ] dip 0 objc_allocateClassPair
     [ add-protocols ] [ add-methods ] [ objc_registerClassPair ]
     tri ;
@@ -59,28 +59,23 @@ IN: cocoa.subclassing
         class sel imp types add-method
     ] if* ;
     
-: redefine-objc-methods ( imeth name -- )
+: redefine-objc-methods ( methods name -- )
     dup class-exists? [
         objc_getClass '[ [ _ ] dip (redefine-objc-method) ] each
     ] [ 2drop ] if ;
 
-SYMBOL: +name+
-SYMBOL: +protocols+
-SYMBOL: +superclass+
-
-: define-objc-class ( imeth hash -- )
-    clone [
-        prepare-methods
-        +name+ get "cocoa.classes" create drop
-        +name+ get 2dup redefine-objc-methods swap
-        +protocols+ get +superclass+ get +name+ get
-        '[ _ _ _ _ (define-objc-class) ]
-        import-objc-class
-    ] bind ;
+:: define-objc-class ( name superclass protocols methods -- )
+    methods prepare-methods :> methods
+    name "cocoa.classes" create drop
+    methods name redefine-objc-methods
+    name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
 
 SYNTAX: CLASS:
-    parse-definition unclip
-    >hashtable define-objc-class ;
+    scan-token
+    "<" expect
+    scan-token
+    "[" parse-tokens
+    \ ] parse-until define-objc-class ;
 
 : (parse-selector) ( -- )
     scan-token {

diff --git a/basis/tools/deploy/test/14/14.factor b/basis/tools/deploy/test/14/14.factor
index 0b98b45d680964beb987ba354f728942e334bf2e..95ab68916af6ac0a700babf6f48f0c7ff8480f4f 100644 (file)
--- a/basis/tools/deploy/test/14/14.factor
+++ b/basis/tools/deploy/test/14/14.factor
@@ -6,16 +6,14 @@ kernel math ;
 FROM: alien.c-types => float ;
 IN: tools.deploy.test.14
 
-CLASS: {
-    { +superclass+ "NSObject" }
-    { +name+ "Bar" }
-}
-
-METHOD: float bar: NSRect rect [
-    rect origin>> [ x>> ] [ y>> ] bi +
-    rect size>> [ w>> ] [ h>> ] bi +
-    +
-] ;
+CLASS: Bar < NSObject
+[
+    METHOD: float bar: NSRect rect [
+        rect origin>> [ x>> ] [ y>> ] bi +
+        rect size>> [ w>> ] [ h>> ] bi +
+        +
+    ]
+]
 
 : main ( -- )
     Bar -> alloc -> init

diff --git a/basis/ui/backend/cocoa/cocoa.factor b/basis/ui/backend/cocoa/cocoa.factor
index 65286ab1818df97baf95c11a02c2305adeeb65ec..13f07b9d41ca50d32792c2c5f9f4b4d85f85ff17 100644 (file)
--- a/basis/ui/backend/cocoa/cocoa.factor
+++ b/basis/ui/backend/cocoa/cocoa.factor
@@ -228,12 +228,11 @@ M: cocoa-ui-backend system-alert
     ] [ 2drop ] if*
     init-thread-timer ;
 
-CLASS: {
-    { +superclass+ "NSObject" }
-    { +name+ "FactorApplicationDelegate" }
-}
-
-METHOD: void applicationDidUpdate: id obj [ reset-run-loop ] ;
+CLASS: FactorApplicationDelegate < NSObject
+[
+    METHOD: void applicationDidUpdate: id obj
+    [ reset-run-loop ]
+]
 
 : install-app-delegate ( -- )
     NSApp FactorApplicationDelegate install-delegate ;

diff --git a/basis/ui/backend/cocoa/tools/tools.factor b/basis/ui/backend/cocoa/tools/tools.factor
index e41531b58794efbb82da1fe676784e193290f6ed..bacd6f02e4129bc7b9c296c11121e78db204d7d8 100644 (file)
--- a/basis/ui/backend/cocoa/tools/tools.factor
+++ b/basis/ui/backend/cocoa/tools/tools.factor
@@ -21,30 +21,28 @@ IN: ui.backend.cocoa.tools
     image save-panel [ save-image ] when* ;
 
 ! Handle Open events from the Finder
-CLASS: {
-    { +superclass+ "FactorApplicationDelegate" }
-    { +name+ "FactorWorkspaceApplicationDelegate" }
-}
-
-METHOD: void application: id app openFiles: id files [ files finder-run-files ]
+CLASS: FactorWorkspaceApplicationDelegate < FactorApplicationDelegate
+[
+    METHOD: void application: id app openFiles: id files [ files finder-run-files ]
 
-METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
+    METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
 
-METHOD: id factorListener: id app [ show-listener f ]
+    METHOD: id factorListener: id app [ show-listener f ]
 
-METHOD: id factorBrowser: id app [ show-browser f ]
+    METHOD: id factorBrowser: id app [ show-browser f ]
 
-METHOD: id newFactorListener: id app [ listener-window f ]
+    METHOD: id newFactorListener: id app [ listener-window f ]
 
-METHOD: id newFactorBrowser: id app [ browser-window f ]
+    METHOD: id newFactorBrowser: id app [ browser-window f ]
 
-METHOD: id runFactorFile: id app [ menu-run-files f ]
+    METHOD: id runFactorFile: id app [ menu-run-files f ]
 
-METHOD: id saveFactorImage: id app [ save f ]
+    METHOD: id saveFactorImage: id app [ save f ]
 
-METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
+    METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
 
-METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ] ;
+    METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ]
+]
 
 : install-app-delegate ( -- )
     NSApp FactorWorkspaceApplicationDelegate install-delegate ;
@@ -55,19 +53,17 @@ METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ]
     dup [ quot call( string -- result/f ) ] when
     [ pboard set-pasteboard-string ] when* ;
 
-CLASS: {
-    { +superclass+ "NSObject" }
-    { +name+ "FactorServiceProvider" }
-}
-
-METHOD: void evalInListener: id pboard userData: id userData error: id error
-[ pboard error [ eval-listener f ] do-service ]
-
-METHOD: void evalToString: id pboard userData: id userData error: id error
+CLASS: FactorServiceProvider < NSObject
 [
-    pboard error
-    [ [ (eval>string) ] with-interactive-vocabs ] do-service
-] ;
+    METHOD: void evalInListener: id pboard userData: id userData error: id error
+    [ pboard error [ eval-listener f ] do-service ]
+
+    METHOD: void evalToString: id pboard userData: id userData error: id error
+    [
+        pboard error
+        [ [ (eval>string) ] with-interactive-vocabs ] do-service
+    ]
+]
 
 : register-services ( -- )
     NSApp

diff --git a/basis/ui/backend/cocoa/views/views.factor b/basis/ui/backend/cocoa/views/views.factor
index 6b6e3a32c611af128e63afbd4beee7e906f29292..e98c31b295391d0f142fcc638e6f25057b486f02 100644 (file)
--- a/basis/ui/backend/cocoa/views/views.factor
+++ b/basis/ui/backend/cocoa/views/views.factor
@@ -3,14 +3,16 @@
 USING: accessors alien alien.c-types alien.data alien.strings
 arrays assocs cocoa kernel math cocoa.messages cocoa.subclassing
 cocoa.classes cocoa.views cocoa.application cocoa.pasteboard
-cocoa.runtime cocoa.types cocoa.windows sequences io.encodings.utf8
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
-core-foundation.strings core-graphics core-graphics.types threads
-combinators math.rectangles ;
+cocoa.runtime cocoa.types cocoa.windows sequences
+io.encodings.utf8 locals ui ui.private ui.gadgets
+ui.gadgets.private ui.gadgets.worlds ui.gestures
+core-foundation.strings core-graphics core-graphics.types
+threads combinators math.rectangles ;
 IN: ui.backend.cocoa.views
 
 : send-mouse-moved ( view event -- )
-    [ mouse-location ] [ drop window ] 2bi move-hand fire-motion yield ;
+    [ mouse-location ] [ drop window ] 2bi
+    dup [ move-hand fire-motion yield ] [ 2drop ] if ;
 
 : button ( event -- n )
     #! Cocoa -> Factor UI button mapping
@@ -62,7 +64,7 @@ CONSTANT: key-codes
     [ event-modifiers ] [ key-code ] bi ;
 
 : send-key-event ( view gesture -- )
-    swap window propagate-key-gesture ;
+    swap window dup [ propagate-key-gesture ] [ 2drop ] if ;
 
 : interpret-key-event ( view event -- )
     NSArray swap -> arrayWithObject: -> interpretKeyEvents: ;
@@ -82,22 +84,25 @@ CONSTANT: key-codes
     [ nip mouse-event>gesture <button-down> ]
     [ mouse-location ]
     [ drop window ]
-    2tri send-button-down ;
+    2tri
+    dup [ send-button-down ] [ 3drop ] if ;
 
 : send-button-up$ ( view event -- )
     [ nip mouse-event>gesture <button-up> ]
     [ mouse-location ]
     [ drop window ]
-    2tri send-button-up ;
+    2tri
+    dup [ send-button-up ] [ 3drop ] if ;
 
 : send-scroll$ ( view event -- )
     [ nip [ -> deltaX ] [ -> deltaY ] bi [ neg ] bi@ 2array ]
     [ mouse-location ]
     [ drop window ]
-    2tri send-scroll ;
+    2tri
+    dup [ send-scroll ] [ 3drop ] if ;
 
-: send-action$ ( view event gesture -- junk )
-    [ drop window ] dip send-action f ;
+: send-action$ ( view event gesture -- )
+    [ drop window ] dip over [ send-action ] [ 2drop ] if ;
 
 : add-resize-observer ( observer object -- )
     [
@@ -141,176 +146,191 @@ CONSTANT: selector>action H{
     selector>action at
     [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
 
-CLASS: {
-    { +superclass+ "NSOpenGLView" }
-    { +name+ "FactorView" }
-    { +protocols+ { "NSTextInput" } }
-}
-
-! Rendering
-METHOD: void drawRect: NSRect rect [ self window draw-world ]
-
-! Events
-METHOD: char acceptsFirstMouse: id event [ 1 ]
-
-METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
+CLASS: FactorView < NSOpenGLView NSTextInput
+[
+    ! Rendering
+    METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ]
 
-METHOD: void mouseExited: id event [ forget-rollover ]
+    ! Events
+    METHOD: char acceptsFirstMouse: id event [ 1 ]
 
-METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
+    METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
 
-METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
+    METHOD: void mouseExited: id event [ forget-rollover ]
 
-METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
+    METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
 
-METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
+    METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
 
-METHOD: void mouseDown: id event [ self event send-button-down$ ]
+    METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
 
-METHOD: void mouseUp: id event [ self event send-button-up$ ]
+    METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
 
-METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
+    METHOD: void mouseDown: id event [ self event send-button-down$ ]
 
-METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
+    METHOD: void mouseUp: id event [ self event send-button-up$ ]
 
-METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
+    METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
 
-METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
+    METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
 
-METHOD: void scrollWheel: id event [ self event send-scroll$ ]
+    METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
 
-METHOD: void keyDown: id event [ self event send-key-down-event ]
+    METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
 
-METHOD: void keyUp: id event [ self event send-key-up-event ]
+    METHOD: void scrollWheel: id event [ self event send-scroll$ ]
 
-METHOD: char validateUserInterfaceItem: id event
-[
-    self window
-    event -> action utf8 alien>string validate-action
-    [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
-]
+    METHOD: void keyDown: id event [ self event send-key-down-event ]
 
-METHOD: id undo: id event [ self event undo-action send-action$ ]
+    METHOD: void keyUp: id event [ self event send-key-up-event ]
 
-METHOD: id redo: id event [ self event redo-action send-action$ ]
+    METHOD: char validateUserInterfaceItem: id event
+    [
+        self window [
+            event -> action utf8 alien>string validate-action
+            [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
+        ] [ 0 ] if*
+    ]
 
-METHOD: id cut: id event [ self event cut-action send-action$ ]
+    METHOD: id undo: id event [ self event undo-action send-action$ f ]
 
-METHOD: id copy: id event [ self event copy-action send-action$ ]
+    METHOD: id redo: id event [ self event redo-action send-action$ f ]
 
-METHOD: id paste: id event [ self event paste-action send-action$ ]
+    METHOD: id cut: id event [ self event cut-action send-action$ f ]
 
-METHOD: id delete: id event [ self event delete-action send-action$ ]
+    METHOD: id copy: id event [ self event copy-action send-action$ f ]
 
-METHOD: id selectAll: id event [ self event select-all-action send-action$ ]
+    METHOD: id paste: id event [ self event paste-action send-action$ f ]
 
-METHOD: id newDocument: id event [ self event new-action send-action$ ]
+    METHOD: id delete: id event [ self event delete-action send-action$ f ]
 
-METHOD: id openDocument: id event [ self event open-action send-action$ ]
+    METHOD: id selectAll: id event [ self event select-all-action send-action$ f ]
 
-METHOD: id saveDocument: id event [ self event save-action send-action$ ]
+    METHOD: id newDocument: id event [ self event new-action send-action$ f ]
 
-METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ ]
+    METHOD: id openDocument: id event [ self event open-action send-action$ f ]
 
-METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ ]
+    METHOD: id saveDocument: id event [ self event save-action send-action$ f ]
 
-! Multi-touch gestures
-METHOD: void magnifyWithEvent: id event
-[
-    self event
-    dup -> deltaZ sgn {
-        {  1 [ zoom-in-action send-action$ drop ] }
-        { -1 [ zoom-out-action send-action$ drop ] }
-        {  0 [ 2drop ] }
-    } case
-]
+    METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ]
 
-METHOD: void swipeWithEvent: id event
-[
-    self event
-    dup -> deltaX sgn {
-        {  1 [ left-action send-action$ drop ] }
-        { -1 [ right-action send-action$ drop ] }
-        {  0
-            [
-                dup -> deltaY sgn {
-                    {  1 [ up-action send-action$ drop ] }
-                    { -1 [ down-action send-action$ drop ] }
-                    {  0 [ 2drop ] }
-                } case
-            ]
-        }
-    } case
-]
+    METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ f ]
 
-METHOD: char acceptsFirstResponder [ 1 ]
-
-! Services
-METHOD: id validRequestorForSendType: id sendType returnType: id returnType
-[
-    ! We return either self or nil
-    self window world-focus sendType returnType
-    valid-service? [ self ] [ f ] if
-]
-
-METHOD: char writeSelectionToPasteboard: id pboard types: id types
-[
-    NSStringPboardType types CF>string-array member? [
-        self window world-focus gadget-selection
-        [ pboard set-pasteboard-string 1 ] [ 0 ] if*
-    ] [ 0 ] if
-]
+    ! Multi-touch gestures
+    METHOD: void magnifyWithEvent: id event
+    [
+        self event
+        dup -> deltaZ sgn {
+            {  1 [ zoom-in-action send-action$ ] }
+            { -1 [ zoom-out-action send-action$ ] }
+            {  0 [ 2drop ] }
+        } case
+    ]
+
+    METHOD: void swipeWithEvent: id event
+    [
+        self event
+        dup -> deltaX sgn {
+            {  1 [ left-action send-action$ ] }
+            { -1 [ right-action send-action$ ] }
+            {  0
+                [
+                    dup -> deltaY sgn {
+                        {  1 [ up-action send-action$ ] }
+                        { -1 [ down-action send-action$ ] }
+                        {  0 [ 2drop ] }
+                    } case
+                ]
+            }
+        } case
+    ]
+
+    METHOD: char acceptsFirstResponder [ 1 ]
+
+    ! Services
+    METHOD: id validRequestorForSendType: id sendType returnType: id returnType
+    [
+        ! We return either self or nil
+        self window [
+            world-focus sendType returnType
+            valid-service? [ self ] [ f ] if
+        ] [ f ] if*
+    ]
+
+    METHOD: char writeSelectionToPasteboard: id pboard types: id types
+    [
+        NSStringPboardType types CF>string-array member? [
+            self window [
+                world-focus gadget-selection
+                [ pboard set-pasteboard-string 1 ] [ 0 ] if*
+            ] [ 0 ] if*
+        ] [ 0 ] if
+    ]
+
+    METHOD: char readSelectionFromPasteboard: id pboard
+    [
+        self window :> window
+        window [
+            pboard pasteboard-string
+            [ window user-input 1 ] [ 0 ] if*
+        ] [ 0 ] if
+    ]
+
+    ! Text input
+    METHOD: void insertText: id text
+    [
+        self window :> window
+        window [
+            text CF>string window user-input
+        ] when
+    ]
 
-METHOD: char readSelectionFromPasteboard: id pboard
-[
-    pboard pasteboard-string
-    [ self window user-input 1 ] [ 0 ] if*
-]
+    METHOD: char hasMarkedText [ 0 ]
 
-! Text input
-METHOD: void insertText: id text
-[ text CF>string self window user-input ]
+    METHOD: NSRange markedRange [ 0 0 <NSRange> ]
 
-METHOD: char hasMarkedText [ 0 ]
+    METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
 
-METHOD: NSRange markedRange [ 0 0 <NSRange> ]
+    METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
 
-METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
+    METHOD: void unmarkText [ ]
 
-METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
+    METHOD: id validAttributesForMarkedText [ NSArray -> array ]
 
-METHOD: void unmarkText [ ]
+    METHOD: id attributedSubstringFromRange: NSRange range [ f ]
 
-METHOD: id validAttributesForMarkedText [ NSArray -> array ]
+    METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
 
-METHOD: id attributedSubstringFromRange: NSRange range [ f ]
+    METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
 
-METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
+    METHOD: NSInteger conversationIdentifier [ self alien-address ]
 
-METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
+    ! Initialization
+    METHOD: void updateFactorGadgetSize: id notification
+    [
+        self window :> window
+        window [
+            self view-dim window dim<< yield
+        ] when
+    ]
 
-METHOD: NSInteger conversationIdentifier [ self alien-address ]
+    METHOD: void doCommandBySelector: SEL selector [ ]
 
-! Initialization
-METHOD: void updateFactorGadgetSize: id notification
-[ self view-dim self window dim<< yield ]
+    METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
+    [
+        self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
+        dup dup add-resize-observer
+    ]
 
-METHOD: void doCommandBySelector: SEL selector [ ]
+    METHOD: char isOpaque [ 0 ]
 
-METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
-[
-    self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
-    dup dup add-resize-observer
+    METHOD: void dealloc
+    [
+        self remove-observer
+        self SUPER-> dealloc
+    ]
 ]
 
-METHOD: char isOpaque [ 0 ]
-
-METHOD: void dealloc
-[
-    self remove-observer
-    self SUPER-> dealloc
-] ;
-
 : sync-refresh-to-screen ( GLView -- )
     -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
     CGLSetParameter drop ;
@@ -321,38 +341,39 @@ METHOD: void dealloc
 : save-position ( world window -- )
     -> frame CGRect-top-left 2array >>window-loc drop ;
 
-CLASS: {
-    { +name+ "FactorWindowDelegate" }
-    { +superclass+ "NSObject" }
-}
-
-METHOD: void windowDidMove: id notification
+CLASS: FactorWindowDelegate < NSObject
 [
-    notification -> object -> contentView window
-    notification -> object save-position
-]
+    METHOD: void windowDidMove: id notification
+    [
+        notification -> object -> contentView window
+        [ notification -> object save-position ] when*
+    ]
 
-METHOD: void windowDidBecomeKey: id notification
-[
-    notification -> object -> contentView window
-    focus-world
-]
+    METHOD: void windowDidBecomeKey: id notification
+    [
+        notification -> object -> contentView window
+        [ focus-world ] when*
+    ]
 
-METHOD: void windowDidResignKey: id notification
-[
-    forget-rollover
-    notification -> object -> contentView
-    dup -> isInFullScreenMode 0 =
-    [ window [ unfocus-world ] when* ] [ drop ] if
+    METHOD: void windowDidResignKey: id notification
+    [
+        forget-rollover
+        notification -> object -> contentView :> view
+        view window :> window
+        window [
+            view -> isInFullScreenMode 0 =
+            [ window unfocus-world ] when
+        ] when
+    ]
+
+    METHOD: char windowShouldClose: id notification [ 1 ]
+
+    METHOD: void windowWillClose: id notification
+    [
+        notification -> object -> contentView
+        [ window ungraft ] [ unregister-window ] bi
+    ]
 ]
 
-METHOD: char windowShouldClose: id notification [ 1 ]
-
-METHOD: void windowWillClose: id notification
-[
-    notification -> object -> contentView
-    [ window ungraft ] [ unregister-window ] bi
-] ;
-
 : install-window-delegate ( window -- )
     FactorWindowDelegate install-delegate ;