fix -singleInstance for GTK+3

Closes PR 15240

gui-doc/scribblings/gui/libs.scrbl

@@ -19,5 +19,5 @@ either case:
  @item{@filepath{libgtk-3.0[.0]} (GTK+ 3) or @filepath{libgtk-x11-2.0[.0]} (GTK+ 2)}
  @item{@filepath{libgio-2.0[.0]} --- optional, for detecting interface scaling}
  @item{@filepath{libGL[.1]} --- optional, for OpenGL support}
- @item{@filepath{libunique-1.0[.0]} --- optional, for single-instance support}
+ @item{@filepath{libunique-1.0[.0]} --- optional, for single-instance support (GTK+ 2)}
 ]

gui-lib/mred/private/wx/gtk/unique.rkt

@@ -10,6 +10,9 @@
 (provide 
  (protect-out do-single-instance))
 
+;; ----------------------------------------
+;; Old-style -singleInstance support lith libunqiue
+
 (define unique-lib-name "libunique-1.0")
 
 (define unique-lib
@@ -56,14 +59,90 @@
 					    (exn-message exn))))])
 	(let* ([p (open-input-bytes d)]
 	       [vec (read p)])
-	  (for-each
-	   queue-file-event
-	   (map (lambda (s) (if (bytes? s)
-                                (bytes->path s)
-                                (string->path s)))
-                (vector->list vec))))))
+	  (handle-argv vec))))
     UNIQUE_RESPONSE_OK))
 
+(define (send-command-line app)
+  (let ([msg (unique_message_data_new)]
+        [b (let ([o (open-output-bytes)])
+             (write (for/vector ([p (in-vector (current-command-line-arguments))])
+                      (define cp (path->complete-path p))
+                      (define s (path->string cp))
+                      (if (equal? cp (string->path s))
+                          s
+                          ;; can't represent as string; use bytes
+                          (path->bytes cp)))
+                    o)
+             (get-output-bytes o))])
+    (unique_message_data_set msg b (bytes-length b))
+    (unique_app_send_message app 42 msg)))
+
+(define (do-single-instance/libunique)
+  (let ([app (unique_app_new (build-app-name) #f)])
+    (when app
+      (unique_app_add_command app "startup" 42)
+      (when (unique_app_is_running app)
+        (when (= (send-command-line app)
+                 UNIQUE_RESPONSE_OK)
+          (exit 0)))
+      (void (connect-message-received app)))))
+
+;; ----------------------------------------
+;; New-style -singleInstance support lith Gtk
+
+(define _GtkApplication _GtkWidget) ; (_cpointer/null 'GtkApplication)
+(define _GApplicationCommandLine (_cpointer 'GApplicationCommandLine))
+
+(define-gtk gtk_application_new (_fun _string _int -> _GtkApplication)
+  #:fail (lambda () #f))
+
+(define-gdk g_application_get_is_remote (_fun _GtkApplication -> _gboolean))
+(define-gdk g_application_run (_fun _GtkApplication _int (_vector i _string) -> _gboolean))
+(define-gdk g_application_command_line_get_arguments
+  (_fun _GApplicationCommandLine (n : (_ptr o _int)) -> (p : _pointer) -> (values p n)))
+(define-gdk g_strfreev (_fun _pointer -> _void))
+
+(define-signal-handler connect-activate "activate"
+  (_fun _GtkApplication -> _void)
+  (lambda (app)
+    (void)))
+
+(define-signal-handler connect-command-line "command-line"
+  (_fun _GtkApplication _GApplicationCommandLine -> _void)
+  (lambda (app cmdline)
+    (define-values (args n) (g_application_command_line_get_arguments cmdline))
+    (define argv (cast args _pointer (_vector o _string n)))
+    (g_strfreev args)
+    (handle-argv argv)))
+
+(define APPLICATION_HANDLES_COMMAND_LINE 8)
+
+(define (do-single-instance/gtk)
+  (define app (gtk_application_new (build-app-name) APPLICATION_HANDLES_COMMAND_LINE))
+  (when app
+    (define args (for/vector ([i (current-command-line-arguments)])
+		   (path->string (path->complete-path i))))
+    (g_application_run app (vector-length args) args)
+    (when (g_application_get_is_remote app)
+      (exit 0))
+    (connect-activate app)
+    (connect-command-line app)))
+
+;; ----------------------------------------
+
+(define (do-single-instance)
+  (if gtk_application_new
+      (do-single-instance/gtk)
+      (do-single-instance/libunique)))
+
+(define (handle-argv vec)
+  (for-each
+   queue-file-event
+   (map (lambda (s) (if (bytes? s)
+			(bytes->path s)
+			(string->path s)))
+	(vector->list vec))))
+
 (define-mz gethostname (_fun _pointer _long -> _int)
   #:fail (lambda () #f))
 
@@ -87,28 +166,3 @@
 
 (define (encode s)
   (regexp-replace* #rx"=|\r\n" (base64-encode (string->bytes/utf-8 s)) ""))
-
-(define (send-command-line app)
-  (let ([msg (unique_message_data_new)]
-        [b (let ([o (open-output-bytes)])
-             (write (for/vector ([p (in-vector (current-command-line-arguments))])
-                      (define cp (path->complete-path p))
-                      (define s (path->string cp))
-                      (if (equal? cp (string->path s))
-                          s
-                          ;; can't represent as string; use bytes
-                          (path->bytes cp)))
-                    o)
-             (get-output-bytes o))])
-    (unique_message_data_set msg b (bytes-length b))
-    (unique_app_send_message app 42 msg)))
-
-(define (do-single-instance)
-  (let ([app (unique_app_new (build-app-name) #f)])
-    (when app
-      (unique_app_add_command app "startup" 42)
-      (when (unique_app_is_running app)
-        (when (= (send-command-line app)
-                 UNIQUE_RESPONSE_OK)
-          (exit 0)))
-      (void (connect-message-received app)))))