;; -*- mode: scheme; coding: utf-8 -*-

;;;;
;;;; Copyright (C) 2016 - 2024
;;;; Free Software Foundation, Inc.

;;;; This file is part of GNU G-Golf

;;;; GNU G-Golf is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU Lesser General Public License as
;;;; published by the Free Software Foundation; either version 3 of the
;;;; License, or (at your option) any later version.

;;;; GNU G-Golf 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
;;;; Lesser General Public License for more details.

;;;; You should have received a copy of the GNU Lesser General Public
;;;; License along with GNU G-Golf.  If not, see
;;;; <https://www.gnu.org/licenses/lgpl.html>.
;;;;

;;; Commentary:

;;; Code:


(define-module (g-golf gi callable-info)
  #:use-module (ice-9 format)
  #:use-module (system foreign)
  #:use-module (g-golf support enum)
  #:use-module (g-golf init)
  #:use-module (g-golf gi version)
  #:use-module (g-golf gi utils)
  #:use-module (g-golf gi base-info)
  #:use-module (g-golf gi arg-info)
  #:use-module (g-golf gi type-info)

  #:export (gi-callable-show

            g-callable-info-can-throw-gerror
            g-callable-info-get-n-args
	    g-callable-info-get-arg
	    g-callable-info-get-caller-owns
            g-callable-info-get-instance-ownership-transfer
	    g-callable-info-get-return-type
            g-callable-info-invoke
            g-callable-info-is-method
	    g-callable-info-may-return-null
            g-callable-info-create-closure
            g-callable-info-get-closure-native-address))



;;;
;;; Misc.
;;;

(define %callable-fmt
  "
~S is a (pointer to a) GICallableInfo:

          namespace: ~S
               name: ~S
               type: ~S
   can-throw-gerror: ~S
              n-arg: ~A
        caller-owns: ~S
                iot: ~S	 [ instance-ownership-transfer
        return-type: ~S
          is-method: ~S
    may-return-null: ~S

")

(define* (gi-callable-show info
                           #:optional (port (current-output-port)))
  (let* ((return-type-info (g-callable-info-get-return-type info))
         (return-type (g-type-info-get-tag return-type-info)))
    (g-base-info-unref return-type-info)
    (format port "~?" %callable-fmt
            (list info
                  (g-base-info-get-namespace info)
                  (g-base-info-get-name info)
                  (g-base-info-get-type info)
                  (g-callable-info-can-throw-gerror info)
                  (g-callable-info-get-n-args info)
                  (g-callable-info-get-caller-owns info)
                  (g-callable-info-get-instance-ownership-transfer info)
                  return-type
                  (g-callable-info-is-method info)
                  (g-callable-info-may-return-null info)))))


;;;
;;; Low level API
;;;

(define (g-callable-info-can-throw-gerror info)
  (gi->scm (g_callable_info_can_throw_gerror info) 'boolean))

(define (g-callable-info-get-n-args info)
  (g_callable_info_get_n_args info))

(define (g-callable-info-get-arg info n)
  (gi->scm (g_callable_info_get_arg info n) 'pointer))

(define (g-callable-info-get-caller-owns info)
  (enum->symbol %gi-transfer
                (g_callable_info_get_caller_owns info)))

(define (g-callable-info-get-instance-ownership-transfer info)
  (enum->symbol %gi-transfer
                (g_callable_info_get_instance_ownership_transfer info)))

(define (g-callable-info-get-return-type info)
  (gi->scm (g_callable_info_get_return_type info) 'pointer))

(define (g-callable-info-invoke info
                                f-ptr
                                in-args n-in
                                out-args n-out
                                r-val
                                is-method
                                throws
                                g-error)
  (g_callable_info_invoke info
                          f-ptr
                          in-args n-in
                          out-args n-out
                          r-val
                          (scm->gi is-method 'boolean)
                          (scm->gi throws 'boolean)
                          g-error))

(define (g-callable-info-is-method info)
  (gi->scm (g_callable_info_is_method info) 'boolean))

(define (g-callable-info-may-return-null info)
  (gi->scm (g_callable_info_may_return_null info) 'boolean))


;;;
;;; GI Bindings
;;;

(define g_callable_info_can_throw_gerror
  (pointer->procedure int
                      (dynamic-func "g_callable_info_can_throw_gerror"
				    %libgirepository)
                      (list '*)))

(define g_callable_info_get_n_args
  (pointer->procedure int
                      (dynamic-func "g_callable_info_get_n_args"
				    %libgirepository)
                      (list '*)))

(define g_callable_info_get_arg
  (pointer->procedure '*
                      (dynamic-func "g_callable_info_get_arg"
				    %libgirepository)
                      (list '* int)))

(define g_callable_info_get_caller_owns
  (pointer->procedure int
                      (dynamic-func "g_callable_info_get_caller_owns"
				    %libgirepository)
                      (list '*)))

(define g_callable_info_get_instance_ownership_transfer
  (pointer->procedure int
                      (dynamic-func "g_callable_info_get_instance_ownership_transfer"
				    %libgirepository)
                      (list '*)))

(define g_callable_info_get_return_type
  (pointer->procedure '*
                      (dynamic-func "g_callable_info_get_return_type"
				    %libgirepository)
                      (list '*)))

(define g_callable_info_invoke
  (pointer->procedure int
                      (dynamic-func "g_callable_info_invoke"
				    %libgirepository)
                      (list '*		;; info
                            '*		;; function
                            '*		;; in-args
                            int		;; n-in
                            '*		;; out-args
                            int		;; n-out
                            '*  	;; r-val
                            int		;; is-method
                            int		;; throws
                            '*)))	;; g-error

(define g_callable_info_is_method
  (pointer->procedure int
                      (dynamic-func "g_callable_info_is_method"
				    %libgirepository)
                      (list '*)))

(define g_callable_info_may_return_null
  (pointer->procedure int
                      (dynamic-func "g_callable_info_may_return_null"
				    %libgirepository)
                      (list '*)))


;;;
;;; Up-on Condition Bindings
;;;

(define g-callable-info-create-closure
  (if (gi-check-version 1 71 0)
      (lambda (info ffi-cif ffi-closure-callback user-data)
        (gi->scm (g_callable_info_create_closure info
                                                 ffi-cif
                                                 ffi-closure-callback
                                                 user-data)
                 'pointer))
      #f))

(define g_callable_info_create_closure
  (if (gi-check-version 1 71 0)
      (pointer->procedure '* ;; *ffi-closure
                          (dynamic-func "g_callable_info_create_closure"
				        %libgirepository)
                          (list '*	;; *callback-info
                                '*	;; *ffi-cif
                                '*	;; *ffi-closure-callback
                                '*))	;; user-data
      #f))

(define g-callable-info-get-closure-native-address
  (if (gi-check-version 1 71 0)
      (lambda (info ffi-closure)
        (gi->scm (g_callable_info_get_closure_native_address info
                                                             ffi-closure)
                 'pointer))
      #f))

(define g_callable_info_get_closure_native_address
    (if (gi-check-version 1 71 0)
      (pointer->procedure '* ;; *ffi-closure
                          (dynamic-func "g_callable_info_get_closure_native_address"
				        %libgirepository)
                          (list '*	;; *callback-info
                                '*))	;; *ffi-closure
      #f))
