
;; Copyright (C) 2020, 2021, 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/.


(define-module (guile-theme-d-intr-support code-generation)
  #:export
  (<golf-generator>
   <intr-entity>
   <intr-function>
   <intr-type>
   <intr-object>
   <intr-property>
   <intr-enum>
   <intr-flags>
   <intr-struct>
   <intr-union>
   <intr-interface>
   <intr-callback>
   get-golf-imports
   get-namespace-versions
   gi-import-info1
   get-method-name
   suitable-for-method?
   process-explicit-names
   gi-make-callback-entry
   parse-ignored-slots
   my-get-name5
   dp
   dpl))


;; (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))

;;  (gi-import-by-name "GObject" "Object"))
;;  (gi-import "GObject"))


(use-modules (g-golf gi))
(use-modules (g-golf gobject type-info))
(use-modules (g-golf hl-api ccc))
(use-modules (g-golf hl-api callable))
(use-modules (g-golf hl-api function))
(use-modules (g-golf hl-api argument))
(use-modules (g-golf hl-api n-decl))
(use-modules (g-golf override override))
(use-modules (ice-9 regex))
(use-modules (ice-9 match))
(use-modules (ice-9 receive))
(use-modules (rnrs lists))
(use-modules (rnrs exceptions))
(use-modules (srfi srfi-1))
(use-modules (th-scheme-utilities stdutils))
(import (except (rnrs base) map))


