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

;; Copyright (C) 2020, 2022 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 (rnrs))
(use-modules (rnrs exceptions))
(use-modules (th-scheme-utilities hrecord))
(use-modules (th-scheme-utilities parse-command-line))
(use-modules (th-scheme-utilities stdutils))
(use-modules (srfi srfi-1))

(define (make-setter s-setter s-accessor)
  `(define-public (,s-setter x-self x-value)
     (set! (,s-accessor x-self) x-value)))


(define (make-arg-var i)
  (string->symbol (string-append "arg" (number->string i))))


(define-method (generate-cb-mult
                (generator <golf-generator>)
                (l-argument-types <list>))
  (let ((al-callbacks (slot-ref generator 'al-callbacks)))
    (map (lambda (sx-arg)
                 (and (symbol? sx-arg)
                      (let ((p (assq sx-arg al-callbacks)))
                        (if p (cdr p) #f))))
         l-argument-types)))

(define (generate-arg-var-list i-count i-first)
  ;; (assert (>= i-count 0))
  (if (= i-count 0)
    '()
    (cons (make-arg-var i-first)
          (generate-arg-var-list (- i-count 1) (+ i-first 1)))))


(define (generate-arg-wrapper s-var cb-mult?)
  (if cb-mult?
    `(lambda l-callback-args
             (apply values
               (_i_call-proc ,s-var
                              l-callback-args
                              (map theme-type-of l-callback-args))))
    `(lambda l-callback-args
             (_i_call-proc ,s-var
                            l-callback-args
                            (map theme-type-of l-callback-args)))))


(define (generate-arg-wrappers l-arg-vars l-are-callback-args l-cb-mult)
  (assert (= (length l-arg-vars) (length l-are-callback-args)))
  (assert (= (length l-arg-vars) (length l-cb-mult)))
  (map 
   (lambda (s-var callback? cb-mult?)
           (assert (symbol? s-var))
           (assert (boolean? callback?))
           (if callback? (generate-arg-wrapper s-var cb-mult?) s-var))
   l-arg-vars l-are-callback-args l-cb-mult))


(define-method (get-wrapper-func-name (intr <intr-function>))
  (string->symbol
    (string-append
     "_wrapper-"
     (symbol->string (slot-ref intr 's-target-name)))))


(define-method (function-needs-wrapper? (intr <intr-function>))
  (or                          
   (> (slot-ref intr 'n-return-values) 1)
   (exists (lambda (b) (eq? b #t))
           (slot-ref intr 'l-are-callback-args))))


(define-method (reexport-entity
                (generator <golf-generator>) (intr <intr-entity>)
                (op <output-port>))
  (let ((s-target-name (slot-ref intr 's-target-name)))
    (if (and
         (not (memq s-target-name (slot-ref generator 'l-rejected-functions)))
         (not (and (is-a? intr <intr-function>)
                   (function-needs-wrapper? intr))))
      (begin
       (display s-target-name op)
       (newline op)))))


(define-method (generate-wrapper
                (generator <golf-generator>)
                (intr <intr-function>)
                (multiple-return-values? <boolean>)
                (callback-arguments? <boolean>)
                (i-arg-count <integer>)
                (l-are-callback-args <list>)
                (l-cb-mult <list>)
                (op <output-port>))
  (assert (or multiple-return-values? callback-arguments?))
  (let ((s-target-name (slot-ref intr 's-target-name))
        (s-wrapper-name (get-wrapper-func-name intr)))
    (cond
      ((and multiple-return-values? (not callback-arguments?))
       (let ((l-arg-vars
              (generate-arg-var-list i-arg-count 1)))
         (display
          `(define-public ,s-wrapper-name
             (lambda ,l-arg-vars
                      (receive vals (,s-target-name ,@l-arg-vars) 
                               vals)))
          op)))
      ((and multiple-return-values? callback-arguments?)
       (let* ((l-arg-vars
               (generate-arg-var-list i-arg-count 1))
              (l-arg-wrappers
               (generate-arg-wrappers
                l-arg-vars
                l-are-callback-args
                l-cb-mult)))
         (display
          `(define-public ,s-wrapper-name
             (lambda ,l-arg-vars
                      (receive vals (,s-target-name ,@l-arg-wrappers)
                               vals)))
          op)))
      ((and (not multiple-return-values?) callback-arguments?)
       (let* ((l-arg-vars
               (generate-arg-var-list i-arg-count 1))
              (l-arg-wrappers
               (generate-arg-wrappers
                l-arg-vars
                l-are-callback-args
                l-cb-mult)))
         (display
          `(define-public ,s-wrapper-name
             (lambda ,l-arg-vars
                      (,s-target-name ,@l-arg-wrappers)))
          op)))
      (else
       (raise 'logical-error)))
    (newline op)))


