Subject: [PATCH 4/5] gnu: Add G-Golf's GTK-4 examples.

From: Florian Pelz <[email-masked]>
Date: Mon, 17 Feb 2025 00:54:08 +0100

* gnu/packages/guile-xyz.scm (g-golf-gtk-4-examples): New variable.

Change-Id: I19b182eb71095ca2deacdb4011c8f50dfcfc8476
---
 gnu/packages/guile-xyz.scm | 182 ++++++++++++++++++++++++++++++++++++-
 1 file changed, 181 insertions(+), 1 deletion(-)

diff --git a/gnu/packages/guile-xyz.scm b/gnu/packages/guile-xyz.scm
index 9877e01748..7ca6a1bd75 100644
--- a/gnu/packages/guile-xyz.scm
+++ b/gnu/packages/guile-xyz.scm
@@ -1,4 +1,4 @@
-;;; GNU Guix --- Functional package management for GNU
+;; GNU Guix --- Functional package management for GNU
 ;;; Copyright © 2012-2024 Ludovic Courtès <[email-masked]>
 ;;; Copyright © 2014, 2015, 2018 Mark H Weaver <[email-masked]>
 ;;; Copyright © 2015, 2017, 2022 Christine Lemmer-Webber <[email-masked]>
@@ -53,6 +53,7 @@
 ;;; Copyright © 2024 Alec Barreto <[email-masked]>
 ;;; Copyright © 2024 Josep Bigorra <[email-masked]>
 ;;; Copyright © 2024 Ashish SHUKLA <[email-masked]>
+;;; Copyright © 2025 Florian Pelz <[email-masked]>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -2623,6 +2624,185 @@ (define-public guile2.2-g-golf
        (replace "guile" guile-2.2)
        (replace "guile-lib" guile2.2-lib)))))
 