;; (define dp display)
;; (define (dpl x) (display x) (newline))
(define (dp x) #f)
(define (dpl x) #f)


(define-class <golf-generator> ()
  (l-rejected-functions #:init-keyword #:l-rejected-functions)
  (l-rejected-methods #:init-keyword #:l-rejected-methods)
  (l-overridden-functions #:init-keyword #:l-overridden-functions)
  (l-explicit-names #:init-keyword #:l-explicit-names
                    #:init-value '())
  (l-strip-boolean-result #:init-keyword #:l-strip-boolean-result
                          #:init-value '())
  (l-all-entities #:init-value '())
  (l-imported-types #:init-value '())
  (l-imported-only-type #:init-value '())
  (l-imported-functions #:init-value '())
  (l-toplevel-functions #:init-value '())
  (al-ignored-slots #:init-keyword #:al-ignored-slots #:init-value '())
  (al-callbacks #:init-value '())
  (al-versions #:init-keyword #:al-versions)
  (debug? #:init-keyword #:debug?)
  (generate-methods? #:init-keyword #:generate-methods?)
  (check-procedures? #:init-keyword #:check-procedures?)
  (generate-accessors? #:init-keyword #:generate-accessors?
                       #:init-value #f))

(define-class <intr-entity> ()
  (str-namespace #:init-keyword #:str-namespace)
  (str-name #:init-keyword #:str-name)
  (s-target-name #:init-keyword #:s-target-name))

(define-class <intr-type> (<intr-entity>)
  (l-methods #:init-keyword #:l-methods))

(define-class <intr-object> (<intr-type>)
  (l-supers #:init-keyword #:l-supers)
  (l-properties #:init-keyword #:l-properties))

(define-class <intr-property> (<intr-entity>)
  (s-class-name #:init-keyword #:s-class-name)
  (s-property-class #:init-keyword #:s-property-class)
  (has-getter? #:init-keyword #:has-getter?)
  (has-setter? #:init-keyword #:has-setter?)
  (s-getter-name #:init-keyword #:s-getter-name)
  (s-setter-name #:init-keyword #:s-setter-name)
  (s-accessor-name #:init-keyword #:s-accessor-name))

(define-class <intr-function> (<intr-entity>)
  (l-argument-types #:init-keyword #:l-argument-types)
  (x-return-type #:init-keyword #:x-return-type)
  (n-return-values #:init-keyword #:n-return-values)
  (method? #:init-keyword #:method?)
  (str-base #:init-keyword #:str-base)
  (l-are-callback-args #:init-keyword #:l-are-callback-args))

(define-class <intr-callback> (<intr-entity>)
  (l-argument-types #:init-keyword #:l-argument-types)
  (x-return-type #:init-keyword #:x-return-type)
  (n-return-values #:init-keyword #:n-return-values)
  (l-are-callback-args #:init-keyword #:l-are-callback-args))

(define-class <intr-interface> (<intr-type>))

(define-class <intr-enum> (<intr-type>)
  (al-values #:init-keyword #:al-values))

(define-class <intr-flags> (<intr-type>)
  (al-values #:init-keyword #:al-values)
  (s-component-type #:init-keyword #:s-component-type))

(define-class <intr-struct> (<intr-type>)
  (is-opaque? #:init-keyword #:is-opaque? #:init-value #f)
  (is-semi-opaque? #:init-keyword #:is-semi-opaque? #:init-value #f)
  (l-field-types #:init-keyword #:l-field-types #:init-value '()))

(define-class <intr-union> (<intr-type>))

(define %gi-imported-base-info-types1 '())

(define gl-al-type-name-map
  (list
   (cons 'void '<none>)
   (cons 'int8 '<integer>)
   (cons 'uint8 '<integer>)
   (cons 'int16 '<integer>)
   (cons 'uint16 '<integer>)
   (cons 'int32 '<integer>)
   (cons 'uint32 '<integer>)
   (cons 'int64 '<integer>)
   (cons 'uint64 '<integer>)
   (cons 'boolean '<boolean>)
   (cons 'double '<real>)
   (cons 'float '<real>)
   ;; Not sure about the following.
   (cons 'unichar '<character>)
   (cons 'utf8 '<string>)
   (cons 'filename '<string>)
   ;; Think about the following.
   (cons 'glist '<object>)
   ;; Think about the following.
   (cons 'array '<object>)
   (cons 'interface '<object>)
   (cons 'callback '<object>)
   (cons 'gtype '<object>)
   (cons 'ghash '<object>)))


(define (process-explicit-names l-raw)
  (map (lambda (x)
               (strong-assert (and (list? x) (= (length x) 3)))
               (cons (cons (car x) (cadr x)) (caddr x)))
       l-raw))


(define (my-get-name my-name)
  (string->symbol
    (string-append
     "<"
     (symbol->string (g-name->name my-name))
     ">")))


(define (my-get-name2 my-namespace my-name)
  (string->symbol
    (string-append
     "<"
     (symbol->string (g-name->name my-namespace))
     "-"
     (symbol->string (g-name->name my-name))
     ">")))


(define (my-get-name3 str-namespace str-name)
  (string->symbol
    (string-append
     "<"
     (g-studly-caps-expand str-namespace)
     "-"
     (g-studly-caps-expand str-name)
     ">")))


(define (my-get-name4 info)
  (my-get-name2
   (g-base-info-get-namespace info)
   (g-base-info-get-name info)))


(define (my-get-name5 s-namespace s-name)
  (string-append
   "<"
   (g-name->name (symbol->string s-namespace) #t)
   "-"
   (g-name->name (symbol->string s-name) #t)
   ">"))


(define (get-enum-name enum-type)
  (strong-assert (or (is-a? enum-type <gi-enum>)
                     (is-a? enum-type <gi-flags>)))
  (let ((str-name (slot-ref enum-type 'g-name)))
    (string->symbol
      (string-append
       "<"
       (g-studly-caps-expand str-name)
       ">"))))


(define (get-golf-imports str-filename)
  (assert (string? str-filename))
  (let ((ip (open-input-file str-filename)))
    (if ip
      (let ((sx-contents (read ip)))
        (close-input-port ip)
        (if (and (list? sx-contents)
                 (not (null? sx-contents))
                 (eq? (car sx-contents) 'intr-entities))
          (cdr sx-contents)
          (raise 'invalid-config-file)))
      (raise 'config-file-not-found))))


(define (get-namespace-versions l-data)
  (let ((al-versions '()))
    (for-each
     (lambda (l-entry)
             (if (and (list? l-entry) (not-null? l-entry)
                      (eq? (car l-entry) 'version))
               (if (= (length l-entry) 3)
                 (let ((s-namespace (cadr l-entry))
                       (str-version (caddr l-entry)))
                   (if (and (symbol? s-namespace)
                            (string? str-version))
                     (set! al-versions
                       (cons (cons (symbol->string s-namespace)
                                   str-version)
                             al-versions))
                     (raise (list 'version-entry-syntax-error
                                  (cons 'x-namespace s-namespace)
                                  (cons 'x-version str-version)))))
                 (raise (list 'invalid-version-entry-length
                              (cons 'l-entry l-entry))))))
     l-data)
    al-versions))


(define (parse-ignored-slots l-data)
  (let ((al-ignored-slots '()))
    (for-each
     (lambda (l-entry)
       (if (and (list? l-entry)
                (not-null? l-entry)
                (eq? (car l-entry) 'ignore-slots))
         (if (and (>= (length l-entry) 2)
                  (list? (cadr l-entry))
                  (eqv? (length (cadr l-entry)) 2)
                  (for-all symbol? (cadr l-entry)))
           (let* ((s-namespace (caadr l-entry))
                  (s-class-name (cadr (cadr l-entry)))
                  (str-class-name (my-get-name5 s-namespace s-class-name))
                  (s-class-name (string->symbol str-class-name))
                  (l-slots (cddr l-entry)))
             (if (and (list? l-slots) (for-all symbol? l-slots))
               (set! al-ignored-slots
                 (cons (cons s-class-name l-slots)
                       al-ignored-slots))
               (raise (list 'ignore-slots:invalid-slots
                            (cons 'l-entry l-entry)))))
           (raise (list 'ignore-slots:syntax-error
                        (cons 'l-entry l-entry))))))
     l-data)
    al-ignored-slots))


(define (make-target-class-name s-namespace s-class-name)
  (if s-namespace
    (let* ((str-namespace (g-studly-caps-expand (symbol->string s-namespace)))
           (str-class-name (g-studly-caps-expand
                            (symbol->string s-class-name)))
           (str-final-name (string-append "<" str-namespace "-"
                                          str-class-name ">"))
           (s-final-name (string->symbol str-final-name)))
      s-final-name)
    (let* ((str-class-name (g-studly-caps-expand
                            (symbol->string s-class-name)))
           (str-final-name (string-append "<" str-class-name ">"))
           (s-final-name (string->symbol str-final-name)))
      s-final-name)))


(define-method (search-entity (generator <golf-generator>)
                              (s-target-name <symbol>))
  (let ((l-all-entities (slot-ref generator 'l-all-entities)))
    (find (lambda (ent) (eq? (slot-ref ent 's-target-name) s-target-name))
          l-all-entities)))


(define (gi-import-info1 info generator toplevel? methods?)
  (assert (is-a? generator <golf-generator>))
  (assert (boolean? toplevel?))
  (let ((i-type (g-base-info-get-type info)))
    ;; (unless (memq i-type
    ;;               %gi-base-info-types)
    ;;   (push! i-type %gi-base-info-types))
    (case i-type
      ((enum)
       (unless (memq i-type
                     %gi-imported-base-info-types1)
         (push! i-type %gi-imported-base-info-types1))
       (gi-import-enum1 info generator toplevel? methods?))
      ((flags)
       (unless (memq i-type
                     %gi-imported-base-info-types1)
         (push! i-type %gi-imported-base-info-types1))
       (gi-import-flags1 info generator toplevel? methods?))
      ((struct)
       (unless (memq i-type
                     %gi-imported-base-info-types1)
         (push! i-type %gi-imported-base-info-types1))
       (gi-import-struct1 info generator toplevel? methods?))
      ((union)
       (unless (memq i-type
                     %gi-imported-base-info-types1)
         (push! i-type %gi-imported-base-info-types1))
       (gi-import-union1 info generator toplevel? methods?))
      ((function)
       (unless (memq i-type
                     %gi-imported-base-info-types1)
         (push! i-type %gi-imported-base-info-types1))
       (gi-import-function1 info generator toplevel?))
      ((object)
       (unless (memq i-type
                     %gi-imported-base-info-types1)
         (push! i-type %gi-imported-base-info-types1))
       
       ;; TBR
       (dp "class: ")
       (dpl (g-base-info-get-name info))
       
       (gi-import-object1 info generator toplevel? methods?))
      ((interface)
       ;; GObject interfaces are not understood by the Theme-D type system
       ;; so we may not generate methods here.
       (unless (memq i-type
                     %gi-imported-base-info-types1)
         (push! i-type %gi-imported-base-info-types1))
       (gi-import-interface1 info generator toplevel? methods?))
      ((callback)
       (unless (memq i-type
                     %gi-imported-base-info-types1)
         (push! i-type %gi-imported-base-info-types1))
       (gi-import-callback1 info generator))
      (else
       (if (slot-ref generator 'debug?)
         (begin
          (display "Entity ")
          (display (g-base-info-get-name info))
          (display " not imported.")
          (newline)
          (display "type: ")
          (display i-type)
          (newline)))
       'nothing))))


(define (g-object-class-precedence-list info)
  (let loop ((parent (g-object-info-get-parent info))
             (results (list (list info
                                  (g-base-info-get-namespace info)
                                  (g-object-info-get-type-name info)))))
    (if (or (not parent) (null-pointer? parent))
      (reverse! results)
      (loop (g-object-info-get-parent parent)
        (cons (list parent
                    (g-base-info-get-namespace parent)
                    (g-object-info-get-type-name parent))
              results)))))


(define (is-g-object-subclass? info-cpl)
  (letrec ((is-g-object-info-cpl-item?
            (lambda (what info-cpl-item)
                    (match info-cpl-item
                           ((info namespace name)
                            (string=? name what))))))
    (member "GObject" info-cpl is-g-object-info-cpl-item?)))


(define* (g-object-info-cpl info #:key (reversed-order? #f))
  (let  loop ((parent (g-object-info-get-parent info))
              (results (list (list info
                                   (g-base-info-get-namespace info)
                                   (g-object-info-get-type-name info)))))
    (if (not parent)
      (if reversed-order? results (reverse! results))
      (loop (g-object-info-get-parent parent)
        (cons (list parent
                    (g-base-info-get-namespace parent)
                    (g-object-info-get-type-name parent))
              results)))))


(define (gi-import-object1 info generator toplevel? methods?)
  (assert (is-a? generator <golf-generator>))
  
  ;; TBR
  (dpl "gi-import-object1 ENTER")
  ;; (display methods?)
  ;; (newline)
  
  ;; (let ((dbg-event? (equal? (g-base-info-get-name info) "Event")))
  ;; (if dbg-event? (display "Event HEP\n"))
  (let ((r-info-cpl (g-object-info-cpl info #:reversed-order? #t)))
    ;; (display r-info-cpl)
    ;; (newline)
    (unless (is-g-object-subclass? r-info-cpl)
      
      ;; TBR
      ;; (display "not g-object subclass\n")
      
      (match r-info-cpl
             ((parent . rest)
              (g-object-import-with-supers1
               parent '() generator methods?))))
    (let loop ((r-info-cpl r-info-cpl))
      (match r-info-cpl
             ((item)
              (g-object-import-with-supers1 item '() generator methods?))
             ((parent child . rest)
              (g-object-import1 child parent generator methods?)
              (loop (cons child rest)))))))

;; TBR
;; (display "gi-import-object1 EXIT\n"))


(define (add-entity generator entity)
  (assert (is-a? generator <golf-generator>))
  (slot-set! generator 'l-all-entities
             (cons entity (slot-ref generator 'l-all-entities))))


(define (add-imported-type generator gi-name)
  (assert (is-a? generator <golf-generator>))
  (slot-set! generator 'l-imported-types
             (cons
              gi-name
              (slot-ref generator 'l-imported-types))))


(define (add-imported-only-type generator gi-name)
  (assert (is-a? generator <golf-generator>))
  (slot-set! generator 'l-imported-only-type
             (cons
              gi-name
              (slot-ref generator 'l-imported-only-type))))


(define (add-callback generator s-name mult-ret?)
  (assert (is-a? generator <golf-generator>))
  (assert (symbol? s-name))
  (slot-set! generator 'al-callbacks
             (cons
              (cons s-name mult-ret?)
              (slot-ref generator 'al-callbacks))))


(define (remove-type1 generator gi-name)
  (assert (is-a? generator <golf-generator>))
  (slot-set! generator 'l-imported-only-type
             (delete
              gi-name
              (slot-ref generator 'l-imported-only-type))))


(define (add-imported-function generator s-target-name)
  (assert (is-a? generator <golf-generator>))
  (assert (symbol? s-target-name))
  (slot-set! generator 'l-imported-functions
             (cons
              s-target-name
              (slot-ref generator 'l-imported-functions))))


(define (gi-import-function1 info generator toplevel?)
  (assert (is-a? generator <golf-generator>))
  
  ;; TBR
  ; (if (equal? (g-base-info-get-namespace info) "Gsk")
  ;   (begin
  ;    (display "Gsk function: ")
  ;    (display (g-base-info-get-name info))
  ;    (newline)))
  
  (let ((intr-function (gi-make-function-entry info generator "")))
    (add-entity generator intr-function)
    (if toplevel?
      (slot-set! generator 'l-toplevel-functions
                 (cons intr-function
                       (slot-ref generator 'l-toplevel-functions))))))


(define (gi-import-callback1 info generator)
  (assert (is-a? generator <golf-generator>))
  (let* ((intr-callback (gi-make-callback-entry info generator))
         (s-target-name (slot-ref intr-callback 's-target-name)))
    (if (not (assq s-target-name
                   (slot-ref generator 'al-callbacks)))
      (begin
       (add-entity generator intr-callback)
       (add-callback generator
                     s-target-name
                     (> (slot-ref intr-callback 'n-return-values) 1))))))


(define (g-object-import1 child parent generator methods?)
  (assert (is-a? generator <golf-generator>))
  
  ;; TBR
  (dpl "g-object-import1")
  
  (match parent
         ((p-info p-namespace p-name)
          (let* ((p-r-type (g-registered-type-info-get-g-type p-info))
                 (p-gi-name (g-type-name p-r-type))
                 (p-c-name (g-name->class-name p-gi-name)))
            (g-object-import-with-supers1 child
                                          (list p-c-name)
                                          generator
                                          methods?)))))

(define (g-object-import-with-supers1 child supers generator methods?)
  (assert (is-a? generator <golf-generator>))
  
  ;; TBR
  (dpl "g-object-import-with-supers1")
  
  (match child
         ((info namespace name)
          ;; (unless (member namespace
          ;; 		  (g-irepository-get-loaded-namespaces)
          ;; 		  string=?)
          ;;   g-irepository-require namespace)
          
          ;; TBR
          ;; (display "g-object-import-with-supers1/2\n")
          
          (let* ((r-type (g-registered-type-info-get-g-type info))
                 (gi-name (g-type-name r-type))
                 (str-basename (g-studly-caps-expand gi-name))
                 (s-target-name (g-name->class-name gi-name)))

            ;; TBR
            (if (eq? s-target-name '<gtk-text-tag>)
              (begin
               (dpl "<gtk-text-tag> HEP")
               (dpl methods?)))

            (cond
              ((not (member gi-name (slot-ref generator 'l-imported-types)))
               (dpl "import/1")
               (let* ((str-name (g-base-info-get-name info))
                      (str-namespace (g-base-info-get-namespace info))
                      (intr-object
                       (make <intr-object>
                             #:str-namespace str-namespace
                             #:str-name str-name
                             #:s-target-name s-target-name
                             #:l-methods '()
                             #:l-supers supers
                             #:l-properties '())))
                 
                 (add-entity generator intr-object)
                 (add-imported-type generator gi-name)
                 
                 ;; TBR
                 ;  (if (equal? str-namespace "GObject")
                 ;    (begin
                 ;     (display "object\n")
                 ;     (display str-namespace)
                 ;     (newline)
                 ;     (display str-name)
                 ;     (newline)
                 ;     (display gi-name)
                 ;     (newline)
                 ;     (display s-target-name)
                 ;     (newline)))
                 
                 (if methods?
                   (begin
                    (gi-import-methods1 info intr-object generator
                                        g-object-info-get-n-methods
                                        g-object-info-get-method
                                        str-basename s-target-name)
                    (gi-import-properties1 info intr-object generator
                                           str-basename
                                           s-target-name))
                   (add-imported-only-type generator gi-name))))
              ((and methods?
                    (member gi-name (slot-ref generator 'l-imported-only-type)))
               (dpl "import/2")
               (let* ((str-name (g-base-info-get-name info))
                      (str-namespace (g-base-info-get-namespace info))
                      (intr-object (search-entity generator s-target-name)))
                 (assert (is-a? intr-object <intr-entity>))
                 (dpl "import/2-1")
                 (remove-type1 generator gi-name)
                 (dpl "import/2-2")
                 (add-imported-type generator gi-name)
                 (dpl "import/2-3")
                 (gi-import-methods1 info intr-object generator
                                     g-object-info-get-n-methods
                                     g-object-info-get-method
                                     str-basename s-target-name)
                 (dpl "import/2-4")
                 (gi-import-properties1 info intr-object generator
                                        str-basename
                                        s-target-name)))
              (else
               (dpl "import/3")
               #f))))))


(define (gi-import-nonobj-type info generator toplevel? methods?
                               create-intr
                               get-n-methods
                               get-method)
  (assert (is-a? generator <golf-generator>))
  (let* ((str-name (g-base-info-get-name info))
         (str-namespace (g-base-info-get-namespace info))
         (s-name (string->symbol str-name))
         (s-namespace (string->symbol str-namespace))
         ;; (p-explicit (assoc (cons s-namespace s-name)
         ;;		    (slot-ref generator 'l-explicit-names)))
         ;; (r-type (g-registered-type-info-get-g-type info))
         ;; (gi-name
         ;;  (if p-explicit
         ;;      (symbol->string (cdr p-explicit))
         ;;      (g-type-name r-type)))
         (gi-name (gi-registered-type-info-name info))
         (str-basename (g-studly-caps-expand gi-name))
         (s-target-name (g-name->class-name gi-name)))
    
    ;; TBR
    ; (if (equal? str-namespace "GLib")
    ;   (begin
    ;    (display "gi-import-nonobj-type\n")
    ;    (display str-namespace)
    ;    (newline)
    ;    (display str-name)
    ;    (newline)
    ;    (display gi-name)
    ;    (newline)
    ;    (display s-target-name)
    ;    (newline)))
    
    (cond
      ((not (member gi-name (slot-ref generator 'l-imported-types)))
       (let* ((str-name (g-base-info-get-name info))
              (str-namespace (g-base-info-get-namespace info))
              (intr
               (create-intr str-namespace str-name s-target-name)))
         (add-entity generator intr)
         (add-imported-type generator gi-name)
         (if methods?
           (gi-import-methods1 info intr generator
                               get-n-methods
                               get-method
                               str-basename s-target-name)
           (add-imported-only-type generator gi-name))))	    
      ((and methods?
            (member gi-name (slot-ref generator 'l-imported-only-type)))
       (let* ((str-name (g-base-info-get-name info))
              (str-namespace (g-base-info-get-namespace info))
              (intr
               (create-intr str-namespace str-name s-target-name)))
         (remove-type1 generator gi-name)
         (gi-import-methods1 info intr generator
                             get-n-methods
                             get-method
                             str-basename s-target-name))))))


(define (gi-import-interface1 info generator toplevel? methods?)
  (let ((create-intr
         (lambda (str-namespace str-name s-target-name)
                 (make <intr-interface>
                       #:str-namespace str-namespace
                       #:str-name str-name
                       #:s-target-name s-target-name
                       #:l-methods '()))))	   
    (gi-import-nonobj-type info generator toplevel? methods?
                           create-intr
                           g-interface-info-get-n-methods
                           g-interface-info-get-method)))


(define (get-struct-field-types l-types)
  (map
   (lambda (x-type)
           (let ((p (assq x-type gl-al-type-name-map)))
             (if p (cdr p) '<object>)))
   l-types))


(define (gi-import-struct1 info generator toplevel? methods?) 
  
  ;; TBR
  ; (if (equal? (g-base-info-get-namespace info) "Gsk")
  ;   (begin
  ;    (display "Gsk struct: ")
  ;    (display (g-base-info-get-name info))
  ;    (newline)))
  ; (if (equal? (g-base-info-get-namespace info) "Graphene")
  ;   (begin
  ;    (display "Graphene struct: ")
  ;    (display (g-base-info-get-name info))
  ;    (newline)
  ;    (display methods?)
  ;    (newline)))
  
  (let* ((gi (gi-import-struct info))
         (is-opaque? (!is-opaque? gi))
         (is-semi-opaque? (!is-semi-opaque? gi))
         (l-field-types (get-struct-field-types (!field-types gi))))
    (let ((create-intr
           (lambda (str-namespace str-name s-target-name)
                   (make <intr-struct>
                         #:str-namespace str-namespace
                         #:str-name str-name
                         #:s-target-name s-target-name
                         #:l-methods '()
                         #:is-opaque? is-opaque?
                         #:is-semi-opaque? is-semi-opaque?
                         #:l-field-types l-field-types))))	   
      (gi-import-nonobj-type info generator toplevel? methods?
                             create-intr
                             g-struct-info-get-n-methods
                             g-struct-info-get-method))))


(define (gi-import-union1 info generator toplevel? methods?)
  (let ((create-intr
         (lambda (str-namespace str-name s-target-name)
                 (make <intr-union>
                       #:str-namespace str-namespace
                       #:str-name str-name
                       #:s-target-name s-target-name
                       #:l-methods '()))))	   
    (gi-import-nonobj-type info generator toplevel? methods?
                           create-intr
                           g-union-info-get-n-methods
                           g-union-info-get-method)))


(define (gi-import-enum1 info generator toplevel? methods?)
  (let ((create-intr
         (lambda (str-namespace str-name s-target-name)
                 (make <intr-enum>
                       #:str-namespace str-namespace
                       #:str-name str-name
                       #:s-target-name s-target-name
                       #:l-methods '()
                       #:al-values (gi-enum-value-values info)))))
    (gi-import-nonobj-type info generator toplevel? methods?
                           create-intr
                           g-enum-info-get-n-methods
                           g-enum-info-get-method)))


(define (get-flags-component-type-name info)
  (let* ((str-name1 (gi-registered-type-info-name info))
         (str-name2 (g-name->name str-name1 #t)))
    (string->symbol (string-append "<_" str-name2 ">"))))


(define (gi-import-flags1 info generator toplevel? methods?)
  (let ((create-intr
         (lambda (str-namespace str-name s-target-name)
                 (make <intr-flags>
                       #:str-namespace str-namespace
                       #:str-name str-name
                       #:s-target-name s-target-name
                       #:l-methods '()
                       #:al-values (gi-enum-value-values info)
                       #:s-component-type
                       (get-flags-component-type-name info)))))
    ;; G-Golf uses enum accessors for flags.
    (gi-import-nonobj-type info generator toplevel? methods?
                           create-intr
                           g-enum-info-get-n-methods
                           g-enum-info-get-method)))


(define (gi-import-methods1 info intr-type generator
                            get-n-methods get-method
                            str-basename s-class-name)
  (dpl "gi-import-methods1 ENTER")
  (assert (is-a? generator <golf-generator>))
  (assert (procedure? get-n-methods))
  (assert (procedure? get-method))
  (assert (string? str-basename))
  (let ((n-method (get-n-methods info))
        (l-methods '()))
    (do ((i 0
            (+ i 1)))
      ((= i n-method))
      (dpl "gi-import-methods1/1")
      (let* ((m-info (get-method info i))
             (intf-method
              (gi-make-function-entry m-info generator str-basename)))

        ;; TBR
        ; (if (equal? (g-base-info-get-namespace m-info) "Gsk")
        ;   (begin
        ;    (display "Gsk method: ")
        ;    (display (g-base-info-get-name m-info))
        ;    (newline)))
        
        (set! l-methods (cons intf-method l-methods))
        (dpl "gi-import-methods1/2")
        (add-entity generator intf-method)
        (dpl "gi-import-methods1/3")
        (add-imported-function generator
                               (slot-ref intf-method 's-target-name))
        (gi-check-method m-info generator s-class-name)))
    (dpl "gi-import-methods1 EXIT")
    (slot-set! intr-type 'l-methods l-methods)))


(define (gi-check-method info generator s-class-name)
  (dpl "gi-check-method ENTER")
  (dpl s-class-name)
  (assert (is-a? generator <golf-generator>))
  (let ((return-type (g-callable-info-get-return-type info)))
    (if (eq? (g-type-info-get-tag return-type) 'interface)
      (let ((s-result-class
             (my-get-name4
              (g-type-info-get-interface return-type))))
        (dpl s-result-class)
        (if (not (eq? s-result-class s-class-name))
          (gi-import-info1 (g-type-info-get-interface return-type)
                           generator #f #f)))))
  (dpl "gi-check-method/1")
  (let ((n (g-callable-info-get-n-args info)))
    (do ((i 0 (+ i 1))) ((>= i n))
      (let* ((info-arg (g-callable-info-get-arg info i))
             (tp (g-arg-info-get-type info-arg)))
        (if (eq? (g-type-info-get-tag tp) 'interface)
          (begin
           (let* ((x-intf (g-type-info-get-interface tp))
                  (s-class-name2 (my-get-name4 x-intf)))
             (dpl "gi-check-method/2")
             (dpl s-class-name2)
             (if (not (eq? s-class-name2 s-class-name))
               (gi-import-info1 x-intf generator #f #f)))))))))


(define (gi-import-properties1 info intr-object generator
                               str-basename s-class-name)
  (assert (is-a? intr-object <intr-object>))
  (assert (is-a? generator <golf-generator>))
  (assert (string? str-basename))
  (assert (symbol? s-class-name))
  (let ((i-count (g-object-info-get-n-properties info))
        (l-properties '()))
    (dp "gi-import-properties1 ")
    (dpl i-count)
    (dpl (slot-ref intr-object 's-target-name))
    (dpl s-class-name)
    (do ((i 0 (+ i 1))) ((>= i i-count))
      (let* ((info-prop (g-object-info-get-property info i))
             (str-prop-name (g-base-info-get-name info-prop))
             (prop-type (g-property-info-get-type info-prop))
             (s-property-class (get-target-type2 prop-type))
             (str-accessor-name (string-append "!" str-prop-name))
             (s-accessor-name (string->symbol str-accessor-name))
             (l-prop-flags (g-property-info-get-flags info-prop))
             (str-getter-name
              (string-append str-basename "-get-" str-prop-name))
             (s-getter-name (string->symbol str-getter-name))
             (str-setter-name
              (string-append str-basename "-set-" str-prop-name))
             (s-setter-name (string->symbol str-setter-name))
             (l-imported-functions
              (slot-ref generator 'l-imported-functions))
             (def-getter?
               (and (member 'readable l-prop-flags)
                    (not (member s-getter-name
                                 l-imported-functions))))
             (def-setter?
               (and (member 'writable l-prop-flags)
                    (not (member s-setter-name
                                 l-imported-functions))))
             (intr-property
              (make <intr-property>
                    #:str-namespace '()
                    #:str-name str-prop-name
                    #:s-target-name '()
                    #:s-class-name s-class-name
                    #:s-property-class s-property-class
                    #:has-getter? def-getter?
                    #:has-setter? def-setter?
                    #:s-getter-name s-getter-name
                    #:s-setter-name s-setter-name
                    #:s-accessor-name s-accessor-name)))

        ;; TBR
        (if (and  (equal? str-prop-name "show-spaces-set")
                  (eq? s-property-class '<gtk-text-tag>))
          (display "tag HEP1\n"))
        (dp "gi-import-properties1/1 ")
        (dpl s-property-class)

        (if (eq? (g-type-info-get-tag prop-type) 'interface)
          (gi-import-info1 (g-type-info-get-interface prop-type)
                           generator #f #f))
        (add-entity generator intr-property)
        (set! l-properties (cons intr-property l-properties))))
    (dp "gi-import-properties1 EXIT ")
    (dpl (length l-properties))
    (slot-set! intr-object 'l-properties l-properties)))


(define (get-target-type type-desc)
  (let* ((base-type
          (cond
            ((list? type-desc)
             (cond
               ((eq? (car type-desc) 'object)
                (cadr type-desc))
               ((and (eq? (car type-desc) 'struct)
                     (eq? (cadr type-desc) 'g-value))
                '<object>)
               ((eq? (car type-desc) 'struct)
                ;; '<pointer>)
                (my-get-name (!g-name (caddr type-desc))))
               ((eq? (car type-desc) 'glist)
                '<list>)
               ((eq? (car type-desc) 'gslist)
                '<list>)
               ((eq? (car type-desc) 'enum)
                (get-enum-name (caddr type-desc)))
               ((eq? (car type-desc) 'flags)
                (get-enum-name (caddr type-desc)))
               ((eq? (car type-desc) 'union)
                ;; '<pointer>)  
                (my-get-name (!g-name (caddr type-desc))))
               ((eq? (car type-desc) 'interface)
                '<object>)
               ((eq? (car type-desc) 'byte-array)
                '<bytevector>)
               ((eq? (car type-desc) 'ptr-array)
                '<object>)
               ((eq? (car type-desc) 'callback)
                (let ((info (caddr type-desc)))
                  (my-get-name2
                   (g-base-info-get-namespace info)
                   (g-base-info-get-name info))))
               ;; '<object>)
               ;; Don't know what the following is.
               ((eq? (car type-desc) 'c)
                '<object>)
               (else
                (display type-desc)
                (newline)
                (raise 'cannot-parse-argument-type))))
            ((symbol? type-desc)
             ;; We can have void as an argument type. This may be a bug in G-Golf.
             (if (eq? type-desc 'void)
               '<object>
               (let ((p (assq type-desc gl-al-type-name-map)))
                 (if p (cdr p) type-desc))))
            (else
             (display type-desc)
             (newline)
             (raise 'cannot-parse-argument-type)))))
    base-type))

(define (get-target-type0 tag type1 return?)
  (case tag
    ((interface)
     (if (eq? type1 'void)
       (if return? '<none> '<object>)
       (get-target-type type1)))
    ((void)
     (if return? '<none> '<object>))
    ((boolean)
     '<boolean>)
    ((int64 uint64 int32 uint32 int16 uint16 int8 uint8)
     '<integer>)
    ((double float)
     '<real>)
    ((utf8 filename)
     '<string>)
    ((unichar)
     '<character>)
    ((glist gslist) '<list>)
    ((array)
     '<object>)
    ((gtype)
     '<symbol>)
    (else
     (raise (list 'unknown-type-tag (cons 'tag tag))))))


(define (get-target-type1 tag type1 may-return-null? return?)
  (let ((x (get-target-type0 tag type1 return?)))
    (if (or (not may-return-null?)
            (eq? x '<object>)
            (eq? x '<boolean>))
      x
      (list ':alt-maybe x))))


(define (get-target-type2 prop-type)
  (let ((s-tag (g-type-info-get-tag prop-type)))
    (case s-tag
      ((interface)
       (let* ((intf (g-type-info-get-interface prop-type))
              (s-result
               (g-name->class-name (gi-registered-type-info-name intf))))
         s-result))
      ((void)
       (raise 'void-property-type))
      ((boolean)
       '<boolean>)
      ((int64 uint64 int32 uint32 int16 uint16 int8 uint8)
       '<integer>)
      ((double float)
       '<real>)
      ((utf8 filename)
       '<string>)
      ((unichar)
       '<character>)
      ((glist gslist) '<list>)
      ((array)
       '<object>)
      ((gtype)
       '<symbol>)
      (else
       (raise (list 'unknown-type-tag (cons 'tag s-tag)))))))


(define (get-argument-type x-arg)
  (let ((tag (!type-tag x-arg))
        (type-desc (!type-desc x-arg))
        (may-be-null? (!may-be-null? x-arg)))
    (get-target-type1 tag type-desc may-be-null? #f)))


(define (get-first-out-arg l-arguments)
  (car (filter (lambda (gi-arg) (eq? (!direction gi-arg) 'out)) l-arguments)))


(define (get-out-args l-arguments)
  (filter (lambda (gi-arg) (eq? (!direction gi-arg) 'out)) l-arguments))


(define (gi-make-function-entry info generator str-base)
  (assert (is-a? generator <golf-generator>))
  (assert (string? str-base))
  (let ((namespace (g-base-info-get-namespace info)))
    ;; (if (not (gi-namespace-import-exception? namespace))
    (receive (namespace b-name name m-name c-name)
             (gi-function-info-names info namespace)
             ;; (display "gi-make-function-entry\n")
             ;; (display name)
             ;; (newline)
             (let* ((str-name (g-base-info-get-name info))
                    ;; (x-function (gi-import-function info))
                    (x-function
                     (make <function>
                           #:info info
                           #:namespace namespace
                           #:g-name b-name
                           #:name name
                           #:m-name m-name
                           #:c-name c-name
                           #:override? (gi-override? c-name)))
                    ;; (or (gi-cache-ref 'function name)
                    ;;     (let ((f-inst (make <function>
                    ;; 		      #:info info
                    ;; 		      #:namespace namespace
                    ;; 		      #:g-name b-name
                    ;; 		      #:name name
                    ;; 		      #:m-name m-name
                    ;; 		      #:c-name c-name
                    ;; 		      #:override? (gi-override? c-name))))
                    ;; 	(gi-cache-set! 'function name)
                    ;; 	(if (!is-method? f-inst)
                    ;; 	    (gi-add-method-* f-inst)
                    ;; 	    (gi-add-procedure f-inst))
                    ;; 	f-inst)))
                    (s-name (!name x-function))
                    ;; (tmp
                    ;;  (begin
                    ;;    (display "function name: ")
                    ;;    (display s-name)
                    ;;    (newline)
                    ;;    #f))
                    (l-arguments0 (!arguments x-function))
                    (o-spec-pos (!o-spec-pos x-function))
                    (l-arguments
                     (if o-spec-pos
                       (map (lambda (pos)
                                    (list-ref l-arguments0 pos))
                            o-spec-pos)
                       (filter (lambda (gi-arg)
                                       (and (not (eq? (!direction gi-arg) 'out))
                                            (not (!al-arg? gi-arg))))
                               l-arguments0)))
                    (l-argument-types (map get-argument-type l-arguments))
                    (x-return-type-tag (!return-type x-function))
                    (x-return-type0 (!type-desc x-function))
                    (l-out-args (get-out-args l-arguments0))
                    (n-out-args (length l-out-args))
                    ;; (x-return-type
                    ;;  (if (and (> n-out-args 0)
                    ;; 	   (eq? x-return-type0 'void))
                    ;;      ;; Multiple return values won't probably work with Theme-D.
                    ;;      (if (= n-out-args 1)
                    ;; 	  (get-argument-type (get-first-out-arg l-arguments0))
                    ;; 	  '<object>)
                    ;;      (get-return-type x-return-type0 (!may-return-null? x-function))))
                    (strip-first?
                     (if (memq s-name (slot-ref generator 'l-strip-boolean-result))
                       #t
                       #f))
                    (x-return-type
                     (if strip-first?
                       (if (eq? x-return-type-tag 'boolean)
                         (cond
                           ((= n-out-args 0)
                            ;; Not sure about the following
                            '<none>)
                           ((= n-out-args 1)
                            (get-argument-type (car l-out-args)))
                           (else
                            (map get-argument-type l-out-args)))
                         (raise (list 'invalid-function-to-strip
                                      (cons 's-name s-name))))
                       (if (= n-out-args 0)
                         (get-target-type1 x-return-type-tag
                                           x-return-type0
                                           (!may-return-null? x-function)
                                           #t)
                         (cond
                           ((not (eq? x-return-type0 'void))
                            (cons
                             ;; For a void argument the component type has to be
                             ;; <object>.
                             ;; That's why we pass #f as the third paramater here.
                             (get-target-type1 x-return-type-tag
                                               x-return-type0
                                               (!may-return-null? x-function)
                                               #f)
                             (map get-argument-type l-out-args)))
                           ((= n-out-args 1)
                            (get-argument-type (car l-out-args)))
                           (else
                            (map get-argument-type l-out-args))))))
                    (n-return-values
                     (+ (if (or strip-first? (eq? x-return-type0 'void)) 0 1)
                        n-out-args))
                    (method? (gi-function-info-is-method? info))
                    (l-are-callback-args (check-if-callbacks l-arguments))
                    (intr-function
                     (make <intr-function>
                           #:str-namespace namespace
                           #:str-name str-name
                           #:s-target-name s-name
                           #:l-argument-types l-argument-types
                           #:x-return-type x-return-type
                           #:n-return-values n-return-values
                           #:method? method?
                           #:str-base str-base
                           #:l-are-callback-args l-are-callback-args)))
               (assert (not (and method? (string-null? str-base))))
               
               ;; TBR
               ;;  (display "gi-make-function-entry EXIT\n")
               ;;  (display (slot-ref intr-function 'str-namespace))
               ;;  (newline)
               ;;  (display (slot-ref intr-function 'str-name))
               ;;  (newline)
               ;;  (display (slot-ref intr-function 'str-base))
               ;;  (newline)
            ;;    (if (equal? namespace "GLib")
            ;;      (display "GLib HEP\n"))
               
               intr-function))))


(define (check-if-callbacks l-arguments)
  (map (lambda (x-arg)
               (if
                 (and
                  (eq? (!type-tag x-arg) 'interface)
                  (let ((type-desc (!type-desc x-arg)))
                    (and
                     (list? type-desc)
                     (not (null? type-desc))
                     (eq? (car type-desc) 'callback))))
                 #t #f))
       l-arguments))


(define (gi-make-callback-entry info generator)
  (assert (is-a? generator <golf-generator>))
  (let* ((str-namespace (g-base-info-get-namespace info))
         (str-g-name (g-base-info-get-name info))
         (s-name (g-name->name str-g-name))
         (s-target-name (my-get-name3 str-namespace str-g-name)))
    (let* ((x-callback
            (make <callback>
                  #:info info
                  #:namespace str-namespace
                  #:g-name str-g-name
                  #:name s-name))
           (l-arguments0 (!arguments x-callback))
           (l-arguments
            (filter (lambda (gi-arg)
                            (and (not (eq? (!direction gi-arg) 'out))
                                 (not (!al-arg? gi-arg))))
                    l-arguments0))
           (l-argument-types (map get-argument-type l-arguments))
           (x-return-type-tag (!return-type x-callback))
           (x-return-type0 (!type-desc x-callback))
           (l-out-args (get-out-args l-arguments0))
           (n-out-args (length l-out-args))
           ;; Not sure if this works for callbacks.
           (strip-first?
            (if (memq s-name (slot-ref generator 'l-strip-boolean-result))
              #t
              #f))
           (x-return-type
            (if strip-first?
              (if (eq? x-return-type-tag 'boolean)
                (cond
                  ((= n-out-args 0)
                   ;; Not sure about the following
                   '<none>)
                  ((= n-out-args 1)
                   (get-argument-type (car l-out-args)))
                  (else
                   (map get-argument-type l-out-args)))
                (raise (list 'invalid-function-to-strip
                             (cons 's-name s-name))))
              (if (= n-out-args 0)
                (get-target-type1 x-return-type-tag
                                  x-return-type0
                                  (!may-return-null? x-callback)
                                  #t)
                (cond
                  ((not (eq? x-return-type0 'void))
                   (cons
                    ;; For a void argument the component type has to be
                    ;; <object>.
                    ;; That's why we pass #f as the third paramater here.
                    (get-target-type1 x-return-type-tag
                                      x-return-type0
                                      (!may-return-null? x-callback)
                                      #f)
                    (map get-argument-type l-out-args)))
                  ((= n-out-args 1)
                   (get-argument-type (car l-out-args)))
                  (else
                   (map get-argument-type l-out-args))))))
           (n-return-values
            (+ (if (or strip-first? (eq? x-return-type0 'void)) 0 1)
               n-out-args))
           (l-are-callback-args (check-if-callbacks l-arguments))
           (intr-callback
            (make <intr-callback>
                  #:str-namespace str-namespace
                  #:str-name str-g-name
                  #:s-target-name s-target-name
                  #:l-argument-types l-argument-types
                  #:x-return-type x-return-type
                  #:n-return-values n-return-values
                  #:l-are-callback-args l-are-callback-args)))
      
      ;; TBR
      ;  (display "gi-make-callback-entry EXIT\n")
      ;  (display (slot-ref intr-callback 'str-namespace))
      ;  (newline)
      ;  (display (slot-ref intr-callback 'str-name))
      ;  (newline)
      ;  (display (slot-ref intr-callback 's-target-name))
      ;  (newline)
      
      intr-callback)))

(define-method (get-method-name (intr-function <intr-function>))
  (let* ((str-base (slot-ref intr-function 'str-base))
         (s-name (slot-ref intr-function 's-target-name))
         (str-regexp (string-append "^" str-base "-"))
         (str-name (symbol->string s-name))
         (x-match (string-match str-regexp str-name)))
    (if x-match
      (let ((s-method-name
             (string->symbol
               (substring str-name
                          (+ (string-length str-base) 1)))))
        s-method-name)
      '())))

(define (suitable-for-method? l-argument-types)
  (not (for-all (lambda (x) (eq? x '<pointer>)) l-argument-types)))

