diff --git a/TODO.FACTOR.txt b/TODO.FACTOR.txt index f0a076836a..cb39752c40 100644 --- a/TODO.FACTOR.txt +++ b/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 diff --git a/library/ui/cocoa/view-utils.factor b/library/ui/cocoa/view-utils.factor index a8ebd70bea..08ce7f3b20 100644 --- a/library/ui/cocoa/view-utils.factor +++ b/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 [ ] send-key-event @@ -93,7 +93,18 @@ opengl sequences ; "NSViewFrameDidChangeNotification" 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" } [ [ diff --git a/library/ui/gadgets.factor b/library/ui/gadgets.factor index 0cd18d68a6..d1340b868c 100644 --- a/library/ui/gadgets.factor +++ b/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" ; + +! Selection protocol +GENERIC: gadget-selection? ( gadget -- ? ) + +M: gadget gadget-selection? drop f ; + +GENERIC: gadget-selection ( gadget -- string/f ) + +M: gadget gadget-selection drop f ; diff --git a/library/ui/ui.factor b/library/ui/ui.factor index 17b8753d99..af16325279 100644 --- a/library/ui/ui.factor +++ b/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 ; diff --git a/library/ui/windows/ui.factor b/library/ui/windows/ui.factor index e9cb34e1d7..63fd1771c8 100644 --- a/library/ui/windows/ui.factor +++ b/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 - 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 hWnd get get-focus handle-gesture + wParam get keystroke>gesture + hWnd get window-focus handle-gesture drop ; : cleanup-window ( handle -- )