+(define-public g-golf-gtk-4-examples
+  (package
+    (inherit guile-g-golf)
+    (name "g-golf-gtk-4-examples")
+    (arguments
+     (list
+      #:modules `(((guix build guile-build-system)
+                   #:select
+                   (target-guile-effective-version))
+                  (srfi srfi-26)
+                  ,@%default-gnu-modules)
+      #:phases
+      (with-imported-modules `((guix build guile-build-system)
+                               ,@%default-gnu-imported-modules)
+        #~(modify-phases %standard-phases
+            (add-after 'unpack 'prepare-examples
+              (lambda _
+                (chdir "examples/gtk-4")
+                ;; Re-use the existing Makefile for its wildcard syntax.
+                (rename-file "Makefile.am" "Makefile")
+                ;; Add a rule to install the examples.  This also
+                ;; installs UI, CSS and Scheme files to /bin, but
+                ;; better keep how G-Golf packages them.
+                (let ((port (open-file "Makefile" "al")))
+                  (format port "
+prefix = ~a
+bindir = $(prefix)/bin
+.PHONY: install
+install:
+	mkdir -p $(bindir)/css
+	mkdir -p $(bindir)/demos
+	mkdir -p $(bindir)/images
+	mkdir -p $(bindir)/ui
+	for f in $(EXTRA_DIST); do      \\
+	  cp $$f $(bindir)/$$f; \\
+	done
+	install demos/libfpt.so $(bindir)/demos
+" #$output)
+                  (close-port port))))
+            (delete 'configure)
+            (replace 'build
+              (lambda _
+                ;; The layout-manager-2 example calls `make', GCC at run-time.
+                ;; But since it would compile to the read-only /gnu/store, we
+                ;; deviate by compiling in advance in the build phase,
+                ;; ignoring failing `make' calls.  We do not propagate `make'.
+                (with-directory-excursion "demos"
+                  (when #$(%current-target-system)
+                    (substitute* "Makefile"
+                      (("^CC = gcc$")
+                       (string-append "CC = " #$(cc-for-target) "\n"))))
+                  (system* "make"))))
+            ;; There are no tests for examples, but we do an installcheck phase,
+            ;; which respects when #:tests? is turned off.  So delete 'check.
+            (delete 'check)
+            (add-before 'install 'patch-scm-files
+              (lambda* (#:key inputs #:allow-other-keys)
+                ;; `current-filename' calls in examples are broken.
+                (map (lambda (binary)
+                       (let ((installed-binary (string-append
+                                                #$output "/bin/" binary)))
+                         (substitute* binary
+                           (("\\(current-filename\\)")
+                            (string-append "\"" installed-binary "\""))
+                           (("\\(getcwd\\)")
+                            (string-append "\"" #$output "/bin\""))
+                           (("^exec guile ")
+                            (string-append
+                             "exec " (search-input-file inputs "/bin/guile")
+                             " ")))))
+                     (map (cut string-drop <> 2) ;strip ./ prefix
+                          (find-files "." (lambda (file stat)
+                                        ;executables or .scm modules
+                                            (or (= (stat:perms stat) #o755)
+                                                (string-suffix? ".scm"
+                                                                file))))))))
+            (add-after 'install 'wrap-binaries
+              (lambda* (#:key inputs #:allow-other-keys)
+                (let* ((version (target-guile-effective-version))
+                       (g-golf (assoc-ref inputs "guile-g-golf"))
+                       (gcairo (assoc-ref inputs "guile-cairo-next"))
+                       (adwaita-icons (assoc-ref inputs "adwaita-icon-theme"))
+                       (scm (string-append "/share/guile/site/" version))
+                       (go (string-append "/lib/guile/"
+                                          version "/site-ccache"))
+                       (binaries
+                        (find-files "." (lambda (file stat) ;executables
+                                          (= (stat:perms stat) #o755)))))
+                  (map (lambda (binary)
+                         (let ((installed-binary (string-append
+                                                  #$output "/bin/" binary)))
+                           (wrap-program installed-binary
+                             `("GUILE_LOAD_PATH" prefix
+                               (,(string-append g-golf scm)
+                                ,(string-append gcairo scm)))
+                             `("GUILE_LOAD_COMPILED_PATH" prefix
+                               (,(string-append g-golf go)
+                                ,(string-append gcairo go)))
+                             `("GI_TYPELIB_PATH" prefix
+                               (,(getenv "GI_TYPELIB_PATH")))
+                             ;; Library path for libraries loaded by binaries.
+                             `("LD_LIBRARY_PATH" prefix
+                               (,(string-append gcairo "/lib")))
+                             `("XDG_DATA_DIRS" suffix
+                               (,(string-append adwaita-icons "/share"))))))
+                       binaries))))
+            ;; Add installcheck to ensure nothing breaks.
+            (add-after 'strip 'installcheck
+              (lambda* (#:key inputs tests? #:allow-other-keys)
+                (cond
+                 ((not tests?)
+                  (display "test suite not run\n"))
+                 (#$(%current-target-system)
+                  (display "cross-compiling; reftest skipped\n"))
+                 (else
+                  ;; Start an X server.
+                  (system "Xvfb :1 &")
+                  (setenv "DISPLAY" ":1")
+                  (let* ((g-golf-drawing (string-append
+                                          #$output "/bin/drawing-widget"))
+                         (pid (spawn g-golf-drawing `(,g-golf-drawing)
+                                     #:search-path? #f)))
+                    (sleep 10) ;2s is enough on my machine
+                    (display "Taking a screenshot with G-Golf.\n")
+                    (system* "import" "-window" "root"
+                             "drawing-widget.out.png")
+                    (sleep 5) ;1s is enough on my machine
+                    (kill pid SIGINT)
+                    (waitpid pid))
+                  (let* ((python (search-input-file inputs "/bin/python3"))
+                         (pygobject-drawing #$(this-package-native-input
+                                               "drawing-widget.py"))
+                         (pid (spawn python `(,python ,pygobject-drawing)
+                                     #:search-path? #f)))
+                    (sleep 5) ;1s is enough on my machine
+                    (display "Taking a screenshot with Pygobject.\n")
+                    (system* "import" "-window" "root"
+                             "drawing-widget.ref.png")
+                    (sleep 5)
+                    (kill pid SIGINT)
+                    (waitpid pid))
+                  (if (= (pk (system* "compare" "-metric" "AE" "-fuzz" "1%"
+                                      "drawing-widget.out.png"
+                                      "drawing-widget.ref.png"
+                                      "drawing-widget.dif.png")) 0)
+                      (display "All good; they look the same.\n")
+                      (error "Reftest failed; screenshots differ."))))))))))
+    (inputs
+     (list adwaita-icon-theme
+           bash-minimal
+           gtk
+           guile-3.0
+           guile-cairo-next
+           guile-g-golf))
+    (native-inputs
+     (list pkg-config
+           which
+           ;; For installcheck:
+           imagemagick
+           python-minimal
+           python-pygobject
+           xorg-server-for-tests
+           ;; Python version of drawing-widget from
+           ;; https://lists.gnu.org/archive/html/guile-user/2024-05/msg00032.html
+           (origin
+             (method url-fetch)
+             (uri "\
+https://lists.gnu.org/archive/html/guile-user/2024-05/txtT_80XuINsX.txt")
+             (sha256
+              (base32
+               "07j2v159a3bb99i8kwbqrcgslcmhhnqa5ah53q2b9bdk8042grsx"))
+             (file-name "drawing-widget.py"))))
+    (propagated-inputs (list))
+    (synopsis "Example GTK 4 apps written in Guile with G-Golf")
+    (description
+     "G-Golf port of (a subset of) the upstream @code{gtk4-demo} examples in
+the @code{gtk:bin} Guix package output.  They also show how to wrap G-Golf
+applications in a Guix package.")))
+
 (define-public g-wrap
   (package
     (name "g-wrap")
-- 
2.48.1