#lang racket/base
(require racket/promise
	 ffi/unsafe
         ffi/unsafe/define
         ffi/unsafe/alloc
         racket/string
         racket/draw/unsafe/glib
         (only-in '#%foreign ctype-c->scheme)
	 "gtk3.rkt"
         "../common/utils.rkt"
         "types.rkt"
	 "resolution.rkt")

(provide
 gtk3?
 define-mz
 define-gobj
 define-glib
 (protect-out define-gtk
              define-gdk
              define-gdk_pixbuf

              g_object_ref
              g_object_ref_sink
              g_object_unref

              gobject-ref
              gobject-unref
              as-gobject-allocation

              as-gtk-allocation
              as-gtk-window-allocation
              clean-up-destroyed

              g_free
              _gpath/free
              _GSList
              gfree

              g_object_set_data
              g_object_get_data

              g_object_new

              (rename-out [g_object_get g_object_get_window])

              get-gtk-object-flags
              set-gtk-object-flags!

              define-signal-handler

              gdk_screen_get_default

              ;; for declaring derived structures:
              _GtkObject

	      ;; window size adjustments for screen scale:
	      ->screen ->screen* ->normal)
 mnemonic-string)

(define gdk-lib 
  (case (system-type)
    [(windows)
     (ffi-lib "libatk-1.0-0")
     (ffi-lib "libgio-2.0-0")
     (ffi-lib "libgdk_pixbuf-2.0-0")
     (ffi-lib "libgdk-win32-2.0-0")]
    [else (if gtk3?
	      (get-gdk3-lib)
	      (ffi-lib "libgdk-x11-2.0" '("0" "")))]))
(define gdk_pixbuf-lib 
  (case (system-type)
    [(windows)
     (ffi-lib "libgdk_pixbuf-2.0-0")]
    [(unix)
     (if gtk3?
	 #f
	 (ffi-lib "libgdk_pixbuf-2.0" '("0" "")))]
    [else gdk-lib]))
(define gtk-lib
  (case (system-type)
    [(windows) 
     (ffi-lib "libgtk-win32-2.0-0")]
    [else (if gtk3?
	      (get-gtk3-lib)
	      (ffi-lib "libgtk-x11-2.0" '("0" "")))]))

(define-ffi-definer define-gtk gtk-lib)
(define-ffi-definer define-gdk gdk-lib)
(define-ffi-definer define-gdk_pixbuf gdk_pixbuf-lib)

(define-gobj g_object_ref (_fun _pointer -> _pointer))
(define-gobj g_object_unref (_fun _pointer -> _void))
(define-gobj g_object_ref_sink (_fun _pointer -> _pointer))

(define gobject-unref ((deallocator) g_object_unref))
(define gobject-ref ((allocator gobject-unref) g_object_ref))

(define-syntax-rule (as-gobject-allocation expr)
  ((gobject-allocator (lambda () expr))))

(define gobject-allocator (allocator gobject-unref))

(define-gtk gtk_widget_destroy (_fun _GtkWidget -> _void))

(define gtk-destroy ((deallocator) (lambda (v)
                                     (gtk_widget_destroy v)
                                     (g_object_unref v))))

(define gtk-allocator (allocator remember-to-free-later))
(define (clean-up-destroyed)
  (free-remembered-now gtk-destroy))

(define-syntax-rule (as-gtk-allocation expr)
  ((gtk-allocator (lambda () (let ([v expr])
                               (g_object_ref_sink v)
                               v)))))
(define-syntax-rule (as-gtk-window-allocation expr)
  ((gtk-allocator (lambda () (let ([v expr])
                               (g_object_ref v)
                               v)))))

(define-glib g_free (_fun _pointer -> _void))
(define gfree ((deallocator) g_free))

(define-gobj g_object_set_data (_fun _GtkWidget _string _pointer -> _void))
(define-gobj g_object_get_data (_fun _GtkWidget _string -> _pointer))

(define-gobj g_signal_connect_data (_fun _gpointer _string _fpointer _pointer _fnpointer _int -> _ulong))
(define G_CONNECT_AFTER 1)
(define (g_signal_connect obj s proc user-data after?)
  (g_signal_connect_data obj s proc user-data #f (if after? G_CONNECT_AFTER 0)))

(define-gobj g_object_get (_fun _GtkWidget (_string = "window") 
				[w : (_ptr o _GdkWindow)]
				(_pointer = #f) -> _void -> w))

(define-gobj g_object_new (_fun _GType _pointer -> _GtkWidget))

;; This seems dangerous, since the shape of GtkObject is not
;;  documented. But it seems to be the only way to get and set
;;  flags.
(define-cstruct _GtkObject ([type-instance _pointer]
                            [ref_count _uint]
                            [qdata _pointer]
                            [flags _uint32]))
(define (get-gtk-object-flags gtk)
  (GtkObject-flags (cast gtk _pointer _GtkObject-pointer)))
(define (set-gtk-object-flags! gtk v)
  (unless gtk3?
    (set-GtkObject-flags! (cast gtk _pointer _GtkObject-pointer) v)))

(define-gmodule g_module_open (_fun _path _int -> _pointer))

(define-syntax-rule (define-signal-handler 
                      connect-name
                      signal-name
                      (_fun . args)
                      proc)
  (begin
    (define handler-proc proc)
    (define handler_function
      (function-ptr handler-proc (_fun #:atomic? #t . args)))
    (define (connect-name gtk [user-data #f] #:after? [after? #f])    
      (g_signal_connect gtk signal-name handler_function user-data after?))))


(define _gpath/free
  (make-ctype _pointer
              path->bytes ; a Racket bytes can be used as a pointer
              (lambda (x)
                (let ([b (bytes->path (make-byte-string x))])
                  (g_free x)
                  b))))

(define-cstruct _g-slist
  ([data _pointer]
   [next (_or-null _g-slist-pointer)]))

(define-glib g_slist_free (_fun _g-slist-pointer -> _void))
;; This should probably be provided by Racket
(define make-byte-string
  (get-ffi-obj 'scheme_make_byte_string #f (_fun _pointer -> _racket)))

(define (_GSList elem)
  (make-ctype (_or-null _g-slist-pointer)
              (lambda (l)
                (let L ([l l])
                  (if (null? l) 
                      #f
                      (make-g-slist (car l) (L (cdr l))))))
              (lambda (gl)
                (begin0
                 (let L ([gl gl])
                   (if (not gl) 
                       null
                       (cons ((ctype-c->scheme elem) (g-slist-data gl))
                             (L (g-slist-next gl)))))
                 (g_slist_free gl)))))

(define-gdk gdk_screen_get_default (_fun -> _GdkScreen))

(define (mnemonic-string orig-s)
  (string-join
   (for/list ([s (in-list (regexp-split #rx"&&" orig-s))])
     (regexp-replace*
      #rx"&(.)"
      (regexp-replace*
       #rx"_" 
       s
       "__")
      "_\\1"))
   "&"))

;; ----------------------------------------

(define screen-scale-factor/promise
  (delay
    (inexact->exact (get-interface-scale-factor 0))))

(define (->screen x)
  (define screen-scale-factor
    (force screen-scale-factor/promise))
  (and x
       (if (= screen-scale-factor 1)
	   x
	   (if (exact? x)
	       (ceiling (* x screen-scale-factor))
	       (* x screen-scale-factor)))))
(define (->screen* x)
  (define screen-scale-factor
    (force screen-scale-factor/promise))
  (if (and (not (= screen-scale-factor 1))
	   (exact? x))
      (floor (* x screen-scale-factor))
      (->screen x)))

(define (->normal x)
  (define screen-scale-factor
    (force screen-scale-factor/promise))
  (and x
       (if (= screen-scale-factor 1)
	   x
	   (if (exact? x)
	       (floor (/ x screen-scale-factor))
	       (/ x screen-scale-factor)))))
