cocoa.subclassing: cleaner CLASS: syntax; ui.backend.cocoa: ignore events delivered after window closed to fix FEP (reported by Doug Coleman)

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: {
+CLASS: Foo < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "Foo" }
-}
-
     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: {
+CLASS: Bar < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "Bar" }
+    METHOD: NSRect bar [ test-foo "x" get ]
-}
+]
-
-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: {
+CLASS: Bar < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "Bar" }
-}
-
     METHOD: NSRect bar [ test-foo "x" get ]
 
-METHOD: int babb: int x [ x sq ] ;
+    METHOD: int babb: int x [ x sq ]
+]
 
 [ 144 ] [
     Bar [

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... ;" }
+{ $syntax "CLASS: name < superclass protocols... [ imeth... ]" }
-{ $values { "spec" "an array of pairs" } { "name" "a new class name" } { "imeth" "instance method definitions using " { $link POSTPONE: METHOD: } } }
+{ $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. The hashtable can contain the following keys:"
+{ $description "Defines a new Objective C class. Instance methods are defined with the " { $link POSTPONE: METHOD: } " parsing word."
-{ $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." } ;
 
@@ -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

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+
+:: define-objc-class ( name superclass protocols methods -- )
-SYMBOL: +protocols+
+    methods prepare-methods :> methods
-SYMBOL: +superclass+
+    name "cocoa.classes" create drop
-
+    methods name redefine-objc-methods
-: define-objc-class ( imeth hash -- )
+    name [ methods protocols superclass name (define-objc-class) ] import-objc-class ;
-    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 ;
 
 SYNTAX: CLASS:
-    parse-definition unclip
+    scan-token
-    >hashtable define-objc-class ;
+    "<" expect
+    scan-token
+    "[" parse-tokens
+    \ ] parse-until define-objc-class ;
 
 : (parse-selector) ( -- )
     scan-token {

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

@@ -6,16 +6,14 @@ kernel math ;
 FROM: alien.c-types => float ;
 IN: tools.deploy.test.14
 
-CLASS: {
+CLASS: Bar < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "Bar" }
-}
-
     METHOD: float bar: NSRect rect [
         rect origin>> [ x>> ] [ y>> ] bi +
         rect size>> [ w>> ] [ h>> ] bi +
         +
-] ;
+    ]
+]
 
 : main ( -- )
     Bar -> alloc -> init

basis/ui/backend/cocoa/cocoa.factor

@@ -228,12 +228,11 @@ M: cocoa-ui-backend system-alert
     ] [ 2drop ] if*
     init-thread-timer ;
 
-CLASS: {
+CLASS: FactorApplicationDelegate < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "FactorApplicationDelegate" }
+    METHOD: void applicationDidUpdate: id obj
-}
+    [ reset-run-loop ]
-
+]
-METHOD: void applicationDidUpdate: id obj [ reset-run-loop ] ;
 
 : install-app-delegate ( -- )
     NSApp FactorApplicationDelegate install-delegate ;

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

@@ -21,11 +21,8 @@ IN: ui.backend.cocoa.tools
     image save-panel [ save-image ] when* ;
 
 ! Handle Open events from the Finder
-CLASS: {
+CLASS: FactorWorkspaceApplicationDelegate < FactorApplicationDelegate
-    { +superclass+ "FactorApplicationDelegate" }
+[
-    { +name+ "FactorWorkspaceApplicationDelegate" }
-}
-
     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 ]
@@ -44,7 +41,8 @@ METHOD: id saveFactorImage: id app [ save 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,11 +53,8 @@ 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: {
+CLASS: FactorServiceProvider < NSObject
-    { +superclass+ "NSObject" }
+[
-    { +name+ "FactorServiceProvider" }
-}
-
     METHOD: void evalInListener: id pboard userData: id userData error: id error
     [ pboard error [ eval-listener f ] do-service ]
 
@@ -67,7 +62,8 @@ METHOD: void evalToString: id pboard userData: id userData error: id error
     [
         pboard error
         [ [ (eval>string) ] with-interactive-vocabs ] do-service
-] ;
+    ]
+]
 
 : register-services ( -- )
     NSApp

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
+cocoa.runtime cocoa.types cocoa.windows sequences
-ui ui.private ui.gadgets ui.gadgets.private ui.gadgets.worlds ui.gestures
+io.encodings.utf8 locals ui ui.private ui.gadgets
-core-foundation.strings core-graphics core-graphics.types threads
+ui.gadgets.private ui.gadgets.worlds ui.gestures
-combinators math.rectangles ;
+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 )
+: send-action$ ( view event gesture -- )
-    [ drop window ] dip send-action f ;
+    [ drop window ] dip over [ send-action ] [ 2drop ] if ;
 
 : add-resize-observer ( observer object -- )
     [
@@ -141,14 +146,10 @@ CONSTANT: selector>action H{
     selector>action at
     [ swap world-focus parents-handle-gesture? t ] [ drop f f ] if* ;
 
-CLASS: {
+CLASS: FactorView < NSOpenGLView NSTextInput
-    { +superclass+ "NSOpenGLView" }
+[
-    { +name+ "FactorView" }
-    { +protocols+ { "NSTextInput" } }
-}
-
     ! Rendering
-METHOD: void drawRect: NSRect rect [ self window draw-world ]
+    METHOD: void drawRect: NSRect rect [ self window [ draw-world ] when* ]
 
     ! Events
     METHOD: char acceptsFirstMouse: id event [ 1 ]
@@ -185,42 +186,43 @@ METHOD: void keyUp: id event [ self event send-key-up-event ]
 
     METHOD: char validateUserInterfaceItem: id event
     [
-    self window
+        self window [
             event -> action utf8 alien>string validate-action
             [ >c-bool ] [ drop self event SUPER-> validateUserInterfaceItem: ] if
+        ] [ 0 ] if*
     ]
 
-METHOD: id undo: id event [ self event undo-action send-action$ ]
+    METHOD: id undo: id event [ self event undo-action send-action$ f ]
 
-METHOD: id redo: id event [ self event redo-action send-action$ ]
+    METHOD: id redo: id event [ self event redo-action send-action$ f ]
 
-METHOD: id cut: id event [ self event cut-action send-action$ ]
+    METHOD: id cut: id event [ self event cut-action send-action$ f ]
 
-METHOD: id copy: id event [ self event copy-action send-action$ ]
+    METHOD: id copy: id event [ self event copy-action send-action$ f ]
 
-METHOD: id paste: id event [ self event paste-action send-action$ ]
+    METHOD: id paste: id event [ self event paste-action send-action$ f ]
 
-METHOD: id delete: id event [ self event delete-action send-action$ ]
+    METHOD: id delete: id event [ self event delete-action send-action$ f ]
 
-METHOD: id selectAll: id event [ self event select-all-action send-action$ ]
+    METHOD: id selectAll: id event [ self event select-all-action send-action$ f ]
 
-METHOD: id newDocument: id event [ self event new-action send-action$ ]
+    METHOD: id newDocument: id event [ self event new-action send-action$ f ]
 
-METHOD: id openDocument: id event [ self event open-action send-action$ ]
+    METHOD: id openDocument: id event [ self event open-action send-action$ f ]
 
-METHOD: id saveDocument: id event [ self event save-action send-action$ ]
+    METHOD: id saveDocument: id event [ self event save-action send-action$ f ]
 
-METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ ]
+    METHOD: id saveDocumentAs: id event [ self event save-as-action send-action$ f ]
 
-METHOD: id revertDocumentToSaved: id event [ self event revert-action send-action$ ]
+    METHOD: id revertDocumentToSaved: id event [ self event revert-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-in-action send-action$ ] }
-        { -1 [ zoom-out-action send-action$ drop ] }
+            { -1 [ zoom-out-action send-action$ ] }
             {  0 [ 2drop ] }
         } case
     ]
