;; Copyright (C) 2016  Tommi Höynälänmaa

(define-body (gnome-examples theme-d-gnome-demo dialog)

  (import (gnome gtk)
	  (gnome gobject)
	  (standard-library object-string-conversion)
	  (standard-library string-utilities)
	  (gnome-examples theme-d-gnome-demo support))


  (define-mutable gl-i-counter <integer> 0)


  (define-simple-proc message-dialog-clicked
      (((window-parent <gtk-window>)) <none> nonpure)
    (let ((dialog (%gtk-message-dialog-create
		   window-parent
		   ;; modal | destroy-with-parent
		   3
		   'info
		   'ok
		   (string-append
		    "This message box has been popped up "
		    "the following\n"
		    "number of times:\n\n"
		    (integer->string gl-i-counter)))))
      (run dialog)
      (destroy dialog)
      (set! gl-i-counter (+ gl-i-counter 1))))


  (define-simple-proc interactive-dialog-clicked
      (((window-parent <gtk-window>) (entry1 <gtk-entry>) (entry2 <gtk-entry>))
       <none> nonpure)
    (let ((dialog (gtk-dialog-create "Interactive Dialog" #t #t))
	  (hbox (gtk-hbox-create #f 8))
	  (image-stock (gtk-image-create-from-stock
			(gtk-stock-id 'dialog-question)
			'dialog))
	  (table (gtk-table-create 2 2 #f))
	  (label1 (gtk-label-create "_Entry 1"))
	  (entry-local1 (gtk-entry-create))
	  (label2 (gtk-label-create "E_ntry 2"))
	  (entry-local2 (gtk-entry-create)))

      (set-use-underline label1 #t)
      (set-use-underline label2 #t)

      (add-button dialog (gtk-stock-id 'ok) 1)
      (add-button dialog "_Non-stock Button" 0)

      (set-border-width hbox 8)
      (pack-start (cast <gtk-vbox> (gtk-dialog-get-vbox dialog))
		  hbox #f #f 0)

      (pack-start hbox image-stock #f #f 0)

      (set-row-spacings table 4)
      (set-col-spacings table 4)
      (pack-start hbox table #t #t 0)

      (attach-defaults table label1 0 1 0 1)
      (set-text entry-local1 (gtk-entry-get-text entry1))
      (attach-defaults table entry-local1 1 2 0 1)
      (set-mnemonic-widget label1 entry-local1)

      (attach-defaults table label2 0 1 1 2)
      (set-text entry-local2 (gtk-entry-get-text entry2))
      (attach-defaults table entry-local2 1 2 1 2)
      (set-mnemonic-widget label2 entry-local2)

      (set-transient-for dialog window-parent)

      (show-all hbox)

      (let ((i-response (run dialog)))
	(if (equal? i-response 1)
	    (begin
	      (set-text entry1 (gtk-entry-get-text entry-local1))
	      (set-text entry2 (gtk-entry-get-text entry-local2)))))
      (destroy dialog)))


  (define-simple-proc run-dialog-demo (((window-parent <gtk-window>))
				       <none> nonpure)
    (let ((window (gtk-window-create 'toplevel))
	  (frame (gtk-frame-create "Dialogs"))
	  (vbox (gtk-vbox-create #f 8)))
      (set-title window "Dialogs")
      (set-border-width window 8)
      (add window frame)
      (set-border-width vbox 8)
      (add frame vbox)

      ;; standard message dialog
      (let ((hbox (gtk-hbox-create #f 8))
	    (button (gtk-button-create-with-label "_Message Dialog")))
	(set-use-underline button #t)
	(pack-start vbox hbox #f #f 0)
	(connect button 'clicked
		 (lambda (((args (rest <object>)))
			  <object>
			  nonpure)
		   (message-dialog-clicked window)
		   null))
	(pack-start hbox button  #f #f 0))
      (pack-start vbox (gtk-hseparator-create) #f #f 0)

      ;; interactive dialog
      (let ((hbox (gtk-hbox-create #f 8))
	    (vbox2 (gtk-vbox-create #f 0))
	    (button (gtk-button-create-with-label "_Interactive Dialog"))
	    (table (gtk-table-create 2 2 #f))
	    (label1 (gtk-label-create "_Entry 1"))
	    (entry1 (gtk-entry-create))
	    (label2 (gtk-label-create "E_ntry 2"))
	    (entry2 (gtk-entry-create)))

	(set-use-underline button #t)
	(set-use-underline label1 #t)
	(set-use-underline label2 #t)
	(pack-start vbox hbox #f #f 0)
	(connect
	 button 'clicked
	 (lambda (((args (rest <object>)))
		  <object>
		  nonpure)
	   (interactive-dialog-clicked window entry1 entry2)
	   null))

	(pack-start hbox vbox2 #f #f 0)
	(pack-start vbox2 button #f #f 0)
	(set-row-spacings table 4)
	(set-col-spacings table 4)

	(pack-start hbox table #f #f 0)

	(attach-defaults table label1 0 1 0 1)
	(attach-defaults table entry1 1 2 0 1)
	(set-mnemonic-widget label1 entry1)
	(attach-defaults table label2 0 1 1 2)
	(attach-defaults table entry2 1 2 1 2)
	(set-mnemonic-widget label2 entry2)

	(set-modal window #t)
	(set-transient-for window window-parent)

	(show-all window))))


  (define-simple-proc get-dialog-demo (() <demo> force-pure)
    (let* ((str-name "Dialog and Message Boxes")
	   (str-module-name "dialog")
	   (str-desc 
	    (string-append
	     "Dialog widgets are used to pop up a transient window "
	     "for user feedback."))
	   (demo (make <demo> str-name str-module-name str-desc "" ""
		       run-dialog-demo)))
      (demo-compute-source demo)
      demo)))