(define-method (generate-setter
                (generator <golf-generator>) (intr <intr-property>)
                (op <output-port>))
  (if (slot-ref intr 'has-setter?)
    (let* ((s-setter-name (slot-ref intr 's-setter-name))
           (s-accessor-name (slot-ref intr 's-accessor-name))
           (sx-setter (make-setter s-setter-name s-accessor-name)))
      (display sx-setter op)
      (newline op))))


(define (generate-target-module generator str-module-name decl? op)
  (display "(define-module " op)
  (display str-module-name op)
  (if decl? (display "#:declarative? #t" op))
  (display ")\n" op)
  (display "(import (theme-d runtime rte-base))\n" op)
  (display "(import (theme-d runtime runtime-theme-d-environment))\n" op)
  (display "(eval-when (expand load eval)\n" op)
  (display "(import (g-golf))\n" op)
  (display "(default-duplicate-binding-handler " op)
  (display
   "'(merge-generics replace warn-override-core warn last))\n" op)
  (display "(gi-method-short-name-skip-all)\n" op)
  (let ((l-entities (reverse (slot-ref generator 'l-all-entities)))
        (l-toplevel-functions (slot-ref generator 'l-toplevel-functions))
        (al-versions (slot-ref generator 'al-versions)))
    (for-each (lambda (ent)
                      (if (or
                           (is-a? ent <intr-type>)
                           (and (is-a? ent <intr-function>)
                                (memq ent l-toplevel-functions)))
                        (let* ((str-namespace (slot-ref ent 'str-namespace))
                               (str-name (slot-ref ent 'str-name))
                               (str-version
                                (let ((p (assoc str-namespace al-versions)))
                                  (if p (cdr p) #f))))
                          (cond
                            ((or (eq? str-version #f)
                                 (and (string? str-version)
                                      (string-null? str-version)))
                             (display
                              (string-append "(gi-import-by-name \""
                                             str-namespace
                                             "\" \""
                                             str-name
                                             "\")\n")
                              op))
                            ((string? str-version)
                             (display
                              (string-append "(gi-import-by-name \""
                                             str-namespace
                                             "\" \""
                                             str-name
                                             "\" #:version \""
                                             str-version
                                             "\")\n")
                              op))
                            (else (raise 'error-with-versions))))))
              l-entities)
    (display ")\n" op)
    (display "(re-export\n" op)
    
    ;; A hack.
    (display "<gobject>\n" op)
    
    (for-each (lambda (ent)
                      (if (or (is-a? ent <intr-object>)
                              (is-a? ent <intr-function>))
                        (reexport-entity generator ent op)))
              l-entities)
    (display ")\n" op)
    (for-each
     (lambda (ent)
             (if (is-a? ent <intr-function>)
               (let* ((s-name (slot-ref ent 's-target-name))
                      (p (assq s-name
                               (slot-ref generator 'l-overridden-functions))))
                 (if (not p)
                   (let ((multiple-return-values?
                          (> (slot-ref ent 'n-return-values) 1))
                         (callback-arguments?
                          (if (memq #t (slot-ref ent 'l-are-callback-args))
                            #t
                            #f)))
                     (if (or multiple-return-values? callback-arguments?)
                       (generate-wrapper generator
                                         ent
                                         multiple-return-values?
                                         callback-arguments?
                                         (length
                                          (slot-ref ent 'l-argument-types))
                                         (slot-ref ent 'l-are-callback-args)
                                         (generate-cb-mult
                                          generator
                                          (slot-ref ent 'l-argument-types))
                                         op)))
                   (let* ((l-argument-types (cadr p))
                          (x-return-type0 (caddr p))
                          (multiple-return-values?
                           (and (list? x-return-type0)
                                (not-null? x-return-type0)
                                (eq? (car x-return-type0) ':tuple)))
                          (l-are-callback-args
                           (map
                            (lambda (x)
                                    (if
                                      (or
                                       (assq x
                                             (slot-ref generator
                                                       'al-callbacks))
                                       (and (list? x)
                                            (not-null? x)
                                            (eq? (car x) ':procedure)))
                                      #t
                                      #f))
                            l-argument-types))
                          (callback-arguments?
                           (if (memq #t l-are-callback-args) #t #f)))
                     (if (or multiple-return-values? callback-arguments?)
                       (generate-wrapper generator
                                         ent
                                         multiple-return-values?
                                         callback-arguments?
                                         (length l-argument-types)
                                         l-are-callback-args
                                         (generate-cb-mult 
                                          generator
                                          l-argument-types)
                                         op)))))))
     l-entities)
    (for-each
     (lambda (s-proc)
             (if (symbol? s-proc)
               (begin
                (display (list 'gi-strip-boolean-result-add s-proc) op)
                (newline op))
               (raise (list 'invalid-proc-to-strip (cons 's-name s-proc)))))
     (slot-ref generator 'l-strip-boolean-result))
    (if (slot-ref generator 'generate-accessors?)
      (for-each (lambda (ent)
                  (if (is-a? ent <intr-property>)
                    (generate-setter generator ent op)))
                l-entities))))
  

(define (my-assq x l)
  (let ((p (assq x l)))
    (if p (cdr p) '())))


(define (main args)
  (let ((str-input-file "intr-imports.scm")
        (str-output-file "_intr-imports-target.scm")
        (str-module-name "(_intr-imports-target)")
        ;; Declarative modules can be used only with Guile 3.0.
        (declarative? #f)
        (generate-methods? #t)
        (generate-accessors? #f)
        (check-procedures? #t)
        (test-errors? #f))
    (let* ((argdesc1 (make-hrecord <argument-descriptor>
                                   "declarative" #f
                                   (lambda () (set! declarative? #t))))
           (argdesc2 (make-hrecord <argument-descriptor>
                                   #\i #t
                                   (lambda (str-arg)
                                           (set! str-input-file str-arg))))
           (argdesc3 (make-hrecord <argument-descriptor>
                                   #\o #t
                                   (lambda (str-arg)
                                           (set! str-output-file str-arg))))
           (argdesc4 (make-hrecord <argument-descriptor>
                                   #\m #t
                                   (lambda (str-arg)
                                           (set! str-module-name str-arg))))
           (argdesc5 (make-hrecord <argument-descriptor>
                                   "test-errors" #f
                                   (lambda ()
                                           (set! test-errors? #t))))
           (argdesc6 (make-hrecord <argument-descriptor>
                                   "generate-accessors" #f
                                   (lambda ()
                                           (set! generate-accessors? #t))))
           (l-arg-descs (list argdesc1 argdesc2 argdesc3 argdesc4 argdesc5
                              argdesc6))
           (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-classes (my-assq 'classes l-data))
             (l-functions (my-assq 'functions l-data))
             (l-rejected-functions
              (my-assq 'rejected-functions l-data))
             (l-rejected-methods
              (my-assq 'rejected-methods l-data))
             (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) '()))))
             (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-versions al-versions
                               #:generate-methods? generate-methods?
                               #:check-procedures? check-procedures?
                               #:generate-accessors? generate-accessors?
                               #:debug? #f))
              (l-req-repositories '()))
          (for-each
           (lambda (p)
                   (let* ((str-namespace (symbol->string (car p)))
                          (str-entity (symbol->string (cadr p))))
                     (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)))
                       (if info
                         (gi-import-info1 info generator #t #t)
                         (raise (list 'nonexistent-entity
                                      (cons 'str-namespace str-namespace)
                                      (cons 'str-entity str-entity)))))))
           (append l-classes l-functions))
          (if (file-exists? str-output-file) (delete-file str-output-file))
          (let ((op (open-output-file str-output-file)))
            (guard (exc (else
                         (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-target-module generator
                                           str-module-name declarative? op)
                   (if test-errors? (raise 'test))
                   (close-output-port op)))))
      0)))
