#! /bin/sh
# -*- mode: scheme; coding: utf-8 -*-
exec guile -e main -s "$0" "$@"
!#


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

;;; Code:


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

  (g-irepository-require "Gtk" #:version "4.0")
  (for-each (lambda (name)
              (gi-import-by-name "Gdk" name))
      '("Display"))

  (for-each (lambda (name)
              (gi-import-by-name "Gtk" name))
      '("Application"
        "ApplicationWindow"
        "Box"
        "Label"
        "Entry"
        "Button"
        "Image")))


(define (activate app)
  (let* ((cwd (getcwd))
         (display (gdk-display-get-default))
         (clipboard (get-clipboard display))
         (window (make <gtk-application-window>
                   #:title "Clipboard"
                   #:default-width 660
                   #:default-height 420
                   #:application app))
         (box (make <gtk-box>
                #:orientation 'vertical
                #:margin-top 24
                #:margin-start 24
                #:margin-bottom 24
                #:margin-end 24
                #:halign 'center
                #:valign 'center
                #:spacing 24))
         (title-1 (make <gtk-label>
                    #:label "Text"
                    #:halign 'start
                    #:css-classes '("title-2")))
         (box-1 (make <gtk-box>
                  #:orientation 'horizontal
                  #:halign 'center
                  #:spacing 24))
         (entry-from (make <gtk-entry>
                       #:placeholder-text "Type text to copy"))
         (copy-1 (make <gtk-button> #:label "Copy"))
         (entry-to (make <gtk-entry>))
         (paste-1 (make <gtk-button> #:label "Paste"))
         (title-2 (make <gtk-label>
                    #:label "Texture"
                    #:halign 'start
                    #:css-classes '("title-2")))
         (box-2 (make <gtk-box>
                  #:orientation 'horizontal
                  #:halign 'center
                  #:spacing 24))
         (path (string-append cwd "/images/levitating-gnu.png"))
         (g-file (g-file-new-for-path path))
         (texture (gdk-texture-new-from-file g-file))
         (image-from (make <gtk-image>
                       #:pixel-size 96
                       #:paintable texture))
         (copy-2 (make <gtk-button>
                   #:label "Copy"
                   #:valign 'center))
         (image-to (make <gtk-image>
                     #:pixel-size 96
                     #:icon-name "image-missing"))
         (paste-2 (make <gtk-button>
                    #:label "Paste"
                    #:valign 'center)))

    (connect copy-1
             'clicked
             (lambda (b)
               (set clipboard (!text entry-from))))

    (connect paste-1
             'clicked
             (lambda (b)
               (let* ((content-provider (get-content clipboard))
                      (value (and content-provider
                                  (get-value content-provider))))
                 (and value
                      (if (is-a? value <string>)
                          (set-text entry-to value)
                          (warning "Can't paste, expecting a <string>, got " value))))))

    (connect copy-2
             'clicked
             (lambda (b)
               (set clipboard (!paintable image-from))))

    (connect paste-2
             'clicked
             (lambda (b)
               (let* ((content-provider (get-content clipboard))
                      (value (and content-provider
                                  (get-value content-provider))))
                 (and value
                      (if (is-a? value <gdk-texture>)
                          (set! (!paintable image-to) value)
                          (warning "Can't paste, expecting a <gdk-texture>, got " value))))))

    (set-child window box)
    (append box title-1)
    (append box box-1)
    (append box-1 entry-from)
    (append box-1 copy-1)
    (append box-1 entry-to)
    (append box-1 paste-1)
    (append box title-2)
    (append box box-2)
    (append box-2 image-from)
    (append box-2 copy-2)
    (append box-2 image-to)
    (append box-2 paste-2)
    (present window)))


(define (main args)
  (letrec ((debug? (or (member "-d" args)
                       (member "--debug" args)))
           (animate
            (lambda ()
              (let ((app (make <gtk-application>
                           #:application-id "org.gnu.g-golf.gtk4.clipboard")))
                (connect app 'activate activate)
                (let ((status (run app '())))
                  (exit status))))))
    (if debug?
        (parameterize ((%debug #t))
          (animate))
        (animate))))
