;; -*-theme-d-*-

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

;; This file is part of Theme-D-Intr.

;; You can redistribute and/or modify this file under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation, either version 3 of the License, or (at your option) any
;; later version.

;; This file is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with this program. If not, see https://www.gnu.org/licenses/.


(define-proper-program (intr-gtk4-examples appwindow main)
  
  (import (standard-library core)
          (standard-library list-utilities)
          (standard-library string-utilities)
          (standard-library console-io)
          (standard-library object-string-conversion)
          (theme-d-intr base support)
          (intr-gtk4-examples appwindow _intr-imports))
  
  (define-simple-method error (((str <string>)) <none> never-returns)
    (console-display-line str)
    (console-newline)
    (exit 1))
  
  (define getcwd
    (prim-proc getcwd () <string> pure))
  
  (define connect gtype-instance-signal-connect)
  
  (define-simple-method application-settings
      (((str-name <string>)) <g-settings> nonpure)
    (let* ((src (g-settings-schema-source-new-from-directory "@programdir@"
                                                             #f #f))
           (schema (g-settings-schema-source-lookup src str-name #f)))
      (g-settings-new-full (cast <pointer> schema) #f #f)))
  
  (define-simple-method update-statusbar (((textbuffer <gtk-text-buffer>)
                                           (statusbar <gtk-statusbar>))
                                          <none>
                                          nonpure)
    (let ((iter (get-iter-at-mark
                 textbuffer
                 (get-insert textbuffer))))
      (pop statusbar 0)
      (push
       statusbar
       0
       (string-append
        "Cursor at row "
        (integer->string (gtk-text-iter-get-line iter))
        " column "
        (integer->string (gtk-text-iter-get-line-offset iter))
        " - "
        (integer->string (get-char-count textbuffer))
        " chars in document"))))
  
  (define-simple-method show-message-dialog
      (((window-parent <gtk-window>) (str-text <string>)) <none> nonpure)
    (let ((dialog
           (cast <adw-message-dialog>
                 (adw-message-dialog-new
                  window-parent "Menu item activated" str-text))))
      (set-size-request dialog 250 150)
      (set-transient-for dialog window-parent)
      (add-response dialog "close" "Close")
      (set-default-response dialog "close")
      (set-close-response dialog "close")
      (connect dialog 'response
               (lambda (((l-args (rest <object>))) <boolean> nonpure)
                 (destroy dialog)
                 #f))
      (present dialog)))
  
  (define-simple-method startup-my-app
      (((args (rest <object>))) <object> nonpure)
    (let* ((app (cast <gtk-application> (uniform-list-ref args 0)))
           (builder (gtk-builder-new))
           (ui "@programdir@/appwindow.ui"))
      (case (add-from-file builder ui)
        ((#f)
         (error (string-append "<gtk-builder> - add-from-file failed: " ui)))
        (else
         (let ((menubar (cast <g-menu-model> (get-object builder "menubar"))))
           (set-menubar app menubar)
           (g-object-unref builder)
           #f)))))
  
  (define-simple-method activate-my-app
      (((args (rest <object>))) <object> nonpure)
    (let* ((app (cast <gtk-application> (uniform-list-ref args 0)))
           (window (cast <gtk-application-window>
                         (gtk-application-window-new app)))
           (box (cast <gtk-box> (gtk-box-new 'vertical 1)))
           ;; (actiongroup (gtk-action-group-new "AppWindowActions"))
           ;; (uimanager (gtk-ui-manager-new))
           (scrwin
            (cast <gtk-scrolled-window> (gtk-scrolled-window-new)))
           (textbuffer (gtk-text-buffer-new #f))
           (textview
            (cast <gtk-text-view> (gtk-text-view-new-with-buffer textbuffer)))
           (statusbar (cast <gtk-statusbar> (gtk-statusbar-new)))
           (box-toolbar (cast <gtk-box> (gtk-box-new 'horizontal 1)))
           (button-open (gtk-button-new-from-icon-name "document-open"))
           (button-quit (gtk-button-new-from-icon-name "application-exit"))
           (settings (application-settings "org.tohoyn.appwindow"))
           (a-quit (g-simple-action-new "quit" #f))
           (a-color (create-action settings "color"))
           (a-shape (create-action settings "shape"))
           (a-bold (create-action settings "bold")))
      (add-action app a-quit)
      (connect a-quit
               'activate
               (lambda (((l-args (rest <object>))) <boolean> nonpure)
                 (for-each1 (lambda (((win <object>)) <none> nonpure)
                              (destroy (cast <gtk-window> win)))
                            (get-windows app))
                 #f))
      (add-action app a-color)
      (add-action app a-shape)
      (add-action app a-bold)
      (set-show-menubar window #t)
      (set-title window "Application Window")
      ;; (gobject-set-property window 'default-width 200)
      ;; (gobject-set-property window 'default-height 200)
      (set-size-request window 500 400)
      (set-policy scrwin 'automatic 'automatic)
      ;; (set-shadow-type scrwin 'in)
      (set-vexpand scrwin #t)
      
      (set-child window box)
      (gtk-box-append box box-toolbar)
      (gtk-box-append box-toolbar button-open)
      (gtk-box-append box-toolbar button-quit)
      
      (gtk-box-append box scrwin)
      (grab-focus textview)
      (set-child scrwin textview)
      (gtk-box-append box statusbar)
      
      (connect
       textbuffer 'changed
       (lambda (((l-args (rest <object>))) <object> nonpure)
         (update-statusbar textbuffer statusbar)
         #f))
      (connect
       textbuffer 'mark-set
       (lambda (((l-args (rest <object>))) <object> nonpure)
         (update-statusbar textbuffer statusbar)
         #f))
      (connect
       window 'close-request
       (lambda (((l-args (rest <object>))) <object> nonpure)
         (destroy window)
         #f))
      (connect settings 'changed::color
               (lambda (((l-args (rest <object>))) <boolean> nonpure)
                 (show-message-dialog
                  window
                  (string-append
                   "Color activated: "
                   (integer->string (get-enum settings "color"))))
                 #f))      
      (connect settings 'changed::shape
               (lambda (((l-args (rest <object>))) <boolean> nonpure)
                 (show-message-dialog
                  window
                  (string-append
                   "Shape activated: "
                   (integer->string (get-enum settings "shape"))))
                 #f))
      (connect settings 'changed::bold
               (lambda (((l-args (rest <object>))) <boolean> nonpure)
                 (show-message-dialog
                  window
                  (string-append
                   "bold activated: "
                   (if (get-boolean settings "bold") "#t" "#f")))
                 #f))
      (update-statusbar textbuffer statusbar)
      (show window)
      #f))
  
  
  (define-main-proc (() <none> nonpure)
    (let* ((str-app-name "org.tohoyn.appwindow")
           (app (gtk-application-new str-app-name null)))
      (gtype-instance-signal-connect
       app 'startup startup-my-app)
      (gtype-instance-signal-connect
       app 'activate activate-my-app)
      (let ((status (g-application-run app null)))
        status))))
