#!@theme_d_guile@ \
-e main -s
!#

;; Copyright (C) 2020, 2024, 2026 Tommi Höynälänmaa

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

;; 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/.


;; (eval-when (expand load eval)
;;   (use-modules (oop goops))

;;   (default-duplicate-binding-handler
;;     '(merge-generics replace warn-override-core warn last))

;;   (use-modules (g-golf)))

(use-modules (oop goops))

(default-duplicate-binding-handler
  '(merge-generics replace warn-override-core warn last))

;; (use-modules (g-golf))

(use-modules (g-golf gi))

(use-modules (guile-theme-d-intr-support code-generation))
(use-modules (th-scheme-utilities hrecord))
(use-modules (th-scheme-utilities parse-command-line))
(use-modules (th-scheme-utilities stdutils))
(use-modules (rnrs))


(define (singleton-get-element sgt)
  (vector-ref sgt 0))


(define (singleton-set-element! sgt x)
  (vector-set! sgt 0 x))


(define (search-entity l-all-types s-name)
  (dpl "search-entity")
  (dpl s-name)
  (find
   (lambda (intr)
     (eq? s-name (slot-ref intr 's-target-name)))
   l-all-types))


(define (order-classes1 l-all-types sgt intr-class l-visited)
  ;;   (display "order-classes1 ENTER")
  ;;   (display (slot-ref intr-class 's-target-name))
  ;;   (newline)
  (strong-assert (is-a? intr-class <intr-object>))
  (dpl "order-classes1")
  (dpl (slot-ref intr-class 's-target-name))
  (if (not (eq? (slot-ref intr-class 's-target-name) '<gobject>))
    (cond
      ((memq intr-class l-visited)
       (raise (list 'cyclic-inheritance (cons 'intr-class intr-class))))
      ((not (memq intr-class (singleton-get-element sgt)))
       (let* ((search (lambda (s-type) (search-entity l-all-types s-type)))
              (l-supers0 (slot-ref intr-class 'l-supers))
              (l-supers (delq '<gobject> l-supers0))
              (l-intr-supers
               (map search l-supers))
              (l-new-visited (cons intr-class l-visited))
              (proc
               (lambda (intr1)
                 (order-classes1 l-all-types sgt intr1
                                 l-new-visited))))
         ;;    (display "order-classes1/1\n")
         ;;    (display (slot-ref intr-class 'l-supers))
         ;;    (newline)
         ;;    (display l-property-types)
         ;;    (newline)
         (if (memq #f l-intr-supers)
           (raise (list 'internal-error-with-superclasses
                        (cons 'intr intr-class))))
         (for-each proc l-intr-supers)
         (singleton-set-element!
          sgt
          (cons intr-class (singleton-get-element sgt))))))))
  

(define-method (order-classes l-all-types)
;;   (display "order-classes ENTER\n")
;;   (display (length l-all-types))
;;   (newline)
  (let ((sgt (vector '())))
    (for-each
     (lambda (intr)
       (order-classes1 l-all-types sgt intr '()))
     l-all-types)
    ;; (display "order-classes EXIT\n")
    ;; (display (length (singleton-get-element sgt)))
    ;; (newline)
    (singleton-get-element sgt)))


(define (get-all-classes generator)
  (filter (lambda (intr) (is-a? intr <intr-object>))
          (slot-ref generator 'l-all-entities)))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-object>)
                (op <output-port>))
  (let ((s-target-name (slot-ref intr 's-target-name))
        (l-supers (slot-ref intr 'l-supers)))
    ;; <gobject> is defined in the support module.
    (if (not (eq? s-target-name '<gobject>))
      (let ((l-slots (cons 'slots (generate-slots generator intr))))
        (if (not (null? l-supers))
          (display
           `(define-foreign-goops-class ,s-target-name
              (target-name ,s-target-name)
              ;; Multiple inheritance is not allowed in Theme-D.
              (superclass ,(car l-supers))
              (make-access hidden)
              ,l-slots)
           op)
          (display
           `(define-foreign-goops-class ,s-target-name
              (target-name ,s-target-name)
              (make-access hidden)
              ,l-slots)
           op))
        (newline op)))))


(define-method (generate-slots (generator <golf-generator>) 
                               (intr-object <intr-object>))
  (let ((l-properties (slot-ref intr-object 'l-properties)))
    (let* ((s-class-name (slot-ref intr-object 's-target-name))
           (al1
            (assq s-class-name
                  (slot-ref generator 'al-ignored-slots))))
      ;; We declare slot references as nonpure in case the introspected
      ;; properties have nonpure slot references.
      (delq #f 
            (map
             (lambda (intr-property)
               (let ((s-prop-name (string->symbol (slot-ref intr-property 'str-name))))
                 (if (or (not al1) (not (memq s-prop-name (cdr al1))))
                   `(,s-prop-name
                     ,(slot-ref intr-property 's-property-class)
                      public
                      public
                      no-init-value
                      nonpure-ref)
                   #f)))
             l-properties)))))

 
(define-method (compute-return-type (intr <intr-function>))
  (let ((n (slot-ref intr 'n-return-values))
        (x-return-type (slot-ref intr 'x-return-type)))
    (cond
      ((= n 0) '<none>)
      ((= n 1) x-return-type)
      (else
       (assert (list? x-return-type)) 
       (cons ':tuple x-return-type)))))


(define-method (generate-normal-function
                (generator <golf-generator>) (intr <intr-function>)
                (op <output-port>))
  (let ((l-argument-types (slot-ref intr 'l-argument-types))
        (x-return-type (compute-return-type intr))
        (s-name (slot-ref intr 's-target-name)))
    (display
     `(declare ,s-name
                (:simple-proc ,l-argument-types ,x-return-type
                               nonpure))
     op)
    (newline op)
    (if (and (slot-ref generator 'generate-methods?)
             (slot-ref intr 'method?)
             (suitable-for-method? l-argument-types))
            ;;  (or (not (slot-ref generator 'only-exported-methods?))
            ;;      (memq (slot-ref intr 'x-object-type)
            ;;            (slot-ref generator 'l-exported-types))))
      (let ((s-method-name (get-method-name intr)))
        (if (and (not-null? s-method-name)
                 (not (memq s-method-name
                            (slot-ref generator 'l-rejected-methods))))
          (begin
           (display
            `(declare-virtual-method
              ,s-method-name
               (:simple-proc ,l-argument-types
                              ,x-return-type nonpure))
            op)
           (newline op)))))))


(define-method (generate-overridden-function
                (generator <golf-generator>) (intr <intr-function>)
                (op <output-port>))
  (let* ((s-name (slot-ref intr 's-target-name))
         (p (assq s-name (slot-ref generator 'l-overridden-functions))))
    (assert (and (pair? p) (list? (cdr p)) (= (length (cdr p)) 3)))
    (let* ((l (cdr p))
           (l-argument-types (car l))
           (x-return-type0 (cadr l))
           (x-attr (caddr l))
           (x-return-type
            (if (and (list? x-return-type0)
                     (not-null? x-return-type0)
                     (eq? (car x-return-type0) ':tuple))
              (cons ':tuple (cdr x-return-type0))
              x-return-type0)))
      (display
       `(declare ,s-name
                  (:simple-proc ,l-argument-types ,x-return-type ,x-attr))
       op)
      (newline op)
      (let ((l-argument-types (car l)))
        (if (and (slot-ref generator 'generate-methods?)
                 (slot-ref intr 'method?)
                 (suitable-for-method? l-argument-types))
                ;;  (or (not (slot-ref generator 'only-exported-methods?))
                ;;      (memq (slot-ref intr 'x-object-type)
                ;;            (slot-ref generator 'l-exported-types))))
          (let ((s-method-name (get-method-name intr)))
            (if (and (not-null? s-method-name)
                     (not (memq s-method-name
                                (slot-ref generator 'l-rejected-methods))))
              (begin
               (display
                `(declare-virtual-method
                  ,s-method-name
                   (:simple-proc ,l-argument-types
                                  ,x-return-type ,x-attr))
                op)
               (newline op)))))))))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-function>)
                (op <output-port>))
  (let ((s-name (slot-ref intr 's-target-name)))
    (if (not (memq s-name (slot-ref generator 'l-rejected-functions)))
      (if (not (assq s-name (slot-ref generator 'l-overridden-functions)))
        (generate-normal-function generator intr op)
        (generate-overridden-function generator intr op)))))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-callback>)
                (op <output-port>))
  (let* ((s-target-name (slot-ref intr 's-target-name))
         (l-argument-types (slot-ref intr 'l-argument-types))
         (sx-return-type0 (slot-ref intr 'x-return-type))
         (sx-return-type
          (if (list? sx-return-type0)
            (cons ':tuple sx-return-type0)
            sx-return-type0)))
    (display
     `(define ,s-target-name
        (:procedure ,l-argument-types ,sx-return-type nonpure))
     op)
    (newline op)))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-struct>)
                (op <output-port>))
  (let ((s-target-name (slot-ref intr 's-target-name)))
    (if (or (slot-ref intr 'is-opaque?) (slot-ref intr 'is-semi-opaque?))
      ;; (display
      ;;  `(define-foreign-goops-class ,s-target-name
      ;;     (target-name ,s-target-name)
      ;;     (superclass <object>))
      ;;  op)
      (display `(define ,s-target-name <pointer>)
               op)
      (let ((l-field-types (slot-ref intr 'l-field-types)))
        (display
         `(define ,s-target-name (:tuple ,@l-field-types))
         op)))
    (newline op)))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-union>)
                (op <output-port>))
  (let ((s-target-name (slot-ref intr 's-target-name)))
    ;;    (display `(define ,s-target-name <pointer>)
    ;;             op)
    (display
     `(define-foreign-goops-class ,s-target-name
        (target-name ,s-target-name)
        (superclass <object>))
     op)
    (newline op)))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-enum>)
                (op <output-port>))
  (let* ((s-target-name (slot-ref intr 's-target-name))
         (l-sx-singleton-types
          (map (lambda (p) (list ':singleton-type `(quote ,(car p))))
               (slot-ref intr 'al-values)))
         (sx-type (cons ':union l-sx-singleton-types)))
    (display `(define ,s-target-name ,sx-type)
             op)
    (newline op)))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-flags>)
                (op <output-port>))
  (let* ((s-target-name (slot-ref intr 's-target-name))
         (s-component-type (slot-ref intr 's-component-type))
         (l-sx-singleton-types
          (map (lambda (p) (list ':singleton-type `(quote ,(car p))))
               (slot-ref intr 'al-values)))
         (sx-type1 (cons ':union l-sx-singleton-types)))
    (display `(define ,s-component-type ,sx-type1)
             op)
    (newline op)
    (display `(define ,s-target-name (:uniform-list ,s-component-type))
             op)
    (newline op)))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-interface>)
                (op <output-port>))
  (let ((s-target-name (slot-ref intr 's-target-name)))
    (display `(define ,s-target-name <object>)
             op)
    (newline op)))


(define-method (generate-entity-output
                (generator <golf-generator>) (intr <intr-property>)
                (op <output-port>))
  
  ;; TBR
  ;; (display "Class: ")
  ;; (display (slot-ref intr 's-class-name))
  ;; (newline)
  ;; (display "Property class: ")
  ;; (display (slot-ref intr 's-property-class))
  ;; (newline)
  
  (let* ((s-class-name (slot-ref intr 's-class-name))
         (s-property-class (slot-ref intr 's-property-class))
         (al1
          (assq s-class-name
                (slot-ref generator 'al-ignored-slots)))
         (s-prop-name (string->symbol (slot-ref intr 'str-name))))
    (if (or (not al1) (not (memq s-prop-name (cdr al1))))
      (begin
       (if (slot-ref intr 'has-getter?)
         (let ((s-getter-name (slot-ref intr 's-getter-name)))
           (display
            `(declare ,s-getter-name
                       (:simple-proc (,s-class-name) ,s-property-class nonpure))
            op)
           (newline op)))
       (if (slot-ref intr 'has-setter?)
         (let ((s-setter-name (slot-ref intr 's-setter-name)))
           (display
            `(declare ,s-setter-name
                       (:simple-proc (,s-class-name ,s-property-class) <none>
                                     nonpure))
            op)
           (newline op)))))))


(define (generate-fw-class-decl intr op)
  (let ((s-target-name (slot-ref intr 's-target-name)))
    ;; <gobject> is defined in the support module.
    (if (not (eq? s-target-name '<gobject>))
      (begin
       (if (or (is-a? intr <intr-enum>) (is-a? intr <intr-flags>))
         (display `(declare ,s-target-name :union) op)
         (display `(declare ,s-target-name <normal-class>) op))
       (newline op)))))
    

(define (generate-interface generator str-module-name l-import op)
  (display "(define-interface " op)
  (display str-module-name op)
  (newline op)
  (display "(import (standard-library core))" op)
  (newline op)
  (display "(import (standard-library bytevector))" op)
  (newline op)
  (if (slot-ref generator 'no-recursion?)
    (display "(import (theme-d-intr base support))" op)
    (display "(import-and-reexport (theme-d-intr base support))" op))
  (newline op)
  (if (not-null? l-import)
    (begin
     (display "(import\n" op)
     (for-each
      (lambda (sx-module)
        (display sx-module op)
        (newline op))
      l-import)
     (display ")\n" op)))
  (let* ((l-entities (reverse (slot-ref generator 'l-all-entities)))
         (l-classes
          (if (slot-ref generator 'no-recursion?)
            (reverse (get-all-classes generator))
            (reverse (order-classes (get-all-classes generator))))))
    (for-each (lambda (ent)
                (generate-fw-class-decl ent op))
              l-classes)
    (for-each (lambda (ent)
                (if (and (is-a? ent <intr-type>)
                         (not (is-a? ent <intr-object>)))
                  (generate-entity-output generator ent op)))
              l-entities)
    (for-each (lambda (ent)
                (generate-entity-output generator ent op))
              l-classes)
    (for-each (lambda (ent)
                (if (is-a? ent <intr-callback>)
                  (generate-entity-output generator ent op)))
              l-entities)
    (for-each (lambda (ent)
                (if (is-a? ent <intr-function>)
                  (generate-entity-output generator ent op)))
              l-entities)
    (if (slot-ref generator 'generate-accessors?)
      (for-each (lambda (ent)
                  (if (is-a? ent <intr-property>)
                    (generate-entity-output generator ent op)))
                l-entities)))
  (display ")\n" op))


(define (main args)
  (let ((str-input-file "intr-imports.scm")
        (str-output-file "_intr-imports.thi")
        (str-module-name "_intr-imports")
        (generate-methods? #t)
        (generate-accessors? #f)
        (check-procedures? #t)
        (only-exported-entities? #f)
        (test-errors? #f))
    (let* ((argdesc1 (make-hrecord <argument-descriptor>
                                   "no-methods" #f
                                   (lambda () (set! generate-methods? #f))))
           (argdesc2 (make-hrecord <argument-descriptor>
                                   "no-check" #f
                                   (lambda () (set! check-procedures? #f))))
           (argdesc3 (make-hrecord <argument-descriptor>
                                   #\i #t
                                   (lambda (str-arg)
                                           (set! str-input-file str-arg))))
           (argdesc4 (make-hrecord <argument-descriptor>
                                   #\o #t
                                   (lambda (str-arg)
                                           (set! str-output-file str-arg))))
           (argdesc5 (make-hrecord <argument-descriptor>
                                   #\m #t
                                   (lambda (str-arg)
                                           (set! str-module-name str-arg))))
           (argdesc6 (make-hrecord <argument-descriptor>
                                   "test-errors" #f
                                   (lambda ()
                                           (set! test-errors? #t))))
           (argdesc7 (make-hrecord <argument-descriptor>
                                   "generate-accessors" #f
                                   (lambda ()
                                           (set! generate-accessors? #t))))
           (argdesc8 (make-hrecord <argument-descriptor>
                                   "only-exported-entities" #f
                                   (lambda ()
                                           (set! only-exported-entities? #t))))
           (argdesc9 (make-hrecord <argument-descriptor>
                                   #\e #f
                                   (lambda ()
                                           (set! only-exported-entities? #t))))
           (l-arg-descs (list argdesc1 argdesc2 argdesc3 argdesc4 argdesc5
                              argdesc6 argdesc7 argdesc8 argdesc9))
           (args-without-cmd (cdr args))
           (handle-proper-args (lambda (proper-args)
                                       (if (not (= (length proper-args) 0))
                                         (raise 'command-line-syntax-error)))))
      (parse-command-line args-without-cmd l-arg-descs handle-proper-args)
      (let* ((l-data (get-golf-imports str-input-file))
             (l-only-types
              (let ((x1 (assq 'only-types l-data)))
                (if x1 (cdr x1) '())))
             (l-types
              (cond
                ((assq 'types l-data) => (lambda (p1) (cdr p1)))
                ((assq 'classes l-data) => (lambda (p1) (cdr p1)))
                (else '())))
             (l-functions
              (let ((x1 (assq 'functions l-data)))
                (if x1 (cdr x1) '())))
             (l-rejected-functions
              (let ((x1 (assq 'rejected-functions l-data)))
                (if x1 (cdr x1) '())))
             (l-rejected-methods
              (let ((x1 (assq 'rejected-methods l-data)))
                (if x1 (cdr x1) '())))
             (l-overridden-functions
              (let ((x1 (assq 'overridden-functions l-data)))
                (if x1 (cdr x1) '())))
             (l-strip-boolean-result
              (let ((x1 (assq 'strip-boolean-result l-data)))
                (if x1 (cdr x1) '())))
             (l-explicit-names
              (process-explicit-names
               (let ((x1 (assq 'explicit-names l-data)))
                 (if x1 (cdr x1) '()))))
             (l-import
              (let ((x1 (assq 'import l-data)))
                (if x1 (cdr x1) '())))              
             (al-ignored-slots (parse-ignored-slots l-data))
             (al-versions (get-namespace-versions l-data)))
        (let ((generator (make <golf-generator>
                               #:l-rejected-functions l-rejected-functions
                               #:l-rejected-methods l-rejected-methods
                               #:l-overridden-functions l-overridden-functions
                               #:l-strip-boolean-result l-strip-boolean-result
                               #:l-explicit-names l-explicit-names
                               #:al-ignored-slots al-ignored-slots
                               #:al-versions al-versions
                               #:generate-methods? generate-methods?
                               #:check-procedures? check-procedures?
                               #:generate-accessors? generate-accessors?
                               #:only-exported-entities? only-exported-entities?
                               ;; Note the following.
                               #:no-recursion? only-exported-entities?
                               #:debug? #f))
              (l-req-repositories '()))
          (for-each
           (lambda (p)
                   (let* ((str-namespace (symbol->string (car p)))
                          (str-entity (symbol->string (cadr p)))
                          (methods? (not (memq p l-only-types))))
                     (if (not (member str-namespace l-req-repositories))
                       (let ((str-version
                              (let ((p2 (assoc str-namespace al-versions)))
                                (if p2 (cdr p2) ""))))
                         (if (string-null? str-version)
                           (g-irepository-require str-namespace)
                           (g-irepository-require str-namespace
                                                  #:version str-version))
                         (set! l-req-repositories
                           (cons str-namespace l-req-repositories))))
                     (let ((info (g-irepository-find-by-name
                                  str-namespace str-entity)))

                       ;; TBR
                       (if (equal? str-entity "TextTag")
                         (dpl "TextTag HEP"))
                       (dp "import: ")
                       (dpl str-entity)
                       
                       (if info
                         (gi-import-info1 info generator #t methods?)
                         (raise (list 'nonexistent-entity
                                      (cons 'str-namespace str-namespace)
                                      (cons 'str-entity str-entity)))))))
           (append l-only-types l-types l-functions))
          
          (if (file-exists? str-output-file) (delete-file str-output-file))
          (let ((op (open-output-file str-output-file)))
            ;; (guard (exc (else
            ;;              (backtrace)
            ;;              (guard (exc2 (else '()))
            ;;                     (close-output-port op)
            ;;                     (delete-file str-output-file))
            ;;              (cond
            ;;                ((symbol? exc)
            ;;                 (display "Error: ")
            ;;                 (display exc)
            ;;                 (newline))
            ;;                ((and (list? exc) (not-null? exc)
            ;;                      (symbol? (car exc)))
            ;;                 (display "Error: ")
            ;;                 (display (car exc))
            ;;                 (newline))
            ;;                (else
            ;;                 (display "Error")
            ;;                 (newline)))
            ;;              (raise exc)))
                   (generate-interface generator str-module-name l-import op)
                   (if test-errors? (raise 'test))
            (close-output-port op))
          0)))))

