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

;;;;
;;;; Copyright (C) 2019 - 2023
;;;; 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:

;; This code is largely inspired by the Guile-Gnome modules
;; (gnome gobject generics) and (gnome gobject gsignal), see:

;;   https://www.gnu.org/software/guile-gnome

;;   http://git.savannah.gnu.org/cgit/guile-gnome.git
;;     tree/glib/gnome/gobject/generic.scm
;;     tree/glib/gnome/gobject/gsignal.scm

;;; Code:


(define-module (g-golf hl-api signal)
  #:use-module (ice-9 threads)
  #:use-module (ice-9 match)
  #:use-module (ice-9 receive)
  #:use-module (srfi srfi-1)
  #:use-module (oop goops)
  #:use-module (g-golf support)
  #:use-module (g-golf gi)
  #:use-module (g-golf glib)
  #:use-module (g-golf gobject)
  #:use-module (g-golf hl-api gtype)
  #:use-module (g-golf hl-api gobject)
  #:use-module (g-golf hl-api argument)
  #:use-module (g-golf hl-api function)
  #:use-module (g-golf hl-api closure)

  #:duplicates (merge-generics
		replace
		warn-override-core
		warn
		last)
  
  #:export (<signal>

            %gi-signal-cache
            gi-signal-cache-ref
            gi-signal-cache-set!
            gi-signal-cache-show
            gi-signal-cache-find))


(g-export describe
          !id
          !name
          !flags
          !iface-type
          !iface-class
          !return-type
          !param-types
          !param-args

          connect
          connect-after
          disconnect
          emit)


;;;
;;; Signal connection
;;;

