Services client support (untested)

TODO.FACTOR.txt

@@ -39,7 +39,6 @@
   - offer to remove generic words which are not called and have no
     methods
 - forgetting a tuple class should forget the constructor
-- seeing a tuple class should show the constructor
 - see by itself only shows the G: def
 - { class generic } see supports forms:
   { f generic } to show all methods

library/ui/cocoa/view-utils.factor

@@ -62,11 +62,11 @@ opengl sequences ;
     dup -> modifierFlags modifiers modifier swap key-code ;
 
 : send-key-event ( view event quot -- ? )
-    >r event>gesture r> call swap window world-focus
+    >r event>gesture r> call swap window-focus
     handle-gesture ; inline
 
 : send-user-input ( view event -- )
-    -> characters CF>string swap window world-focus user-input ;
+    -> characters CF>string swap window-focus user-input ;
 
 : send-key-down-event ( view event -- )
     2dup [ <key-down> ] send-key-event
@@ -93,7 +93,18 @@ opengl sequences ;
     "NSViewFrameDidChangeNotification" <NSString>
     r> add-observer ;
 
+: string-or-nil? ( NSString -- ? )
+    [ dup CF>string NSStringPboardType = ] [ t ] if* ;
+
+: valid-service? ( gadget send-type return-type -- ? )
+    over string-or-nil? over string-or-nil? and [
+        drop [ swap gadget-selection? ] [ 2drop t ] if
+    ] [
+        3drop f
+    ] if ;
+
 "NSOpenGLView" "FactorView" {
+    ! Events
     { "acceptsFirstMouse:" "bool" { "id" "SEL" "id" }
         [ 3drop 1 ]
     }
@@ -178,6 +189,35 @@ opengl sequences ;
         [ [ nip T{ select-all-action } send-action$ ] ui-try ]
     }
 
+    ! Services
+    { "validRequestorForSendType:returnType:" "id" { "id" "SEL" "id" "id" }
+        [
+            ! We return either self or nil
+            >r >r over window-focus r> r>
+            valid-service? [ drop ] [ 2drop f ] if
+        ]
+    }
+
+    { "writeSelectionToPasteboard:types:" "bool" { "id" "SEL" "id" "id" }
+        CF>string-array NSStringPboardType swap member? [
+            >r drop window-focus gadget-selection dup [
+                r> set-pasteboard-string t
+            ] [
+                r> 2drop f
+            ] if
+        ] [
+            3drop f
+        ] if
+    }
+
+    { "readSelectionFromPasteboard:" "bool" { "id" "SEL" "id" }
+        pasteboard-string dup [
+            >r drop window-focus r> swap user-input t
+        ] [
+            3drop f
+        ] if
+    }
+
     { "updateFactorGadgetSize:" "void" { "id" "SEL" "id" }
         [
             [

library/ui/gadgets.factor

@@ -108,3 +108,12 @@ M: gadget gadget-help drop f ;
 GENERIC: gadget-title ( gadget -- string )
 
 M: gadget gadget-title drop "Factor" <model> ;
+
+! Selection protocol
+GENERIC: gadget-selection? ( gadget -- ? )
+
+M: gadget gadget-selection? drop f ;
+
+GENERIC: gadget-selection ( gadget -- string/f )
+
+M: gadget gadget-selection drop f ;

library/ui/ui.factor

@@ -11,6 +11,8 @@ SYMBOL: windows
 
 : window ( handle -- world ) windows get-global assoc ;
 
+: window-focus ( handle -- gadget ) window world-focus ;
+
 : register-window ( world handle -- )
     swap 2array windows get-global push ;
 

library/ui/windows/ui.factor

@@ -112,26 +112,24 @@ SYMBOL: wParam
 SYMBOL: uMsg
 SYMBOL: hWnd
 
-: get-focus ( hWnd -- gadget )
-    window world-focus ;
-
 : handle-wm-keydown ( hWnd uMsg wParam lParam -- )
     lParam set wParam set uMsg set hWnd set
     wParam get exclude-key-wm-keydown? [
         wParam get keystroke>gesture <key-down>
-        hWnd get get-focus handle-gesture drop 
+        hWnd get window-focus handle-gesture drop 
     ] unless ;
 
 : handle-wm-char ( hWnd uMsg wParam lParam -- )
     lParam set wParam set uMsg set hWnd set
     wParam get exclude-key-wm-char? ctrl? or [
         wParam get ch>string
-        hWnd get get-focus user-input
+        hWnd get window-focus user-input
     ] unless ;
 
 : handle-wm-keyup ( hWnd uMsg wParam lParam -- )
     lParam set wParam set uMsg set hWnd set
-    wParam get keystroke>gesture <key-up> hWnd get get-focus handle-gesture
+    wParam get keystroke>gesture <key-up>
+    hWnd get window-focus handle-gesture
     drop ;
 
 : cleanup-window ( handle -- )