;; -*-theme-d-*-

;; Copyright (C) 2015, 2020-2025 Tommi Höynälänmaa

;; Based on the file gtk/examples/calc.scm by Marius Vollmer and
;; Patrick Bernaud in package guile-gnome-platform-2.16.2.

;; 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 calc2 main)
  
  (import (standard-library core)
          (standard-library list-utilities)
          (standard-library dynamic-list)
          (standard-library string-utilities)
          (standard-library text-file-io)
          (standard-library object-string-conversion)
          (standard-library math)
          (standard-library text-file-io)
          (standard-library console-io)
          (standard-library plugins)
          (intr-gtk4-examples calc2 plugin-model)
          (intr-gtk4-examples calc2 plugin-ui)
          (intr-gtk4-examples calc2 utils)
          (intr-gtk4-examples calc2 ui-utils)
          (intr-gtk4-examples calc2 _intr-imports))
  
  (prevent-stripping <pointer>)
  
  (define gl-debug? <boolean> #f)
  
  (define-mutable gl-counter1 <integer> 0)
  
  ;; Allow debug printing in pure procedures, too.
  (define-simple-method debug-print (((obj <object>)) <none> force-pure)
    (if gl-debug? (console-display-line obj)))
  
  (define <op-proc> (:procedure ((rest <object>)) <object> nonpure))
  
  (define <op-spec> (:tuple <string> <op-proc> (:union <integer> <symbol>)
                            (:union <symbol> <integer>)))
  
  (define <panel> (:uniform-list (:uniform-list <op-spec>)))
  
  (define <echo-type> (:union (:unit-type 'info) (:unit-type 'error)))

  (define-simple-method simplify-number (((nr <number>)) <number> pure)
    (match-type nr
      ((i <integer>) i)
      ((rat <rational>) 
       (if (rat-integer-valued? rat) (rational->integer rat) rat))
      ((r <real>) r)
      ((cx <complex>)
       (if (= (imag-part cx) 0.0) (real-part cx) cx))))
  
  (define-simple-method convert-to-real-number (((nr <number>)) <real-number>
                                                                pure)
    (match-type nr
      ((i <integer>) i)
      ((rat <rational>) rat) 
      ((r <real>) r)
      ((cx <complex>)
       (raise-simple 'invalid-real-number))))
  
  (define-simple-method my-complex (((nr1 <number>) (nr2 <number>)) <complex>
                                                                    pure)
    (if (and (real-valued? nr1) (real-valued? nr2))
        (complex (convert-to-real-number nr1) (convert-to-real-number nr2))
        (raise-simple 'invalid-real-number)))
  
  (define-simple-method my-real-part (((nr <number>)) <real-number> pure)
    (match-type nr
      ((i <integer>) i)
      ((rat <rational>) rat)
      ((r <real>) r)
      ((cx <complex>) (real-part cx))))
  
  (define-simple-method my-imag-part (((nr <number>)) <real-number> pure)
    (match-type nr
      ((i <integer>) 0)
      ((rat <rational>) (rational 0 1))
      ((r <real>) 0.0)
      ((cx <complex>) (imag-part cx))))
  
  (define-simple-method remove-all-css-classes
      (((widget <gtk-widget>)) <none> nonpure)
    (let ((x-css-classes (get-css-classes widget)))
      (d-for-each1
       (lambda (((x-class <object>)) <none> nonpure)
         (remove-css-class widget (cast <string> x-class)))
       x-css-classes)))

  (define-simple-method make-calculator
      (((app <gtk-application>)
        (lst-panels (:uniform-list <panel>))
        (plugin-model <plugin-model>))
       <none>
       nonpure)
    (let* ((window (cast <gtk-window> (gtk-application-window-new app)))
           (box (cast <gtk-box> (gtk-box-new 'vertical 0)))
           (scrolled-win (cast <gtk-scrolled-window>
                               (gtk-scrolled-window-new)))
           (text-buffer (cast <gtk-text-buffer> (gtk-text-buffer-new #f)))
           (text-view (cast <gtk-text-view>
                            (gtk-text-view-new-with-buffer text-buffer)))
           (entry (cast <gtk-entry> (gtk-entry-new)))
           (entry-buffer (get-buffer entry))
           (tag-just (gtk-text-tag-new "right-justification"))
           (tag-table (gtk-text-buffer-get-tag-table text-buffer))
           ;;	   (attrlist (pango-attr-list-create))
           ;;	   (attr-background (pango-attr-background-new 65535 0 0))
           (label-echo (cast <gtk-label> (gtk-label-new "")))
           (context-echo (get-style-context label-echo))
           (css-provider (gtk-css-provider-new))
           (conf-user-def-fn
            (lambda (() <none> nonpure)
              (open-plugin-root-dialog plugin-model window))))
           ;; (ui-interface (make <ui-interface> #:app app #:window-app window)))
      ;; (load-plugin-config plugin-model ui-interface)
      (let-mutable ((lst-stack <list> null))
        (let* ((push (lambda (((obj-value <object>)) <none> nonpure)
                       (debug-print "push")
                       (set! lst-stack (cons obj-value lst-stack))))
               
               (pop (lambda (() <object> nonpure)
                      (debug-print "pop")
                      (let* ((pr (cast (:pair <object> <object>) lst-stack))
                             (obj-value (car pr)))
                        (set! lst-stack (cast <list> (cdr pr)))
                        obj-value)))
               
               (pop-n (lambda (((i-count <integer>)) <list> nonpure)
                        (debug-print "pop-n")
                        (if (< (length lst-stack) i-count)
                            (raise-simple 'too-few-arguments)
                            (do ((i <integer> i-count (- i 1))
                                 (lst <list> null (cons (pop) lst)))
                                ((<= i 0) lst)))))
               
               (redisplay
                (lambda (() <none> nonpure)
                  (debug-print "redisplay ENTER")
                  (set-text text-buffer "" -1)
                  (debug-print "redisplay/1")
                  (let ((iter (get-start-iter text-buffer)))
                    (debug-print "redisplay/2")
                    (do ((i <integer> 1 (+ i 1))
                         (lst <object> lst-stack
                              (cdr (cast (:pair <object> <object>) lst))))
                        ((null? lst))
                      (debug-print "redisplay/3")
                      (debug-print (car (cast (:pair <object> <object>) lst)))
                      (insert text-buffer iter
                              (string-append
                               (integer->string i)
                               ":\n"))
                      (let ((mark (create-mark
                                   text-buffer "current"
                                   iter
                                   #t)))
                        (insert
                         text-buffer iter
                         (string-append
                          (object->string
                           (car (cast (:pair <object> <object>) lst)))
                          "\n"))
                        (let ((iter2 (get-iter-at-mark text-buffer mark)))
                          (apply-tag text-buffer tag-just
                                     iter2
                                     (gtk-text-buffer-get-end-iter
                                      text-buffer))))))
                  (debug-print "redisplay EXIT")))
               
               (set-echo
                (let-mutable ((str-last-text <string> ""))
                  (lambda (((str-text <string>) (echo-type <echo-type>))
                           <none> nonpure)
                    (debug-print "set-echo ENTER")
                    (cond ((not (string=? str-last-text str-text))
                           (set! str-last-text str-text)
                           (remove-all-css-classes label-echo)
                           (add-css-class
                            label-echo
                            (case echo-type
                              ((info) "status-line-info")
                              ((error) "status-line-error")
                              (else (raise-simple 'set-echo:internal-error))))
                           (gtk-label-set-text label-echo str-text)))
                    (debug-print "set-echo EXIT"))))

               (set-echo-error
                (lambda (((str-text <string>)) <none> nonpure)
                  (set-echo str-text 'error)))

               (set-echo-info
                (lambda (((str-text <string>)) <none> nonpure)
                  (set-echo str-text 'info)))

               (construct-error-message
                (lambda (((exc <object>)) <string> pure)
                  (debug-print "construct-error-message")
                  (match-type exc
                    ((exc1 <condition>)
                     (if (rte-exception? exc1)
                         (case (get-rte-exception-kind exc1)
                           ((numerical-overflow) "Numerical overflow")
                           ((too-few-arguments) "Too few arguments")
                           ((invalid-real-number) "Invalid real number")
                           ((error-with-user-fn) "Error with the user defined function")
                           (else "Error"))
                         "Error"))
                    (else "Error"))))
               
               (activate-entry
                (lambda (((dup? <boolean>)) <none> nonpure)
                  (debug-print "activate-entry ENTER")
                  (let ((lst-vals (cast <list> (call-with-input-string
                                                (get-text entry-buffer)
                                                read-all))))
                    (if (is-instance? lst-vals (:uniform-list <number>))
                        (begin
                         (if (null? lst-vals)
                             (if (and dup? (not-null? lst-stack))
                                 (push (car (cast (:pair <object> <object>)
                                                  lst-stack))))
                             (for-each1 push lst-vals))
                         (redisplay)
                         (set-text entry-buffer "" 0)
                         (set-echo-info ""))
                        (raise-simple 'invalid-number)))
                  (debug-print "activate-entry EXIT")))
               
               (perform-action
                (lambda (((obj-val <object>) (x-action (:union <symbol> <integer>)))
                         <none> nonpure)
                  (debug-print "perform-action ENTER")
                  (match-type x-action
                    ((i-user-fn <integer>)
                     (match-type obj-val
                       ((l <list>)
                        (for-each1 push l))
                       (else (push obj-val)))
                     (set-echo-info
                      (string-append
                       "Function "
                       (match-type
                           (field-ref
                            (uniform-list-ref
                             (field-ref plugin-model 'l-functions)
                             i-user-fn)
                            'foreign-var-cur)
                         ((foreign-var1 <foreign-var>)
                          (symbol->string
                           (car foreign-var1)))
                         (else "?"))
                       " evaluated.")))
                    ((sym-action <symbol>)
                     (cond
                      ((symbol=? sym-action 'push) (push obj-val))
                      ((symbol=? sym-action 'push-list)
                       (for-each1 push (cast <list> obj-val)))
                      ((symbol=? sym-action 'set-entry)
                       (set-text entry-buffer (cast <string> obj-val) -1))
                      (else (raise-simple 'bad-action)))
                     (debug-print "perform-action EXIT")))))
               
               (make-op
                (lambda (((proc <op-proc>)
                          (obj-arg-count (:union <integer> <symbol>))
                          (x-action (:union <symbol> <integer>)))
                         <none> nonpure)
                  (debug-print "make-op ENTER")
                  (debug-print gl-counter1)
                  (set! gl-counter1 (+ gl-counter1 1))
                  (cond
                   ((equal? x-action 'conf)
                    (set-echo-info "")
                    (conf-user-def-fn))
                   ((and (integer? x-action)
                         (not-object
                          (field-ref
                           (uniform-list-ref
                            (field-ref plugin-model 'l-functions)
                            (cast <integer> x-action))
                           'proc-cur)))
                      (set-echo-error "User-defined function not defined"))
                   ((and (integer? x-action)
                         (<
                          (field-ref
                           (uniform-list-ref
                            (field-ref plugin-model 'l-functions)
                            (cast <integer> x-action))
                           'i-nargs)
                          0))
                      (set-echo-error "Internal error with the user-defined function"))
                   (else
                      (let-mutable ((activate-failed? <boolean> #f))
                        (if (not (equal? x-action 'set-entry))
                            (guard-without-result
                              (exc
                               (else
                                (set-echo-error
                                 (if (equal? exc 'invalid-number)
                                     "Invalid number"
                                     "Error"))
                                (set! activate-failed? #t)))
                              (activate-entry #f)))
                        (if (not activate-failed?)
                            (let ((lst-saved-stack lst-stack))
                              (guard-without-result
                                (exc
                                 (else
                                  (match-type exc
                                    ((exc1 <condition>)
                                     (debug-print "raised")
                                     (debug-print (rte-exception? exc1))
                                     (debug-print exc1)
                                     (if (rte-exception? exc1)
                                         (set-echo-error (construct-error-message exc1))
                                         (raise exc))
                                     (set! lst-stack lst-saved-stack)
                                     (redisplay))
                                    (else
                                     (raise exc)))))
                                (debug-print "make-op normal")
                                (set-echo-info "")
                                (let ((lst-args
                                       (cond
                                        ((integer? obj-arg-count)
                                         (debug-print "integer count")
                                         (pop-n
                                          (cast <integer> obj-arg-count)))
                                        ((equal? obj-arg-count 'all)
                                         (debug-print "count all")
                                         (pop-n (length lst-stack)))
                                        ((integer? x-action)
                                         (debug-print "count n")
                                         (pop-n
                                          (field-ref
                                           (uniform-list-ref
                                            (field-ref plugin-model 'l-functions)
                                            (cast <integer> x-action))
                                           'i-nargs)))
                                        ((equal? obj-arg-count 'entry)
                                         (debug-print "count entry")
                                         (list (get-text entry-buffer)))
                                        (else
                                         (debug-print "bad arg spec")
                                         (raise-simple 'bad-arg-spec)))))
                                  (perform-action (apply-nonpure
                                                   proc
                                                   (cast <list> lst-args))
                                                  x-action)
                                  null)))))))
                  (redisplay)
                  (debug-print "make-op EXIT")))
               
               (make-button-row
                (lambda (((lst-specs (:uniform-list <op-spec>)))
                         <gtk-widget>
                         nonpure)
                  (debug-print "make-button-row")
                  (let ((box (cast <gtk-box> (gtk-box-new 'horizontal 2))))
                    (set-homogeneous box #t)
                    (set-margin-top box 2)
                    (for-each1
                     (lambda (((op-spec <op-spec>)) <none> nonpure)
                       (let* ((button (cast <gtk-button>
                                            (gtk-button-new-with-label
                                             (car op-spec))))
                              (context (get-style-context button)))
                         (set-has-frame button #t)
                         ;; (add-provider context css-provider 600)
                         (add-css-class button "button-1")
                         (gtype-instance-signal-connect
                          button 'clicked
                          (lambda (((args (rest <object>))) <object> nonpure)
                            (debug-print "clicked ENTER")
                            (debug-print (car op-spec))
                            (apply-nonpure make-op (cdr op-spec))
                            (debug-print "clicked EXIT")
                            null))
                         ;; (pack-start box button #t #t 0)))
                         (gtk-box-append box button)))
                     lst-specs)
                    box))))
          
        ;;   (gtk-css-provider-load-from-path css-provider
        ;;                                    "@programdir@/style.css")

          (gtk-css-provider-load-from-path
           css-provider
           (string-append (cast <string> (current-dirname)) "/style.css"))

          (gtk-style-context-add-provider-for-display
           (cast <gdk-display> (gdk-display-get-default))
           css-provider
           600)
          
          ;; (add-provider context-echo css-provider 600)
          ;; (add-css-class label-echo "status-line")
          
          (set-editable text-view #f)
          
          (set-title window "Calc")
          
          (set-policy scrolled-win 'automatic 'always)
          (gtk-scrolled-window-set-child scrolled-win text-view)
          ;; (set-alignment label-echo 0.0 0.5)
          ;;	  (pango-attr-list-insert attrlist attr-background)
          ;;	  (gtk-label-set-attributes label-echo attrlist)
          (set-size-request scrolled-win 200 120)
          
          (gtk-window-set-child window box)
          ;; (pack-start box scrolled-win #t #t 0)
          ;; (pack-start box entry #f #f 0)
          (gtk-box-append box scrolled-win)
          (gtk-box-append box entry)
          
          (slot-set0! tag-just 'justification 'right)
          (gtk-text-tag-table-add tag-table tag-just)
          
          (for-each1
           (lambda (((panel <panel>)) <none> nonpure)
             (for-each1 
              (lambda (((lst-op-specs (:uniform-list <op-spec>)))
                       <none> nonpure)
                (let ((widget-row (make-button-row lst-op-specs)))
                  ;; (pack-start box widget-row #f #f 1)))
                  (gtk-box-append box widget-row)))
              panel)
             ;; (pack-start box (gtk-separator-new 'horizontal) #f #f 1))
             (gtk-box-append box (gtk-separator-new 'horizontal)))
           lst-panels)
          
          ;; (pack-end box label-echo #f #f 0)
          (gtk-box-append box label-echo)
          
          (gtype-instance-signal-connect
           entry 'activate
           (lambda (((args (rest <object>))) <object> nonpure)
             (guard-without-result
               (exc
                (else
                 (console-display-line
                  "unhandled exception (2)")
                 null))
               (activate-entry #t))
             null))
          
          (gtype-instance-signal-connect
           window 'destroy
           (lambda (((args (rest <object>))) <object> nonpure)
             (g-application-quit app)
             null))

          (gtype-instance-signal-connect
           window 'close-request
           (lambda (((args (rest <object>))) <object> nonpure)
             (console-display-line "Saving plugin configuration")
             (let-mutable ((exc1 <object> #f))
               (let ((save-result?
                      (guard-general-nonpure exc
                        (begin
                         (set! exc1 exc)
                         #f)
                        (begin
                         (save-plugin-config plugin-model)
                         #t))))
                 (if save-result?
                     (g-application-quit app)
                     (report-save-config-error
                      exc1 app
                      (lambda (() <none> nonpure)
                        (g-application-quit app)))))                
               null)))
          
          (gtk-widget-show window)))))
  
  (define-simple-method unary-op
      (((str-name <string>)
        (proc (:procedure (<number>) <number> pure)))
       <op-spec>
       pure)
    (let ((proc0 (lambda (((lst-args (rest <object>))) <object> pure)
                   (debug-print "applying unary operator ENTER")
                   (let* ((nr-arg
                           (car (cast (:pair <number> <object>) lst-args)))
                          (nr-result (simplify-number (proc nr-arg))))
                     (debug-print "applying unary operator EXIT")
                     nr-result))))
      (list str-name proc0 1 'push)))
  
  (define-simple-method binary-op
      (((str-name <string>)
        (proc (:procedure (<number> <number>) <number> pure)))
       <op-spec>
       pure)
    (let ((proc0 (lambda (((lst-args (rest <object>))) <object> pure)
                   ;; (guard
                   ;;  (exc (else (debug-print "exception HEP")
                   ;; 	       (raise exc)
                   ;; 	       #f))
                   (begin
                    (debug-print "applying binary operator ENTER")
                    (let* ((obj-args1
                            (cast (:pair <number> (:pair <number> <object>))
                                  lst-args))
                           (nr-arg1 <number> (car obj-args1))
                           (nr-arg2 <number> (car (cdr obj-args1)))
                           (tmp1 (begin
                                  (debug-print "applying binary operator/1")
                                  #f))
                           (nr-result (simplify-number (proc nr-arg1 nr-arg2))))
                      (debug-print "applying binary operator EXIT")
                      nr-result)))))
      (list str-name proc0 2 'push)))
  
  (define-simple-method do-nothing (((args (rest <object>))) <object> pure)
    null)
  
  (define-simple-method do-swap (((args (rest <object>))) <object> pure)
    (debug-print "do-swap ENTER")
    (let* ((args1 (cast (:tuple <object> <object>) args))
           (obj1 (car args1))
           (obj2 (car (cdr args1))))
      (debug-print "do-swap EXIT")
      (list obj2 obj1)))
  
  (define-simple-method do-dup (((args (rest <object>))) <object> pure)
    (let ((obj (car (cast (:tuple <object>) args))))
      (list obj obj)))
  
  (define panel-stack-ops <panel>
    (list
     (list
      (list "drop" do-nothing 1 'push-list)
      (list "swap" do-swap 2 'push-list)
      (list "dup" do-dup 1 'push-list)
      (list "clear" do-nothing 'all 'push-list))))
  
  (define-simple-method ins
      (((str <string>)) (:procedure ((rest <object>)) <object> pure) pure)
    (lambda (((lst-args (rest <object>))) <object> pure)
      (string-append (car (cast (:pair <string> <object>) lst-args))
                     str)))
  
  (define-simple-method del (((lst-args (rest <object>))) <object> pure)
    (let* ((str-entry (car (cast (:pair <string> <object>) lst-args)))
           (i-len (string-length str-entry)))
      (if (> i-len 0)
          (substring str-entry 0 (- i-len 1))
          str-entry)))
  
  
  (define-main-proc (() <none> nonpure)
    
    (let* ((plugin-model
            (create <plugin-model>
                    null
                    (make-function-models gl-i-nr-user-fns)))

           (apply-user-def-fn
            (lambda (((i-user-fn <integer>))
                     (:procedure ((rest <object>)) <object> nonpure)
                     pure)
              (lambda (((l-args (rest <object>))) <object> nonpure)
                (guard-general-nonpure exc
                  (begin
                   (if (rte-exception? exc)
                       (begin
                        (console-display-line "user fn error")
                        (console-display-line
                         (get-rte-exception-kind (cast <condition> exc)))))
                   (static-cast <object> (raise2 'error-with-user-fn)))
                  (let ((x-result
                         (dyn-apply
                          (field-ref
                           (uniform-list-ref
                            (field-ref plugin-model 'l-functions)
                            i-user-fn)
                           'proc-cur)
                          l-args)))
                    (match-type x-result
                      ((nr <number>) (simplify-number nr))
                      ((l-nr (:uniform-list <number>)) (map1 simplify-number l-nr))
                      (else (raise2 'invalid-user-fn-result))))))))
           
           (panel-arith-ops
            <panel>
            (list
             (list
              (unary-op "+-" -)
              (binary-op "+" +)
              (binary-op "-" -)
              (binary-op "*" *)
              (binary-op "/" /))))
           
           (panel-trans-ops
            <panel>
            (list
             (list
              (unary-op "sin" sin)
              (unary-op "cos" cos)
              (unary-op "tan" tan)
              (unary-op "exp" exp))
             (list
              (unary-op "asin" asin)
              (unary-op "acos" acos)
              (unary-op "atan" atan)
              (unary-op "log" log))
             (list
              (unary-op "sinh" sin)
              (unary-op "cosh" cos)
              (unary-op "tanh" tan)
              (binary-op "expt" expt))))
           
           (panel-user-ops
            <panel>
            (list
             (list
              (list "Fn 1" (apply-user-def-fn 0) 'n-ary 0)
              (list "Fn 2" (apply-user-def-fn 1) 'n-ary 1)
              (list "Fn 3" (apply-user-def-fn 2) 'n-ary 2)
              (list "Configure" do-nothing 0 'conf))))

           (panel-digit-pad
            <panel>
            (list
             (list
              (unary-op "+-" -)
              (list "ENTER" do-nothing 0 'push-list)
              (list "DEL" del 'entry 'set-entry)
              (binary-op "complex" my-complex)
              (unary-op "Re" my-real-part)
              (unary-op "Im" my-imag-part))
             (list
              (list "7" (ins "7") 'entry 'set-entry)
              (list "8" (ins "8") 'entry 'set-entry)
              (list "9" (ins "9") 'entry 'set-entry)
              (binary-op "/" /))
             (list
              (list "4" (ins "4") 'entry 'set-entry)
              (list "5" (ins "5") 'entry 'set-entry)
              (list "6" (ins "6") 'entry 'set-entry)
              (binary-op "*" *))
             (list
              (list "1" (ins "1") 'entry 'set-entry)
              (list "2" (ins "2") 'entry 'set-entry)
              (list "3" (ins "3") 'entry 'set-entry)
              (binary-op "-" -))
             (list
              (list "0" (ins "0") 'entry 'set-entry)
              (list "." (ins ".") 'entry 'set-entry)
              (list "SPC" (ins " ") 'entry 'set-entry)
              (binary-op "+" +))))
           
           (lst-panels1
            (:uniform-list <panel>)
            (list panel-user-ops panel-stack-ops panel-trans-ops
                  panel-digit-pad))
           
           (str-app-name "org.tohoyn.calc")
           (app (gtk-application-new str-app-name null))
           
           (activate-my-app
            (lambda (((args (rest <object>))) <object> nonpure)
              (let-mutable ((exc1 <object> #f))
                (let ((conf-result?
                       (guard-general-nonpure exc
                         (begin
                          (set! exc1 exc)
                          (for-each1 plugin-function-reset
                                     (field-ref plugin-model 'l-functions))
                          #f)
                         (begin
                          (load-plugin-config plugin-model)
                          #t))))
                  (if conf-result?
                      (make-calculator app lst-panels1 plugin-model)
                      (report-load-config-error
                       exc1
                       app
                       (lambda (() <none> nonpure)
                         (make-calculator app lst-panels1 plugin-model))))))          
              #f)))
      
      ;; (g-set-prgname str-app-name)
      
      (gtype-instance-signal-connect
       app 'activate activate-my-app)
      
      ;; (let ((status (g-application-run app 0 #f)))
      (let ((status (run app null)))
        status))))
