;; -*-theme-d-*-

;; Copyright (C) 2025 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-body (intr-gtk4-examples calc2 plugin-ui)
  
  
  (import (standard-library list-utilities)
          (standard-library object-string-conversion)
          (standard-library string-utilities)
          (standard-library plugins)
          (standard-library console-io))
  
  (import (intr-gtk4-examples calc2 ui-utils)
          (intr-gtk4-examples calc2 utils))
  
  
  (add-method plugin-root-dialog-new
    (prim-proc plugin-root-dialog-new () <plugin-root-dialog> nonpure))
  
  
  (add-method plugin-dialog-new
    (prim-proc plugin-dialog-new () <plugin-dialog> nonpure))
  
  
  (define-simple-method plugin-dialog-set-cur-plugin
      (((plugin-dialog <plugin-dialog>)
        (l-s-plugins (:uniform-list <symbol>))
        (s-cur-plugin (:alt-maybe <symbol>)))
       <none> nonpure)
    ;; The first item in the dropdown list is "(nothing)".
    (let* ((i-selected0
            (match-type s-cur-plugin
              ((<boolean>) -1)
              ((s-cur-plugin1 <symbol>)
               (list-index
                (lambda (((s <symbol>)) <boolean> pure)
                  (equal? s s-cur-plugin1))
                l-s-plugins))))
           (i-selected (+ i-selected0 1)))
      (slot-set! (slot-ref plugin-dialog 'dropdown-plugin)
                 'selected
                 i-selected)))
  
  
  (define-simple-method plugin-dialog-set-cur-proc
      (((plugin-dialog <plugin-dialog>)
        (foreign-var-cur (:alt-maybe <foreign-var>))
        (i-nargs <integer>))
       <none> nonpure)
    (match-type foreign-var-cur
      ((<boolean>)
       (slot-set! (slot-ref plugin-dialog 'checkbutton-normal-var) 'active #t)
       (slot-set! (slot-ref plugin-dialog 'buffer-proc) 'text "")
       (slot-set! (slot-ref plugin-dialog 'buffer-nargs) 'text ""))
      ((foreign-var-cur1 <foreign-var>)
       (case (cadr foreign-var-cur1)
         ((normal-var)
          (slot-set!
           (slot-ref plugin-dialog 'checkbutton-normal-var) 'active #t))
         ((ngp)
          (slot-set!
           (slot-ref plugin-dialog 'checkbutton-ngp) 'active #t))
         ((vgp)
          (slot-set!
           (slot-ref plugin-dialog 'checkbutton-vgp) 'active #t))
         (else
          ;; We should never arrive here.
          (raise-simple 'internal-error)))
       (slot-set! 
        (slot-ref plugin-dialog 'buffer-proc)
        'text
        (symbol->string (car foreign-var-cur1)))
       (slot-set! 
        (slot-ref plugin-dialog 'buffer-nargs)
        'text
        (if (>= i-nargs 0)
            (integer->string i-nargs)
            "")))))
  
  
  (define-simple-method plugin-dialog-get-proc
      (((plugin-dialog <plugin-dialog>)) (:alt-maybe <foreign-var>) nonpure)
    (let ((str-proc-name (slot-ref (slot-ref plugin-dialog 'buffer-proc) 'text))
          (foreign-var-type
           (cond
            ((slot-ref
              (slot-ref plugin-dialog 'checkbutton-normal-var)
              'active)
             'normal-var)
            ((slot-ref
              (slot-ref plugin-dialog 'checkbutton-ngp)
              'active)
             'ngp)
            ((slot-ref
              (slot-ref plugin-dialog 'checkbutton-vgp)
              'active)
             'vgp)
            (else
             ;; We should probably never arrive here.
             'normal-var))))
      (if (not (string-empty? str-proc-name))
          (list (string->symbol str-proc-name) foreign-var-type)
          #f)))
  
  
  (define-simple-method plugin-dialog-ok-clicked
      (((plugin-dialog <plugin-dialog>)
        (plugin-model <plugin-model>)
        (i-function <integer>))
       <none> nonpure)
    (let ((i-selected0
           (slot-ref
            (slot-ref plugin-dialog 'dropdown-plugin)
            'selected))
          (function-model
           (uniform-list-ref (field-ref plugin-model 'l-functions)
                             i-function)))
      (if (equal? i-selected0 0)
          (if (string-empty?
               (slot-ref
                (slot-ref plugin-dialog 'buffer-proc)
                'text))
              (begin
               (plugin-function-reset function-model)
               (destroy plugin-dialog))
              (show-message-dialog
               "Plugin Error"
               "The procedure is invalid."
               "dialog-error"
               plugin-dialog))
          (let* ((i-selected (- i-selected0 1))
                 (s-plugin-name
                  (uniform-list-ref
                   (field-ref plugin-model 'l-s-plugins)
                   i-selected)))
            (guard-general-nonpure exc
              (begin
               (dwln 'debug2 "plugin-dialog-ok-clicked/1")
               (if (rte-exception? exc)
                   (let ((exc1 (cast <condition> exc)))
                     (dwln 'debug2 "plugin-dialog-ok-clicked/1-2")
                     (case (get-rte-exception-kind exc1)
                       ((plugin-not-found)
                        (show-message-dialog
                         "Plugin Error"
                         "The plugin file cannot be opened."
                         "dialog-error"
                         plugin-dialog))
                       ((not-a-plugin-file)
                        (show-message-dialog
                         "Plugin Error"
                         "The plugin file is invalid."
                         "dialog-error"
                         plugin-dialog))
                       ((invalid-nargs)
                        (show-message-dialog
                         "Plugin Error"
                         "Invalid number of arguments."
                         "dialog-error"
                         plugin-dialog))
                       (else
                        (show-message-dialog
                         "Plugin Error"
                         (string-append
                          "Error "
                          (symbol->string (get-rte-exception-kind exc1))
                          ".")
                         "dialog-error"
                         plugin-dialog))))
                   (raise exc)))
              (let* ((module (calc2-load-plugin s-plugin-name))
                     (tmp1 (begin (dwln 'debug2 "plugin-dialog-ok-clicked/2") #f))
                     (foreign-var-cur (plugin-dialog-get-proc plugin-dialog)))
                (match-type foreign-var-cur
                  ((<boolean>)
                   (show-message-dialog
                    "Plugin Error"
                    "External procedure has not been set."
                    "dialog-error"
                    plugin-dialog))
                  ((foreign-var-cur1 <foreign-var>)
                   (let* ((s-proc-name (get-plugin-proc-name foreign-var-cur1))
                          (i-nargs
                           (guard-general-nonpure exc
                             (static-cast <integer>
                                          (raise-simple 'invalid-nargs))
                             (string->integer
                              (slot-ref
                               (slot-ref plugin-dialog 'buffer-nargs)
                               'text)))))
                     (if (or (< i-nargs 0) (> i-nargs gl-i-max-nargs))
                         (raise-simple 'invalid-nargs))
                     (if (module-var-exists? module s-proc-name)
                         (begin
                          (field-set! function-model 's-cur-plugin s-plugin-name)
                          (field-set! function-model
                                      'foreign-var-cur
                                      foreign-var-cur1)
                          (field-set! function-model 'i-nargs i-nargs)
                          (field-set! function-model 'module-cur module)
                          (field-set! function-model
                                      'proc-cur
                                      (module-ref module s-proc-name))
                          (destroy plugin-dialog))
                         (show-message-dialog
                          "Plugin Error"
                          "The specified procedure does not exist."
                          "dialog-error"
                          plugin-dialog)))))))))))
  
  
  (define-simple-method open-plugin-dialog
      (((plugin-model <plugin-model>)
        (i-function <integer>)
        (window-parent <gtk-window>))
       <none> nonpure)
    (dwln 'debug1 "open-plugin-dialog ENTER")
    (dwln 'debug1 "open-plugin-dialog/1")
    (let ((plugin-dialog (plugin-dialog-new))
          (function-model
           (uniform-list-ref
            (field-ref plugin-model 'l-functions)
            i-function)))
      (check-plugins function-model
                     (field-ref plugin-model 'l-s-plugins))
      (slot-set! (slot-ref plugin-dialog 'dropdown-plugin) 'model
                 (get-plugin-string-list plugin-model))
      (dwln 'debug1 "open-plugin-dialog/2")
      (plugin-dialog-set-cur-plugin
       plugin-dialog
       (field-ref plugin-model 'l-s-plugins)
       (field-ref function-model 's-cur-plugin))
      (plugin-dialog-set-cur-proc
       plugin-dialog
       (field-ref function-model 'foreign-var-cur)
       (field-ref function-model 'i-nargs))
      (set-transient-for plugin-dialog window-parent)
      (slot-set! plugin-dialog 'modal #t)
      (slot-set! plugin-dialog 'destroy-with-parent #t)
      (gtype-instance-signal-connect
       (slot-ref plugin-dialog 'button-ok)
       'clicked
       (lambda (((args (rest <object>))) <object> nonpure)
         (plugin-dialog-ok-clicked plugin-dialog plugin-model i-function)
         null))
      (gtype-instance-signal-connect
       (slot-ref plugin-dialog 'button-cancel)
       'clicked
       (lambda (((args (rest <object>))) <object> nonpure)
         (destroy plugin-dialog)
         null))
      (show plugin-dialog)
      (dwln 'debug1 "open-plugin-dialog EXIT")))


(define-simple-method make-index-string-list
    (((i-count <integer>)) <gtk-string-list> nonpure)
  (assert (>= i-count 0))
  (let ((string-list (gtk-string-list-new #f)))
    (do ((i <integer> 1 (+ i 1))) ((> i i-count))
      (gtk-string-list-append string-list (integer->string i)))
    string-list))

    
(define-simple-method open-plugin-root-dialog
    (((plugin-model <plugin-model>)
      (window-parent <gtk-window>))
     <none> nonpure)
  (field-set! plugin-model 'l-s-plugins (compute-plugin-list))
  (let* ((dialog (plugin-root-dialog-new))
         (i-nr-functions (length (field-ref plugin-model 'l-functions)))
         (string-list-indices (make-index-string-list i-nr-functions)))
    (slot-set! (slot-ref dialog 'dropdown-index) 'model string-list-indices)
    (set-transient-for dialog window-parent)
    (slot-set! dialog 'modal #t)
    (slot-set! dialog 'destroy-with-parent #t)
    (gtype-instance-signal-connect
     (slot-ref dialog 'button-conf)
     'clicked
     (lambda (((args (rest <object>))) <object> nonpure)
       (let ((i-function
              (slot-ref (slot-ref dialog 'dropdown-index) 'selected)))
         (if (and (>= i-function 0)
                  (< i-function
                     (length (field-ref plugin-model 'l-functions))))
             (open-plugin-dialog plugin-model i-function dialog)))
       #f))
    (gtype-instance-signal-connect
     (slot-ref dialog 'button-ok)
     'clicked
     (lambda (((args (rest <object>))) <object> nonpure)
       (destroy dialog)
       #f))
    (show dialog)))


  (define-simple-method report-load-config-error
      (((exc <object>)
        (app <gtk-application>)
        (proc-cb (:procedure () <none> nonpure)))
       <none> nonpure)
    (let* ((str1
            (string-append "Error loading plugin configuration.\n"
                           "The configuration shall be resetted."))
           (str-detail
            (if (rte-exception? exc)
                (begin
                 (console-display-line 
                  (get-rte-exception-info (cast <condition> exc)))
                 (string-append
                  "Error type: "
                  (symbol->string 
                   (get-rte-exception-kind (cast <condition> exc)))
                  "."))
                ""))
           (str-contents
            (if (not (string-empty? str-detail))
                (string-append str1 "\n" str-detail "\n")
                str1)))
      (show-message-dialog1 "Configuration Error"
                            str-contents
                            "dialog-error"
                            app
                            proc-cb)))


  (define-simple-method report-save-config-error
      (((exc <object>)
        (app <gtk-application>)
        (proc-cb (:procedure () <none> nonpure)))
       <none> nonpure)
    (let* ((str1
            (string-append "Error saving plugin configuration.\n"
                           "The program shall be terminated."))
           (str-detail
            (if (rte-exception? exc)
                (begin
                 (console-display-line 
                  (get-rte-exception-info (cast <condition> exc)))
                 (string-append
                  "Error type: "
                  (symbol->string 
                   (get-rte-exception-kind (cast <condition> exc)))
                  "."))
                ""))
           (str-contents
            (if (not (string-empty? str-detail))
                (string-append str1 "\n" str-detail "\n")
                str1)))
      (show-message-dialog1 "Configuration Error"
                            str-contents
                            "dialog-error"
                            app
                            proc-cb))))

