
;; Copyright (C) 2016-2018 Tommi Höynälänmaa
;; Distributed under GNU Lesser General Public License version 3
;; See file doc/LGPL-3.

(library (theme-d-gnome runtime gnome-support)

  (export <gtype>
	  <gtk-progress>
	  theme-gtype-instance-signal-connect
	  theme-gtk-entry-new
	  make-gboolean
	  theme-gtk-tree-selection-get-selected
	  theme-gtk-dialog-new
	  theme-gtk-frame-new
	  proc-theme->scheme
	  process-action-row
	  theme-gtk-action-group-add-actions
	  process-toggle-action-row
	  theme-gtk-action-group-add-toggle-actions
	  theme-gtk-action-group-add-radio-actions
	  gtk-cell-layout-set-attributes)
  
  (import (guile)
	  (rnrs)
	  (except (srfi srfi-1) map)
	  (g-wrap gw-wct)
	  (oop goops)
	  (theme-d runtime runtime-theme-d-environment)
	  (th-scheme-utilities stdutils))

  (import (gnome gobject)
	  (gnome pango)
	  (gnome atk)
	  (gnome gw gdk)
	  (gnome gw gtk)
	  (gnome gtk)
	  (gnome gtk gdk-event))

  (define (theme-gtype-instance-signal-connect obj sym-name proc-handler)
    (gtype-instance-signal-connect
     obj sym-name
     (lambda args
       (_i_call-proc proc-handler
		     args
		     (map theme-class-of args)))))

  (define <gtype> <object>)

  (define <gtk-progress> <gobject>)

  ;; For some reason gtk-entry-new is not visible in guile module (gnome gtk).
  (define (theme-gtk-entry-new)
    (make <gtk-entry>))

  (define (make-gboolean b)
    (make <gboolean> #:value b))

  (define (theme-gtk-tree-selection-get-selected treeselection)
    (call-with-values
	(lambda () (gtk-tree-selection-get-selected treeselection))
      (lambda (treemodel treeiter)
	(cons treemodel treeiter))))

  (define (theme-gtk-dialog-new str-title modal? destroy-with-parent?)
    (make <gtk-dialog>
      #:title str-title
      #:modal modal?
      #:destroy-with-parent destroy-with-parent?))

  (define (theme-gtk-frame-new str-label s-shadow-type
			       i-width-request i-height-request)
    (make <gtk-frame>
      #:label str-label
      #:shadow-type s-shadow-type
      #:width-request i-width-request
      #:height-request i-height-request))

  (define (proc-theme->scheme proc-theme)
    (lambda l-args
      (_i_call-proc proc-theme l-args (map theme-class-of l-args))))


  (define (process-action-row l-row)
    (let ((i-len (length l-row)))
      (cond
       ((< i-len 6) l-row)
       ((= i-len 6)
	(let* ((proc-theme (list-ref l-row 5))
	       (proc-scheme (proc-theme->scheme proc-theme))
	       (l-begin (drop-right l-row 1)))
	  (append l-begin (list proc-scheme))))
       (else (raise 'invalid-action-desc)))))


  (define (theme-gtk-action-group-add-actions actiongroup l-action-descs)
    (let ((l-processed (map process-action-row l-action-descs)))
      (gtk-action-group-add-actions actiongroup l-processed)))


  (define (process-toggle-action-row l-row)
    (let ((i-len (length l-row)))
      ;; Not sure if the whole descriptor is necessary.
      (assert (= i-len 7))
      (let* ((proc-theme (list-ref l-row 5))
	     (proc-scheme (proc-theme->scheme proc-theme))
	     (l-begin (drop-right l-row 2))
	     (o-last (last l-row)))
	(append l-begin (list proc-scheme) (list o-last)))))


  (define (theme-gtk-action-group-add-toggle-actions actiongroup l-action-descs)
    (let ((l-processed (map process-toggle-action-row l-action-descs)))
      (gtk-action-group-add-toggle-actions actiongroup l-processed)))


  (define (theme-gtk-action-group-add-radio-actions actiongroup l-action-descs
						    i-value proc-handler)
    (gtk-action-group-add-radio-actions actiongroup l-action-descs i-value
					(proc-theme->scheme proc-handler)))


  (define (gtk-cell-layout-set-attributes layout renderer)
    (raise 'not-implemented)))