@@ -229,13 +231,13 @@ METHOD: void swipeWithEvent: id event
     [
         self event
         dup -> deltaX sgn {
-        {  1 [ left-action send-action$ drop ] }
+            {  1 [ left-action send-action$ ] }
-        { -1 [ right-action send-action$ drop ] }
+            { -1 [ right-action send-action$ ] }
             {  0
                 [
                     dup -> deltaY sgn {
-                    {  1 [ up-action send-action$ drop ] }
+                        {  1 [ up-action send-action$ ] }
-                    { -1 [ down-action send-action$ drop ] }
+                        { -1 [ down-action send-action$ ] }
                         {  0 [ 2drop ] }
                     } case
                 ]
@@ -249,27 +251,39 @@ METHOD: char acceptsFirstResponder [ 1 ]
     METHOD: id validRequestorForSendType: id sendType returnType: id returnType
     [
         ! We return either self or nil
-    self window world-focus sendType returnType
+        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
+            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
-    [ self window user-input 1 ] [ 0 ] if*
+            [ window user-input 1 ] [ 0 ] if*
+        ] [ 0 ] if
     ]
 
     ! Text input
     METHOD: void insertText: id text
-[ text CF>string self window user-input ]
+    [
+        self window :> window
+        window [
+            text CF>string window user-input
+        ] when
+    ]
 
     METHOD: char hasMarkedText [ 0 ]
 
@@ -293,7 +307,12 @@ METHOD: NSInteger conversationIdentifier [ self alien-address ]
 
     ! Initialization
     METHOD: void updateFactorGadgetSize: id notification
-[ self view-dim self window dim<< yield ]
+    [
+        self window :> window
+        window [
+            self view-dim window dim<< yield
+        ] when
+    ]
 
     METHOD: void doCommandBySelector: SEL selector [ ]
 
@@ -309,7 +328,8 @@ METHOD: void dealloc
     [
         self remove-observer
         self SUPER-> dealloc
-] ;
+    ]
+]
 
 : sync-refresh-to-screen ( GLView -- )
     -> openGLContext -> CGLContextObj NSOpenGLCPSwapInterval 1 <int>
@@ -321,29 +341,29 @@ METHOD: void dealloc
 : save-position ( world window -- )
     -> frame CGRect-top-left 2array >>window-loc drop ;
 
-CLASS: {
+CLASS: FactorWindowDelegate < NSObject
-    { +name+ "FactorWindowDelegate" }
+[
-    { +superclass+ "NSObject" }
-}
-
     METHOD: void windowDidMove: id notification
     [
         notification -> object -> contentView window
-    notification -> object save-position
+        [ notification -> object save-position ] when*
     ]
 
     METHOD: void windowDidBecomeKey: id notification
     [
         notification -> object -> contentView window
-    focus-world
+        [ focus-world ] when*
     ]
 
     METHOD: void windowDidResignKey: id notification
     [
         forget-rollover
-    notification -> object -> contentView
+        notification -> object -> contentView :> view
-    dup -> isInFullScreenMode 0 =
+        view window :> window
-    [ window [ unfocus-world ] when* ] [ drop ] if
+        window [
+            view -> isInFullScreenMode 0 =
+            [ window unfocus-world ] when
+        ] when
     ]
 
     METHOD: char windowShouldClose: id notification [ 1 ]
@@ -352,7 +372,8 @@ METHOD: void windowWillClose: id notification
     [
         notification -> object -> contentView
         [ window ungraft ] [ unregister-window ] bi
-] ;
+    ]
+]
 
 : install-window-delegate ( window -- )
     FactorWindowDelegate install-delegate ;