cocoa.subclassing: new METHOD: syntax cleans up class definitions

basis/cocoa/cocoa-tests.factor

@@ -7,12 +7,11 @@ IN: cocoa.tests
 CLASS: {
     { +superclass+ "NSObject" }
     { +name+ "Foo" }
-} {
+}
-    "foo:"
+
-    void
+METHOD: void foo: NSRect rect [
-    { id SEL NSRect }
+    gc rect "x" set
-    [ gc "x" set 2drop ]
+] ;
-} ;
 
 : test-foo ( -- )
     Foo -> alloc -> init
@@ -29,12 +28,9 @@ test-foo
 CLASS: {
     { +superclass+ "NSObject" }
     { +name+ "Bar" }
-} {
+}
-    "bar"
+
-    NSRect
+METHOD: NSRect bar [ test-foo "x" get ] ;
-    { id SEL }
-    [ 2drop test-foo "x" get ]
-} ;
 
 Bar [
     -> alloc -> init
@@ -51,22 +47,16 @@ Bar [
 CLASS: {
     { +superclass+ "NSObject" }
     { +name+ "Bar" }
-} {
+}
-    "bar"
+
-    NSRect
+METHOD: NSRect bar [ test-foo "x" get ]
-    { id SEL }
+
-    [ 2drop test-foo "x" get ]
+METHOD: int babb: int x [ x sq ] ;
-} {
-    "babb"
-    int
-    { id SEL int }
-    [ 2nip sq ]
-} ;
 
 [ 144 ] [
     Bar [
         -> alloc -> init
-        dup 12 -> babb
+        dup 12 -> babb:
         swap -> release
     ] compile-call
 ] unit-test

basis/cocoa/subclassing/subclassing-docs.factor

@@ -24,20 +24,31 @@ HELP: define-objc-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 a hashtable." } ;
+"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" } }
+{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
-{ $description "A sugared form of the following:"
+{ $description "Defines a new Objective C class. The hashtable can contain the following keys:"
-    { $code "{ imeth... } \"spec\" define-objc-class" }
+{ $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."
+$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." } ;
 
-{ define-objc-class POSTPONE: CLASS: } related-words
+{ define-objc-class POSTPONE: CLASS: POSTPONE: METHOD: } related-words
+
+HELP: METHOD:
+{ $syntax "METHOD: return foo: type1 arg1 bar: type2 arg2 baz: ... [ body ]" }
+{ $values { "return" "a C type name" } { "type1" "a C type name" } { "arg1" "a local variable name" } { "body" "arbitrary code" } }
+{ $description "Defines a method inside of a " { $link POSTPONE: CLASS: } " form." } ;
 
 ARTICLE: "objc-subclassing" "Subclassing Objective C classes"
-"Objective C classes can be subclassed, with new methods defined in Factor, using a parsing word:"
+"Objective C classes can be subclassed, with new methods defined in Factor, using parsing words:"
-{ $subsections POSTPONE: CLASS: }
+{ $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." ;

basis/cocoa/subclassing/subclassing.factor

@@ -1,9 +1,11 @@
-! Copyright (C) 2006, 2008 Slava Pestov, Joe Groff.
+! Copyright (C) 2006, 2010 Slava Pestov, Joe Groff.
 ! See http://factorcode.org/license.txt for BSD license.
-USING: alien alien.c-types alien.strings arrays assocs
+USING: alien alien.c-types alien.parser alien.strings arrays
-combinators compiler hashtables kernel libc math namespaces
+assocs combinators compiler hashtables kernel lexer libc
-parser sequences words cocoa.messages cocoa.runtime locals
+locals.parser locals.types math namespaces parser sequences
-compiler.units io.encodings.utf8 continuations make fry ;
+words cocoa.messages cocoa.runtime locals compiler.units
+io.encodings.utf8 continuations make fry effects stack-checker
+stack-checker.errors ;
 IN: cocoa.subclassing
 
 : init-method ( method -- sel imp types )
@@ -49,13 +51,13 @@ IN: cocoa.subclassing
     ] with-compilation-unit ;
 
 :: (redefine-objc-method) ( class method -- )
-    method init-method [| sel imp types |
+    method init-method :> ( sel imp types )
-        class sel class_getInstanceMethod [
+
-            imp method_setImplementation drop
+    class sel class_getInstanceMethod [
-        ] [
+        imp method_setImplementation drop
-            class sel imp types add-method
+    ] [
-        ] if*
+        class sel imp types add-method
-    ] call ;
+    ] if* ;
     
 : redefine-objc-methods ( imeth name -- )
     dup class-exists? [
@@ -79,3 +81,35 @@ SYMBOL: +superclass+
 SYNTAX: CLASS:
     parse-definition unclip
     >hashtable define-objc-class ;
+
+: (parse-selector) ( -- )
+    scan-token {
+        { [ dup "[" = ] [ drop ] }
+        { [ dup ":" tail? ] [ scan-c-type scan-token 3array , (parse-selector) ] }
+        [ f f 3array , "[" expect ]
+    } cond ;
+
+: parse-selector ( -- selector types names )
+    [ (parse-selector) ] { } make
+    flip first3
+    [ concat ]
+    [ sift { id SEL } prepend ]
+    [ sift { "self" "selector" } prepend ] tri* ;
+
+: parse-method-body ( names -- quot )
+    [ [ make-local ] map ] H{ } make-assoc
+    (parse-lambda) <lambda> ?rewrite-closures first ;
+
+: method-effect ( quadruple -- effect )
+    [ third ] [ second void? { } { "x" } ? ] bi <effect> ;
+
+: check-method ( quadruple -- )
+    [ fourth infer ] [ method-effect ] bi
+    2dup effect<= [ 2drop ] [ effect-error ] if ;
+
+SYNTAX: METHOD:
+    scan-c-type
+    parse-selector
+    parse-method-body [ swap ] 2dip 4array
+    dup check-method
+    suffix! ;

basis/tools/deploy/shaker/strip-cocoa.factor

@@ -13,12 +13,6 @@ IN: tools.deploy.shaker.cocoa
 
 : pool-values ( assoc -- assoc' ) [ pool-array ] assoc-map ;
 
-IN: cocoa.application
-
-: objc-error ( error -- ) die ;
-
-[ [ die ] 19 set-special-object ] "cocoa.application" add-startup-hook
-
 H{ } clone \ pool [
     global [
         ! Only keeps those methods that we actually call

basis/tools/deploy/test/14/14.factor

@@ -9,16 +9,13 @@ IN: tools.deploy.test.14
 CLASS: {
     { +superclass+ "NSObject" }
     { +name+ "Bar" }
-} {
+}
-    "bar:"
+
-    float
+METHOD: float bar: NSRect rect [
-    { id SEL NSRect }
+    rect origin>> [ x>> ] [ y>> ] bi +
-    [
+    rect size>> [ w>> ] [ h>> ] bi +
-        [ origin>> [ x>> ] [ y>> ] bi + ]
+    +
-        [ size>> [ w>> ] [ h>> ] bi + ]
+] ;
-        bi +
-    ]
-} ;
 
 : main ( -- )
     Bar -> alloc -> init

basis/ui/backend/cocoa/cocoa.factor

@@ -233,9 +233,7 @@ CLASS: {
     { +name+ "FactorApplicationDelegate" }
 }
 
-{ "applicationDidUpdate:" void { id SEL id }
+METHOD: void applicationDidUpdate: id obj [ reset-run-loop ] ;
-    [ 3drop reset-run-loop ]
-} ;
 
 : install-app-delegate ( -- )
     NSApp FactorApplicationDelegate install-delegate ;

basis/ui/backend/cocoa/tools/tools.factor

@@ -26,45 +26,25 @@ CLASS: {
     { +name+ "FactorWorkspaceApplicationDelegate" }
 }
 
-{ "application:openFiles:" void { id SEL id id }
+METHOD: void application: id app openFiles: id files [ files finder-run-files ]
-    [ [ 3drop ] dip finder-run-files ]
-}
 
-{ "applicationShouldHandleReopen:hasVisibleWindows:" int { id SEL id int }
+METHOD: int applicationShouldHandleReopen: id app hasVisibleWindows: int flag [ flag 0 = [ show-listener ] when 1 ]
-    [ [ 3drop ] dip 0 = [ show-listener ] when 1 ]
-}
 
-{ "factorListener:" id { id SEL id }
+METHOD: id factorListener: id app [ show-listener f ]
-    [ 3drop show-listener f ]
-}
 
-{ "factorBrowser:" id { id SEL id }
+METHOD: id factorBrowser: id app [ show-browser f ]
-    [ 3drop show-browser f ]
-}
 
-{ "newFactorListener:" id { id SEL id }
+METHOD: id newFactorListener: id app [ listener-window f ]
-    [ 3drop listener-window f ]
-}
 
-{ "newFactorBrowser:" id { id SEL id }
+METHOD: id newFactorBrowser: id app [ browser-window f ]
-    [ 3drop browser-window f ]
-}
 
-{ "runFactorFile:" id { id SEL id }
+METHOD: id runFactorFile: id app [ menu-run-files f ]
-    [ 3drop menu-run-files f ]
-}
 
-{ "saveFactorImage:" id { id SEL id }
+METHOD: id saveFactorImage: id app [ save f ]
-    [ 3drop save f ]
-}
 
-{ "saveFactorImageAs:" id { id SEL id }
+METHOD: id saveFactorImageAs: id app [ menu-save-image f ]
-    [ 3drop menu-save-image f ]
-}
 
-{ "refreshAll:" id { id SEL id }
+METHOD: id refreshAll: id app [ [ refresh-all ] \ refresh-all call-listener f ] ;
-    [ 3drop [ refresh-all ] \ refresh-all call-listener f ]
-} ;
 
 : install-app-delegate ( -- )
     NSApp FactorWorkspaceApplicationDelegate install-delegate ;
@@ -78,25 +58,16 @@ CLASS: {
 CLASS: {
     { +superclass+ "NSObject" }
     { +name+ "FactorServiceProvider" }
-} {
+}
-    "evalInListener:userData:error:"
+
-    void
+METHOD: void evalInListener: id pboard userData: id userData error: id error
-    { id SEL id id id }
+[ pboard error [ eval-listener f ] do-service ]
-    [
+
-        nip
+METHOD: void evalToString: id pboard userData: id userData error: id error
-        [ eval-listener f ] do-service
+[
-        2drop
+    pboard error
-    ]
+    [ [ (eval>string) ] with-interactive-vocabs ] do-service
-} {
+] ;
-    "evalToString:userData:error:"
-    void
-    { id SEL id id id }
-    [
-        nip
-        [ [ (eval>string) ] with-interactive-vocabs ] do-service
-        2drop
-    ]
-} ;
 
 : register-services ( -- )
     NSApp

basis/ui/backend/cocoa/views/views.factor

@@ -148,269 +148,168 @@ CLASS: {
 }
 
 ! Rendering
-{ "drawRect:" void { id SEL NSRect }
+METHOD: void drawRect: NSRect rect [ self window draw-world ]
-    [ 2drop window draw-world ]
-}
 
 ! Events
-{ "acceptsFirstMouse:" char { id SEL id }
+METHOD: char acceptsFirstMouse: id event [ 1 ]
-    [ 3drop 1 ]
-}
 
-{ "mouseEntered:" void { id SEL id }
+METHOD: void mouseEntered: id event [ self event send-mouse-moved ]
-    [ nip send-mouse-moved ]
-}
 
-{ "mouseExited:" void { id SEL id }
+METHOD: void mouseExited: id event [ forget-rollover ]
-    [ 3drop forget-rollover ]
-}
 
-{ "mouseMoved:" void { id SEL id }
+METHOD: void mouseMoved: id event [ self event send-mouse-moved ]
-    [ nip send-mouse-moved ]
-}
 
-{ "mouseDragged:" void { id SEL id }
+METHOD: void mouseDragged: id event [ self event send-mouse-moved ]
-    [ nip send-mouse-moved ]
-}
 
-{ "rightMouseDragged:" void { id SEL id }
+METHOD: void rightMouseDragged: id event [ self event send-mouse-moved ]
-    [ nip send-mouse-moved ]
-}
 
-{ "otherMouseDragged:" void { id SEL id }
+METHOD: void otherMouseDragged: id event [ self event send-mouse-moved ]
-    [ nip send-mouse-moved ]
-}
 
-{ "mouseDown:" void { id SEL id }
+METHOD: void mouseDown: id event [ self event send-button-down$ ]
-    [ nip send-button-down$ ]
-}
 
-{ "mouseUp:" void { id SEL id }
+METHOD: void mouseUp: id event [ self event send-button-up$ ]
-    [ nip send-button-up$ ]
-}
 
-{ "rightMouseDown:" void { id SEL id }
+METHOD: void rightMouseDown: id event [ self event send-button-down$ ]
-    [ nip send-button-down$ ]
-}
 
-{ "rightMouseUp:" void { id SEL id }
+METHOD: void rightMouseUp: id event [ self event send-button-up$ ]
-    [ nip send-button-up$ ]
-}
 
-{ "otherMouseDown:" void { id SEL id }
+METHOD: void otherMouseDown: id event [ self event send-button-down$ ]
-    [ nip send-button-down$ ]
-}
 
-{ "otherMouseUp:" void { id SEL id }
+METHOD: void otherMouseUp: id event [ self event send-button-up$ ]
-    [ nip send-button-up$ ]
-}
 
-{ "scrollWheel:" void { id SEL id }
+METHOD: void scrollWheel: id event [ self event send-scroll$ ]
-    [ nip send-scroll$ ]
-}
 
-{ "keyDown:" void { id SEL id }
+METHOD: void keyDown: id event [ self event send-key-down-event ]
-    [ nip send-key-down-event ]
-}
 
-{ "keyUp:" void { id SEL id }
+METHOD: void keyUp: id event [ self event send-key-up-event ]
-    [ nip send-key-up-event ]
-}
 
-{ "validateUserInterfaceItem:" char { id SEL id }
+METHOD: char validateUserInterfaceItem: id event
-    [
+[
-        nip -> action
+    self window
-        2dup [ window ] [ utf8 alien>string ] bi* validate-action
+    event -> action utf8 alien>string validate-action
-        [ [ 2drop ] dip >c-bool ] [ SUPER-> validateUserInterfaceItem: ] if
+    [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
-    ]
+]
-}
 
-{ "undo:" id { id SEL id }
+METHOD: id undo: id event [ self event undo-action send-action$ ]
-    [ nip undo-action send-action$ ]
-}
 
-{ "redo:" id { id SEL id }
+METHOD: id redo: id event [ self event redo-action send-action$ ]
-    [ nip redo-action send-action$ ]
-}
 
-{ "cut:" id { id SEL id }
+METHOD: id cut: id event [ self event cut-action send-action$ ]
-    [ nip cut-action send-action$ ]
-}
 
-{ "copy:" id { id SEL id }
+METHOD: id copy: id event [ self event copy-action send-action$ ]
-    [ nip copy-action send-action$ ]
-}
 
-{ "paste:" id { id SEL id }
+METHOD: id paste: id event [ self event paste-action send-action$ ]
-    [ nip paste-action send-action$ ]
-}
 
-{ "delete:" id { id SEL id }
+METHOD: id delete: id event [ self event delete-action send-action$ ]
-    [ nip delete-action send-action$ ]
-}
 
-{ "selectAll:" id { id SEL id }
+METHOD: id selectAll: id event [ self event select-all-action send-action$ ]
-    [ nip select-all-action send-action$ ]
-}
 
-{ "newDocument:" id { id SEL id }
+METHOD: id newDocument: id event [ self event new-action send-action$ ]
-    [ nip new-action send-action$ ]
-}
 
-{ "openDocument:" id { id SEL id }
+METHOD: id openDocument: id event [ self event open-action send-action$ ]
-    [ nip open-action send-action$ ]
-}
 
-{ "saveDocument:" id { id SEL id }
+METHOD: id saveDocument: id event [ self event save-action send-action$ ]
-    [ nip save-action send-action$ ]
-}
 
-{ "saveDocumentAs:" id { id SEL id }
+METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ ]
-    [ nip save-as-action send-action$ ]
-}
 
-{ "revertDocumentToSaved:" id { id SEL id }
+METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ ]
-    [ nip revert-action send-action$ ]
-}
 
-! Multi-touch gestures: this is undocumented.
+! Multi-touch gestures
-! http://cocoadex.com/2008/02/nsevent-modifications-swipe-ro.html
+METHOD: void magnifyWithEvent: id event
-{ "magnifyWithEvent:" void { id SEL id }
+[
-    [
+    self event
-        nip
+    dup -> deltaZ sgn {
-        dup -> deltaZ sgn {
+        {  1 [ zoom-in-action send-action$ drop ] }
-            {  1 [ zoom-in-action send-action$ ] }
+        { -1 [ zoom-out-action send-action$ drop ] }
-            { -1 [ zoom-out-action send-action$ ] }
+        {  0 [ 2drop ] }
-            {  0 [ 2drop ] }
+    } case
-        } case
+]
-    ]
-}
 
-{ "swipeWithEvent:" void { id SEL id }
+METHOD: void swipeWithEvent: id event
-    [
+[
-        nip
+    self event
-        dup -> deltaX sgn {
+    dup -> deltaX sgn {
-            {  1 [ left-action send-action$ ] }
+        {  1 [ left-action send-action$ drop ] }
-            { -1 [ right-action send-action$ ] }
+        { -1 [ right-action send-action$ drop ] }
-            {  0
+        {  0
-                [
+            [
-                    dup -> deltaY sgn {
+                dup -> deltaY sgn {
-                        {  1 [ up-action send-action$ ] }
+                    {  1 [ up-action send-action$ drop ] }
-                        { -1 [ down-action send-action$ ] }
+                    { -1 [ down-action send-action$ drop ] }
-                        {  0 [ 2drop ] }
+                    {  0 [ 2drop ] }
-                    } case
+                } case
-                ]
+            ]
-            }
+        }
-        } case
+    } case
-    ]
+]
-}
 
-{ "acceptsFirstResponder" char { id SEL }
+METHOD: char acceptsFirstResponder [ 1 ]
-    [ 2drop 1 ]
-}
 
 ! Services
-{ "validRequestorForSendType:returnType:" id { id SEL id id }
+METHOD: id validRequestorForSendType: id sendType returnType: id returnType
-    [
+[
-        ! We return either self or nil
+    ! We return either self or nil
-        [ over window-focus ] 2dip
+    self window world-focus sendType returnType
-        valid-service? [ drop ] [ 2drop f ] if
+    valid-service? [ self ] [ f ] if
-    ]
+]
-}
 
-{ "writeSelectionToPasteboard:types:" char { id SEL id id }
+METHOD: char writeSelectionToPasteboard: id pboard types: id types
-    [
+[
-        CF>string-array NSStringPboardType swap member? [
+    NSStringPboardType types CF>string-array member? [
-            [ drop window-focus gadget-selection ] dip over
+        self window world-focus gadget-selection
-            [ set-pasteboard-string 1 ] [ 2drop 0 ] if
+        [ pboard set-pasteboard-string 1 ] [ 0 ] if*
-        ] [ 3drop 0 ] if
+    ] [ 0 ] if
-    ]
+]
-}
 
-{ "readSelectionFromPasteboard:" char { id SEL id }
+METHOD: char readSelectionFromPasteboard: id pboard
-    [
+[
-        pasteboard-string dup [
+    pboard pasteboard-string
-            [ drop window ] dip swap user-input 1
+    [ self window user-input 1 ] [ 0 ] if*
-        ] [ 3drop 0 ] if
+]
-    ]
-}
 
 ! Text input
-{ "insertText:" void { id SEL id }
+METHOD: void insertText: id text
-    [ nip CF>string swap window user-input ]
+[ text CF>string self window user-input ]
-}
 
-{ "hasMarkedText" char { id SEL }
+METHOD: char hasMarkedText [ 0 ]
-    [ 2drop 0 ]
-}
 
-{ "markedRange" NSRange { id SEL }
+METHOD: NSRange markedRange [ 0 0 <NSRange> ]
-    [ 2drop 0 0 <NSRange> ]
-}
 
-{ "selectedRange" NSRange { id SEL }
+METHOD: NSRange selectedRange [ 0 0 <NSRange> ]
-    [ 2drop 0 0 <NSRange> ]
-}
 
-{ "setMarkedText:selectedRange:" void { id SEL id NSRange }
+METHOD: void setMarkedText: id text selectedRange: NSRange range [ ]
-    [ 2drop 2drop ]
-}
 
-{ "unmarkText" void { id SEL }
+METHOD: void unmarkText [ ]
-    [ 2drop ]
-}
 
-{ "validAttributesForMarkedText" id { id SEL }
+METHOD: id validAttributesForMarkedText [ NSArray -> array ]
-    [ 2drop NSArray -> array ]
-}
 
-{ "attributedSubstringFromRange:" id { id SEL NSRange }
+METHOD: id attributedSubstringFromRange: NSRange range [ f ]
-    [ 3drop f ]
-}
 
-{ "characterIndexForPoint:" NSUInteger { id SEL NSPoint }
+METHOD: NSUInteger characterIndexForPoint: NSPoint point [ 0 ]
-    [ 3drop 0 ]
-}
 
-{ "firstRectForCharacterRange:" NSRect { id SEL NSRange }
+METHOD: NSRect firstRectForCharacterRange: NSRange range [ 0 0 0 0 <CGRect> ]
-    [ 3drop 0 0 0 0 <CGRect> ]
-}
 
-{ "conversationIdentifier" NSInteger { id SEL }
+METHOD: NSInteger conversationIdentifier [ self alien-address ]
-    [ drop alien-address ]
-}
 
 ! Initialization
-{ "updateFactorGadgetSize:" void { id SEL id }
+METHOD: void updateFactorGadgetSize: id notification
-    [ 2drop [ window ] [ view-dim ] bi >>dim drop yield ]
+[ self view-dim self window dim<< yield ]
-}
 
-{ "doCommandBySelector:" void { id SEL SEL }
+METHOD: void doCommandBySelector: SEL selector [ ]
-    [ 3drop ]
-}
 
-{ "initWithFrame:pixelFormat:" id { id SEL NSRect id }
+METHOD: id initWithFrame: NSRect frame pixelFormat: id pixelFormat
-    [
+[
-        [ drop ] 2dip
+    self frame pixelFormat SUPER-> initWithFrame:pixelFormat:
-        SUPER-> initWithFrame:pixelFormat:
+    dup dup add-resize-observer
-        dup dup add-resize-observer
+]
-    ]
-}
 
-{ "isOpaque" char { id SEL }
+METHOD: char isOpaque [ 0 ]
-    [
-        2drop 0
-    ]
-}
 
-{ "dealloc" void { id SEL }
+METHOD: void dealloc
-    [
+[
-        drop
+    self remove-observer
-        [ remove-observer ]
+    self SUPER-> dealloc
-        [ SUPER-> dealloc ]
+] ;
-        bi
-    ]
-} ;
 
 : sync-refresh-to-screen ( GLView -- )
     -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
@@ -423,44 +322,37 @@ CLASS: {
     -> frame CGRect-top-left 2array >>window-loc drop ;
 
 CLASS: {
-    { +superclass+ "NSObject" }
     { +name+ "FactorWindowDelegate" }
+    { +superclass+ "NSObject" }
 }
 
-{ "windowDidMove:" void { id SEL id }
+METHOD: void windowDidMove: id notification
-    [
+[
-        2nip -> object [ -> contentView window ] keep save-position
+    notification -> object -> contentView window
-    ]
+    notification -> object save-position
-}
+]
 
-{ "windowDidBecomeKey:" void { id SEL id }
+METHOD: void windowDidBecomeKey: id notification
-    [
+[
-        2nip -> object -> contentView window focus-world
+    notification -> object -> contentView window
-    ]
+    focus-world
-}
+]
 
-{ "windowDidResignKey:" void { id SEL id }
+METHOD: void windowDidResignKey: id notification
-    [
+[
-        forget-rollover
+    forget-rollover
-        2nip -> object -> contentView
+    notification -> object -> contentView
-        dup -> isInFullScreenMode 0 =
+    dup -> isInFullScreenMode 0 =
-        [ window [ unfocus-world ] when* ]
+    [ window [ unfocus-world ] when* ] [ drop ] if
-        [ drop ] if
+]
-    ]
-}
 
-{ "windowShouldClose:" char { id SEL id }
+METHOD: char windowShouldClose: id notification [ 1 ]
-    [
-        3drop 1
-    ]
-}
 
-{ "windowWillClose:" void { id SEL id }
+METHOD: void windowWillClose: id notification
-    [
+[
-        2nip -> object -> contentView
+    notification -> object -> contentView
-        [ window ungraft ] [ unregister-window ] bi
+    [ window ungraft ] [ unregister-window ] bi
-    ]
+] ;
-} ;
 
 : install-window-delegate ( window -- )
     FactorWindowDelegate install-delegate ;

basis/ui/ui.factor

@@ -16,8 +16,6 @@ SYMBOL: windows
 
 : window ( handle -- world ) windows get-global at ;
 
-: window-focus ( handle -- gadget ) window world-focus ;
-
 : register-window ( world handle -- )
     #! Add the new window just below the topmost window. Why?
     #! So that if the new window doesn't actually receive focus