#!@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 (th-scheme-utilities hrecord))
(use-modules (th-scheme-utilities parse-command-line))
(use-modules (th-scheme-utilities stdutils))


(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 (get-wrapper-func-name (intr <intr-function>))
  (string->symbol
   (string-append
    "_wrapper-"
    (symbol->string (slot-ref intr 's-target-name)))))


(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))
	(s-target-name
	   (if (<= (slot-ref intr 'n-return-values) 1)
	       (slot-ref intr 's-target-name)
	       (get-wrapper-func-name intr)))
	(s-proc-keyword
	 (if (slot-ref generator 'check-procedures?)
	     'prim-proc
	     'unchecked-prim-proc)))
    (display
     `(define ,s-name
	(,s-proc-keyword ,s-target-name ,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
		 `(add-virtual-method ,s-method-name ,s-name)
		 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))
	 (l (cdr (assq s-name (slot-ref generator 'l-overridden-functions))))
	 (l-argument-types (car l))
	 (x-return-type0 (cadr l))
	 (x-return-type
	  (if (and (list? x-return-type0)
		   (not-null? x-return-type0)
		   (eq? (car x-return-type0) 'values))
	      (cons ':tuple (cdr x-return-type0))
	      x-return-type0))
	 (s-target-name
	  (if (and (list? x-return-type0)
		   (not-null? x-return-type0)
		   (eq? (car x-return-type0) 'values))
	      (get-wrapper-func-name intr)
	      s-name))
	 (x-attr (caddr l))
	 (s-proc-keyword
	  (if (slot-ref generator 'check-procedures?)
	      'prim-proc
	      'unchecked-prim-proc)))
    (display
     `(define ,s-name
	(,s-proc-keyword ,s-target-name ,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
		 `(add-virtual-method ,s-method-name ,s-name)
		 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-property>)
		(op <output-port>))
  (if (slot-ref intr 'has-getter?)
      (let ((s-getter-name (slot-ref intr 's-getter-name))
	    (s-class-name (slot-ref intr 's-class-name))
	    (s-accessor-name (slot-ref intr 's-accessor-name)))
	(display
	 `(define ,s-getter-name
	    (unchecked-prim-proc ,s-accessor-name
				 (,s-class-name) <object> pure))
	 op)
	(newline op)))
  (if (slot-ref intr 'has-setter?)
      (let ((s-setter-name (slot-ref intr 's-setter-name))
	    (s-class-name (slot-ref intr 's-class-name)))
	(display
	 `(define ,s-setter-name
	    (unchecked-prim-proc ,s-setter-name
				 (,s-class-name <object>) <none>
				 nonpure))
	 op)
	(newline op))))


(define (generate-body generator str-module-name op)
  (display "(define-body " op)
  (display str-module-name op)
  (newline op)
  (let ((l-entities (reverse (slot-ref generator 'l-all-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 ((str-input-file "intr-imports.scm")
	(str-output-file "_intr-imports.thb")
	(str-module-name "_intr-imports")
	(generate-methods? #t)
	(check-procedures? #t)
	(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))))
	   (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
	      (let ((x1 (assq 'classes l-data)))
		(if x1 (cdr x1) '())))
	     (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) '()))))
	     (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-body generator str-module-name op)	  
		   (if test-errors? (raise 'test)))
	    (close-output-port op))
	  0)))))
