#!@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 (and (<= (slot-ref intr 'n-return-values) 1)
                  (not (exists (lambda (x) (eq? x #t))
                               (slot-ref intr 'l-are-callback-args))))
           (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))
         (multiple-return-values?
          (and (list? x-return-type0)
               (not-null? x-return-type0)
               (eq? (car x-return-type0) ':tuple)))
         (need-wrapper?
          (or
           multiple-return-values?
           (exists
            (lambda (x)
                    (or
                     (assq x (slot-ref generator 'al-callbacks))
                     (and (list? x)
                          (not-null? x)
                          (eq? (car x) ':procedure))))
            l-argument-types)))
         (x-return-type
          (if multiple-return-values?
            (cons ':tuple (cdr x-return-type0))
            x-return-type0))
         (s-target-name
          (if need-wrapper?
            (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>))
  (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))
            (s-accessor-name (slot-ref intr 's-accessor-name)))
        (display
         `(define ,s-getter-name
            (prim-proc ,s-accessor-name
                        (,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
         `(define ,s-setter-name
            (prim-proc ,s-setter-name
                        (,s-class-name ,s-property-class) <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)
    (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.thb")
        (str-module-name "_intr-imports")
        (generate-methods? #t)
        (generate-accessors? #f)
        (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))))
           (argdesc7 (make-hrecord <argument-descriptor>
                                   "generate-accessors" #f
                                   (lambda ()
                                           (set! generate-accessors? #t))))
           (l-arg-descs (list argdesc1 argdesc2 argdesc3 argdesc4 argdesc5
                              argdesc6 argdesc7))
           (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?
                               #: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-body generator str-module-name op)	  
                   (if test-errors? (raise 'test)))
            (close-output-port op))
          0)))))