(define-method (connect (inst <gtype-instance>) name function)
  (signal-connect inst name function #f))

(define-method (connect-after (inst <gtype-instance>) name function)
  (signal-connect inst name function #t))

(define (signal-connect inst s-name function after?)
  ;; Below, i- stands for instance-, o- for object-, s- for signal-
  (let* ((i-class (class-of inst))
         (i-class-name (class-name i-class))
         (i-type (!g-type i-class)))
    (receive (s-id detail)
        (g-signal-parse-name s-name i-type)
      (match (g-signal-query s-id)
        ((id name iface-type flags return-type n-param param-types)
         (let* ((signal (or (gi-signal-cache-ref i-class-name s-name)
                            (make-signal s-id s-name
                                         name i-type i-class-name
                                         flags return-type n-param param-types)))
                (param-args (!param-args signal))
                (closure (make <closure>
                           #:function function
                           #:return-type return-type
                           #:param-types (cons 'object param-types)
                           #:param-args (and param-args
                                             (cons #f param-args)))))
           (g-signal-connect-closure-by-id (!g-inst inst)
                                           (!id signal)
                                           detail
                                           (!g-closure closure)
                                           after?)))))))

(define-method (disconnect (inst <gtype-instance>) handler-id)
  (g-signal-handler-disconnect (!g-inst inst) handler-id))

(define (make-signal id s-name name iface-type iface-name
                     flags return-type n-param param-types)
  (let* ((iface-info (g-irepository-find-by-gtype iface-type))
         (iface-s-info (and iface-info
                            (g-object-info-find-signal iface-info name)))
         (param-args (and iface-s-info
                          (signal-arguments iface-s-info)))
         (s-inst (make <signal>
                   #:id id
                   #:name name
                   #:iface-type iface-type
                   #:flags flags
                   #:return-type return-type
                   #:n-param n-param
                   #:param-types param-types
                   #:param-args param-args)))
    (gi-signal-cache-set! iface-name s-name s-inst)
    s-inst))

(define (signal-arguments info)
  (let loop ((n-arg (g-callable-info-get-n-args info))
             (args '()))
    (if (= n-arg 0)
        args
        (loop (- n-arg 1)
              (cons (make <argument>
                      #:info (g-callable-info-get-arg info
                                                      (- n-arg 1))
                      #:arg-pos n-arg)
                    args)))))

(define-method (emit (inst <gtype-instance>) name . args)
  (apply signal-emit inst name args))

(define %g_value_init
  (@@ (g-golf gobject generic-values) g_value_init))

(define %prepare-g-value-in
  (@@ (g-golf hl-api closure) prepare-g-value-in))

(define %prepare-return-val
  (@@ (g-golf hl-api closure) prepare-return-val))

(define (signal-emit inst s-name . args)
  (let* ((i-class (class-of inst))
         (i-class-name (class-name i-class))
         (i-type (!g-type i-class))
         (s-id (g-signal-lookup (symbol->string s-name) i-type)))
    (if s-id
        (match (g-signal-query s-id)
           ((id name iface-type flags return-type n-param param-types)
            (let* ((%g-value-size (g-value-size))
                   (signal (or (gi-signal-cache-ref i-class-name s-name)
                               (make-signal s-id s-name
                                            name i-type i-class-name
                                            flags return-type n-param param-types)))
                   (params (bytevector->pointer
                            (make-bytevector (* (+ n-param 1) %g-value-size) 0))))
              (%g_value_init params iface-type)
              (g-value-set-object params (!g-inst inst))
              (let loop ((i 0)
                         (g-value (gi-pointer-inc params %g-value-size)))
                (if (= i n-param)
                    'done
                    (let ((type (list-ref param-types i))
                          (val (list-ref args i)))
                      (%prepare-g-value-in g-value type val)
                      (loop (+ i 1)
                            (gi-pointer-inc g-value %g-value-size)))))
              (case return-type
                ((none)
                 (g-signal-emitv params id 0 #f)
                 (values))
                (else
                 (let ((return-val (bytevector->pointer
                                    (make-bytevector %g-value-size 0))))
                   (%prepare-return-val return-val (!return-type signal))
                   (g-signal-emitv params id 0 return-val)
                   (g-value-ref return-val)))))))
        (scm-error 'invalid #f  "Unknown signal ~A on object ~A"
                   (list s-name inst) #f))))


;;;
;;; The <signal> class, accesors and methods
;;;

(define-class <signal> ()
  (id #:accessor !id #:init-keyword #:id #:init-value #f)
  (name #:accessor !name #:init-keyword #:name)
  (iface-type #:accessor !iface-type #:init-keyword #:iface-type)
  (iface-class #:accessor !iface-class #:init-keyword #:iface-class)
  (flags #:accessor !flags #:init-keyword #:flags)
  (return-type #:accessor !return-type #:init-keyword #:return-type)
  (n-param #:accessor !n-param #:init-keyword #:n-param)
  (param-types #:accessor !param-types #:init-keyword #:param-types)
  (param-args #:accessor !param-args #:init-keyword #:param-args #:init-value #f))

(define-method (initialize (self <signal>) initargs)
  (next-method)
  (let* ((iface-type (!iface-type self))
         (iface-class (g-type-cache-ref iface-type)))
    (mslot-set! self
                'iface-class iface-class)))

(define-method (describe (self <signal>))
  (next-method)
  (newline)
  (let ((param-args (!param-args self)))
    (when param-args ;; #f for user defined signals
      (for-each (lambda (argument)
                  (describe argument)
                  (newline))
          param-args))))


;;;
;;; The gi-signal-cache
;;;

(define %gi-signal-cache #f)
(define gi-signal-cache-ref #f)
(define gi-signal-cache-set! #f)
(define gi-signal-cache-show #f)
(define gi-signal-cache-find #f)


(eval-when (expand load eval)
  (let ((gi-signal-cache '()))

    (set! %gi-signal-cache
          (lambda () gi-signal-cache))

    (set! gi-signal-cache-ref
          (lambda (m-key s-key)
            ;; m-key, s-key stand for main and secondary keys
            (let ((subcache (assq-ref gi-signal-cache m-key)))
              (and subcache
                   (assq-ref subcache s-key)))))

    (set! gi-signal-cache-set!
          (lambda (m-key s-key val)
            (let ((subcache (assq-ref gi-signal-cache m-key)))
              (set! gi-signal-cache
                    (assq-set! gi-signal-cache m-key
                               (assq-set! (or subcache '()) s-key
                                          val))))))

    (set! gi-signal-cache-show
          (lambda* (#:optional (m-key #f))
            (format #t "%gi-signal-cache~%")
            (if m-key
                (begin
                  (format #t "  ~A~%" m-key)
                  (for-each (lambda (s-entry)
                              (match s-entry
                                ((s-key . s-vals)
                                 (format #t "    ~A~%" s-key))))
                      (assq-ref gi-signal-cache m-key)))
                (for-each (lambda (m-entry)
                            (match m-entry
                              ((m-key . m-vals)
                               (format #t "  ~A~%" m-key))))
                    gi-signal-cache))
            (values)))

    (set! gi-signal-cache-find
          (lambda (name)
            'wip))))
