wayland: Set framebuffer scale when creating an OpenGL context

Author: lexi-lambda

gui-lib/mred/private/wx/gtk/gl-context.rkt

@@ -422,7 +422,8 @@
 
     (define/public (gl-update-size x y w h)
       (when win
-	(wl_egl_window_resize win w h 0 0)
+	(define scale (if widget (gtk_widget_get_scale_factor widget) 1))
+	(wl_egl_window_resize win (* scale w) (* scale h) 0 0)
 	(when (and widget wl-subsurface)
 	  (define toplevel (gtk_widget_get_toplevel widget))
 	  (define-values (dx dy)
@@ -702,10 +703,11 @@
 				     (error 'EGL "subcompositor failed")))
 
 	(define (create recreate?)
+	  (define scale (gtk_widget_get_scale_factor widget))
 	  (define-values (width height)
 	    (let ([a (widget-allocation widget)])
-	      (values (GtkAllocation-width a)
-		      (GtkAllocation-height a))))
+              (values (* scale (GtkAllocation-width a))
+                      (* scale (GtkAllocation-height a)))))
 
 	  (define wl-surface/sub (or (wayland-compositor-create-surface wl-compositor)
 				     (error 'EGL "subsurface create failed")))
@@ -728,6 +730,7 @@
 	      (wayland-region-destroy region))
 	    (wayland-subsurface-set-position wl-subsurface dx dy)
 	    (wayland-subsurface-set-sync wl-subsurface #f)
+	    (wayland-surface-set-buffer-scale wl-surface/sub scale)
 	    (wayland-surface-commit wl-surface/sub)
 	    (wayland-surface-commit wl-surface))
 

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

@@ -12,6 +12,7 @@
 	 wayland-subsurface-set-position
 	 wayland-subsurface-set-sync
 	 wayland-surface-commit
+         wayland-surface-set-buffer-scale
 	 wayland-surface-destroy
 	 wayland-roundtrip
 	 wayland-display-dispatch-pending
@@ -62,6 +63,7 @@
 (define WL_SURFACE_FRAME 3)
 (define WL_SURFACE_SET_INPUT_REGION 5)
 (define WL_SURFACE_COMMIT 6)
+(define WL_SURFACE_SET_BUFFER_SCALE 8)
 (define WL_REGION_DESTROY 0)
 
 (define _registry (_cpointer/null 'wl_registry))
@@ -132,6 +134,14 @@
 	-> _pointer
 	-> (void))
   #:c-id wl_proxy_marshal_flags)
+(define-wayland wl_proxy_marshal_flags/wl_surface_set_buffer_scale
+  (_fun #:varargs-after 5
+	_pointer _uint32 _pointer _uint32
+	_uint32
+	_int32
+	-> _pointer
+	-> (void))
+  #:c-id wl_proxy_marshal_flags)
 (define-wayland wl_proxy_marshal_flags/wl_surface_<object>
   (_fun #:varargs-after 5
 	_pointer _uint32 _pointer _uint32
@@ -226,6 +236,14 @@
    #f (wl_proxy_get_version surface)
    0))
 
+(define (wayland-surface-set-buffer-scale surface scale)
+  (wl_proxy_marshal_flags/wl_surface_set_buffer_scale
+   surface
+   WL_SURFACE_SET_BUFFER_SCALE
+   #f (wl_proxy_get_version surface)
+   0
+   scale))
+
 (define (wayland-surface-destroy surface)
   (wl_proxy_marshal_flags/wl_<object>_destroy
    surface