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

;; Copyright (C) 2020, 2024 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))


(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>))
      (begin
       (if (not (null? l-supers))
         (display
          `(define-goops-class ,s-target-name
             (target-name ,s-target-name)
             ;; Multiple inheritance is not allowed in Theme-D.
             (superclass ,(car l-supers)))
          op)
         (display
          `(define-goops-class ,s-target-name
             (target-name ,s-target-name))
          op))
       (newline op)))))


(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))
      (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))
          (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-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-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)))
    (display `(define ,s-target-name <pointer>)
             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)))
    (display `(define ,s-target-name <pointer>)
             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)))
    (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 pure))
         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-interface generator str-module-name 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)
  (display "(import-and-reexport (theme-d-intr support))" op)
  (newline op)
  (let ((l-entities (reverse (slot-ref generator 'l-all-entities))))
    (for-each (lambda (ent)
                      (if (is-a? ent <intr-type>)
                        (generate-entity-output generator ent op)))
              l-entities)
    (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)
    (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 ((i-args (length args)))
    (if (not (or (= i-args 3) (= i-args 4)))
      (begin
       (display "Invalid number of arguments.\n")
       (exit 1)))
    (let ((str-namespace (list-ref args 1))
          (str-type-name (list-ref args 2))
          (str-version (if (= i-args 4) (list-ref args 3) "")))
      (let ((generator (make <golf-generator>
                             #:l-rejected-functions '()
                             #:l-rejected-methods '()
                             #:l-overridden-functions '()
                             #:l-strip-boolean-result '()
                             #:l-explicit-names '()
                             #:al-versions '()
                             #:generate-methods? #f
                             #:check-procedures? #f
                             #:debug? #f)))
        (if (not (string-null? str-version))
          (g-irepository-require str-namespace #:version str-version)
          (g-irepository-require str-namespace))
        (let* ((info (g-irepository-find-by-name str-namespace str-type-name))
               (intr-callback (gi-make-callback-entry info generator))
               (sx-proc-type
               `(:procedure
                 ,(slot-ref intr-callback 'l-argument-types)
                 ,(slot-ref intr-callback 'x-return-type))))
          (flush-all-ports)
          (display (slot-ref intr-callback 's-target-name))
          (display " = ")
          (display sx-proc-type)
          (newline))))))

                             
