;; -*-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-model)


  (import (standard-library string-utilities)
          (standard-library list-utilities)
          (standard-library dynamic-list)
          (standard-library object-string-conversion)
          (standard-library text-file-io)
          (standard-library system))

  (import (intr-gtk4-examples calc2 utils))


  (define gl-i-nr-user-fns 3)
  (define gl-i-max-nargs 100)
  (define gl-str-rc-path ".theme-d-intr-calc2")
  (define gl-str-config-filename "config.scm")
  (define gl-str-plugin-dir "plugins")


  (define-simple-method get-config-path (() <string> pure)
    (match-type (getenv "HOME")
      ((str-home <string>)
       (string-append str-home "/" gl-str-rc-path "/" gl-str-config-filename))
      (else
       (string-append gl-str-rc-path "/" gl-str-config-filename))))


  (define-simple-method get-plugin-directory (() <string> pure)
    (match-type (getenv "HOME")
      ((str-home <string>)
       (string-append str-home "/" gl-str-rc-path "/" gl-str-plugin-dir))
      (else
       (string-append gl-str-rc-path "/" gl-str-plugin-dir))))


  (define-simple-method make-function-models
      (((i-count <integer>)) (:uniform-list <plugin-function-model>) pure)
    (assert (>= i-count 0))
    (cond
     ((equal? i-count 0) null)
     ((> i-count 0)
      (cons (create <plugin-function-model> #f #f -1 #f #f )
            (make-function-models (- i-count 1))))
     (else
      ;; We should never arrive here.
      (raise-simple 'internal-error))))
      

  (define-simple-method compute-plugin-list
      (() (:uniform-list <symbol>) nonpure)
    (dwln 'debug1 "compute-plugin-list ENTER")
    (guard-general-nonpure exc
      null
      (let* ((str-plugin-directory (get-plugin-directory))
             (tmp1 (begin (dwln 'debug1 "compute-plugin-list/0-1") #f))
             (tmp2 (begin (dwln 'debug1 str-plugin-directory) #f))
             (x-dir-contents0
              (get-plain-file-tree str-plugin-directory))
             (tmp3 (begin (dwln 'debug1 "compute-plugin-list/0-2") #f))
             (tmp4 (begin (dwln 'debug1 x-dir-contents0) #f))
             (x-dir-contents (d-cadr x-dir-contents0)))
        (dwln 'debug1 "compute-plugin-list/1")
        (let-mutable ((l-result (:uniform-list <symbol>) null))
          (d-for-each1
           (lambda (((x <object>)) <none> nonpure)
             (match-type-weak x
               ((str <string>)
                (if (and (> (string-length str) 3)
                         (equal? (string-take-right str 3) ".go"))
                    (set! l-result
                      (append-uniform2 l-result
                                       (list (string->symbol (string-drop-right str 3)))))))))
           x-dir-contents)
          (dwln 'debug1 "compute-plugin-list EXIT")
          l-result))))
  

  (define-simple-method get-plugin-string-list
      (((plugin-model <plugin-model>)) <gtk-string-list> nonpure)
    (let ((string-list (gtk-string-list-new #f)))
      (gtk-string-list-append string-list "(nothing)")
      (iterate-list
          (s-cur-plugin <symbol> (field-ref plugin-model 'l-s-plugins))
        (gtk-string-list-append string-list (symbol->string s-cur-plugin)))
      string-list))


  (define-simple-method get-plugin-proc-name
      (((foreign-var <foreign-var>)) <symbol> pure)
    (case (cadr foreign-var)
      ((normal-var) (get-exported-var-name (car foreign-var)))
      ((ngp) (get-exported-ngp-name (car foreign-var)))
      ((vgp) (get-exported-vgp-name (car foreign-var)))
      (else
       ;; We should never arrive here.
       (raise2 'internal-error))))


  (define-simple-method plugin-function-reset
      (((plugin-function-model <plugin-function-model>)) <none> nonpure)
    (field-set! plugin-function-model 's-cur-plugin #f)
    (field-set! plugin-function-model 'foreign-var-cur #f)
    (field-set! plugin-function-model 'i-nargs -1)
    (field-set! plugin-function-model 'module-cur #f)
    (field-set! plugin-function-model 'proc-cur #f))


  (define-simple-method calc2-load-plugin
      (((s-plugin-name <symbol>)) <module> nonpure)
    (dwln 'debug2 "calc2-load-plugin ENTER")
    (dwln 'debug2 s-plugin-name)
    (let ((l-compiled-path (get-load-compiled-path)))
      (dwln 'debug2 "calc2-load-plugin/1")
      (set-load-compiled-path!
       (cons (get-plugin-directory)
             l-compiled-path))
      (dwln 'debug2 "calc2-load-plugin/2")
      (dwln 'debug2 (get-load-compiled-path))
      (let ((plugin
             (guard-general-nonpure exc
               (begin
                (dwln 'debug2 "calc2-load-plugin/3")
                (set-load-compiled-path! l-compiled-path)
                (dwln 'debug2 "calc2-load-plugin/4")
                (static-cast <module> (raise exc)))
               (load-plugin (list s-plugin-name)))))
        (dwln 'debug2 "calc2-load-plugin/5")
        (set-load-compiled-path! l-compiled-path)
        (dwln 'debug2 "calc2-load-plugin EXIT")
        plugin)))


  (define-simple-method foreign-var-exists?
      (((mod <module>) (foreign-var <foreign-var>)) <boolean> pure)
    (module-var-exists? mod (get-plugin-proc-name foreign-var)))


  (define-simple-method check-plugins
      (((plugin-function-model <plugin-function-model>)
        (l-s-plugins-new (:uniform-list <symbol>))) <none> nonpure)
    (dwln 'debug1 "check-plugins ENTER")
    (let* ((s-cur-plugin-old (field-ref plugin-function-model 's-cur-plugin))
           (s-cur-plugin-new
            (match-type s-cur-plugin-old
              ((s <symbol>)
               (if (member? s l-s-plugins-new) s #f))
              (else #f))))
      (match-type s-cur-plugin-new
        ((<boolean>)
         (dwln 'debug1 "check-plugins/1")
         (plugin-function-reset plugin-function-model))
        ((s-cur-plugin1 <symbol>)
         (dwln 'debug1 "check-plugins/2")
         (let ((mod
                (guard-general-nonpure exc
                  #f
                  (calc2-load-plugin s-cur-plugin1))))
           (match-type mod
             ((<boolean>)
              (plugin-function-reset plugin-function-model))
             ((mod1 <module>)
              (field-set! plugin-function-model 's-cur-plugin s-cur-plugin1)
              (match-type-weak (field-ref plugin-function-model 'foreign-var-cur)
                ((foreign-var-cur1 <foreign-var>)
                 (if (not (foreign-var-exists? mod1 foreign-var-cur1))
                     (begin
                     (field-set! plugin-function-model 'foreign-var-cur #f)
                     (field-set! plugin-function-model 'i-nargs -1)
                     (field-set! plugin-function-model 'proc-cur #f))))))))))))



  (define-simple-method handle-config-function-item
     (((plugin-model <plugin-model>) (sx-item <source-expr>)) <none> nonpure)
    (let* ((l-functions (field-ref plugin-model 'l-functions))
           (i-nr-functions (length l-functions)))
      (match-type sx-item
        ((l-sx1 (:tuple <symbol> <integer> <symbol>))
         ;; This branch requires no actions since the functions models are
         ;; initialized empty and no function number is allowed to occur twice.
         (if (or (not (equal? (car l-sx1) 'function))
                 (< (cadr l-sx1) 0)
                 (>= (cadr l-sx1) i-nr-functions)
                 (not (equal? (caddr l-sx1) 'nothing)))
             (raise-simple 'invalid-function-item-1)))
        ((l-sx2 (:tuple <symbol> <integer> <symbol> <symbol>
                        <foreign-var-type> <integer>))
         (let* ((s-keyword (car l-sx2))
                (i-fn (cadr l-sx2))
                (s-mod (caddr l-sx2))
                (s-function (tuple-ref l-sx2 3))
                (foreign-var-type (tuple-ref l-sx2 4))
                (i-nargs (tuple-ref l-sx2 5))
                (function-model (uniform-list-ref l-functions i-fn)))
           (cond
            ((not (equal? s-keyword 'function))
             (raise-simple 'invalid-keyword))
            ((not (and (>= i-fn 0) (< i-fn i-nr-functions)))
             (raise-simple 'invalid-user-function-number))
            ((not (and (>= i-nargs 0) (<= i-nargs gl-i-max-nargs)))
             (raise-simple 'invalid-nargs))
            ;; Do not allow duplicate function entries for the same index.
            ((or (not-false? (field-ref function-model 's-cur-plugin))
                 (not-false? (field-ref function-model 'foreign-var-cur))))
            (else
             (guard-general-nonpure exc
               ;; No need to reset the function model here.
               #f
               (let ((module (calc2-load-plugin s-mod))
                     (foreign-var (list s-function foreign-var-type)))
                 (if (foreign-var-exists? module foreign-var)
                     (begin
                      (field-set! function-model 's-cur-plugin s-mod)
                      (field-set! function-model 'foreign-var-cur foreign-var)
                      (field-set! function-model 'i-nargs i-nargs)
                      (field-set! function-model 'module-cur module)
                      (field-set!
                       function-model 'proc-cur
                       (module-ref module
                                   (get-plugin-proc-name foreign-var)))))))))))
        (else (raise-simple 'invalid-function-item-2)))))


  ;; This method initializes the plugin model.
  (define-simple-method load-plugin-config
      (((plugin-model <plugin-model>))
       <none> nonpure)
    (assert (>= gl-i-nr-user-fns 0))
    (field-set! plugin-model 'l-s-plugins (compute-plugin-list))
    (field-set! plugin-model 'l-functions (make-function-models gl-i-nr-user-fns))
    (let ((str-config-path (get-config-path)))
      (if (not (string-empty? str-config-path))
          (let* ((ip (open-input-file str-config-path))
                 (l-sx-contents (read-all ip)))
            (close-input-port ip)
            (cond
             ((null? l-sx-contents)
              (raise-simple 'empty-config-file))
             ((not (null? (d-cdr l-sx-contents)))
              (raise-simple 'extra-contents-in-config-file))
             (else
              (let ((sx-expr (uniform-list-ref l-sx-contents 0)))
                (match-type sx-expr
                  ((l-sx-functions (:nonempty-uniform-list <source-expr>))
                   (if (equal? (car l-sx-functions) 'user-functions)
                       (for-each1
                        (lambda (((sx-subexpr <source-expr>)) <none> nonpure)
                          (handle-config-function-item plugin-model
                                                       sx-subexpr))
                        (cdr l-sx-functions))
                       (raise-simple 'invalid-config-file-1)))
                  (else (raise-simple 'invalid-config-file-2))))))))))
  

  (define-simple-method compute-function-config-item
      (((i-index <integer>) (function-model <plugin-function-model>))
       <source-expr-list> pure)
    (if (or (not-object (field-ref function-model 's-cur-plugin))
            (not-object (field-ref function-model 'foreign-var-cur)))
        (list 'function i-index 'nothing)
        (let ((foreign-var-cur
               (cast <foreign-var>
                     (field-ref function-model 'foreign-var-cur))))
          (list 'function
                i-index
                (field-ref function-model 's-cur-plugin)
                (car foreign-var-cur)
                (cadr foreign-var-cur)
                (field-ref function-model 'i-nargs)))))
    

  (define-simple-method save-plugin-config
    (((plugin-model <plugin-model>))
     <none> nonpure)
    (assert (>= gl-i-nr-user-fns 0))
    (let ((l-functions (field-ref plugin-model 'l-functions)))
      (strong-assert (equal? (length l-functions) gl-i-nr-user-fns))
      (let-mutable ((l-sx-target <source-expr-list> null))
        (do ((i <integer> 0 (+ i 1))) ((>= i gl-i-nr-user-fns))
          (set! l-sx-target
            (append-uniform2
             l-sx-target
             (list (compute-function-config-item i (uniform-list-ref l-functions i))))))
        (let ((op (open-output-file (get-config-path))))
          (write op (cons 'user-functions l-sx-target))
          (newline op)
          (close-output-port op))))))


