#!@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))


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


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


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


(define-method (generate-wrapper
		(generator <golf-generator>) (intr <intr-function>)
		(op <output-port>))
  (let ((s-target-name (slot-ref intr 's-target-name))
	(s-wrapper-name (get-wrapper-func-name intr)))
    (display
     `(define-public ,s-wrapper-name
	(lambda args
	  ;; (call-with-values (apply ,s-name args)
	  ;; 	 (lambda args1 args1))))
	  (receive vals (apply ,s-target-name args) vals)))
     op)
    (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 (guile))\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)
		 (begin
		   (if (> (slot-ref ent 'n-return-values) 1)
		       (generate-wrapper generator ent op)))
		 (let ((x-return-type0 (caddr p)))
		   (if (and (list? x-return-type0)
			    (not-null? x-return-type0)
			    (eq? (car x-return-type0) 'values))
		       (let ((s-wrapper-name (get-wrapper-func-name ent)))
			 (display
			  `(define-public ,s-wrapper-name
			     (lambda args
			       ;; (call-with-values (apply ,s-name args)
			       ;; 	 (lambda args1 args1))))
			       (receive vals (apply ,s-name args) vals)))
			  op)
			 (newline 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))
    (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)
	(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))))
	   (l-arg-descs (list argdesc1 argdesc2 argdesc3 argdesc4 argdesc5))
	   (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?
			   #:debug? #t))
	      (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)))
