mirror of
https://codeberg.org/guix/guix.git
synced 2025-10-02 02:15:12 +00:00
gnu: Add G-Golf's GTK-4 examples.
* gnu/packages/guile-xyz.scm (g-golf-gtk-4-examples): New variable. Change-Id: I19b182eb71095ca2deacdb4011c8f50dfcfc8476
This commit is contained in:
Florian Pelz
parent
15b34a875f
commit
3bf8de93e7
1 changed files with 190 additions and 0 deletions
|
|
@ -53,6 +53,7 @@
|
||||||
;;; Copyright © 2024 Alec Barreto <mrh57@posteo.net>
|
;;; Copyright © 2024 Alec Barreto <mrh57@posteo.net>
|
||||||
;;; Copyright © 2024 Josep Bigorra <jjbigorra@gmail.com>
|
;;; Copyright © 2024 Josep Bigorra <jjbigorra@gmail.com>
|
||||||
;;; Copyright © 2024 Ashish SHUKLA <ashish.is@lostca.se>
|
;;; Copyright © 2024 Ashish SHUKLA <ashish.is@lostca.se>
|
||||||
|
;;; Copyright © 2025 Florian Pelz <pelzflorian@pelzflorian.de>
|
||||||
;;;
|
;;;
|
||||||
;;; This file is part of GNU Guix.
|
;;; This file is part of GNU Guix.
|
||||||
;;;
|
;;;
|
||||||
|
|
@ -2648,6 +2649,195 @@ are unaffected.")
|
||||||
(replace "guile" guile-2.2)
|
(replace "guile" guile-2.2)
|
||||||
(replace "guile-lib" guile2.2-lib)))))
|
(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. We install to the
|
||||||
|
;; documentation directory where examples are usually located,
|
||||||
|
;; but we will later create a copy in /bin for `guix shell'.
|
||||||
|
(let ((port (open-file "Makefile" "al")))
|
||||||
|
(format port "
|
||||||
|
prefix = ~a
|
||||||
|
bindir = $(prefix)/bin
|
||||||
|
examplesdir = $(prefix)/share/doc/g-golf/examples/gtk-4
|
||||||
|
.PHONY: install
|
||||||
|
install:
|
||||||
|
mkdir -p $(bindir)
|
||||||
|
mkdir -p $(examplesdir)/css
|
||||||
|
mkdir -p $(examplesdir)/demos
|
||||||
|
mkdir -p $(examplesdir)/images
|
||||||
|
mkdir -p $(examplesdir)/ui
|
||||||
|
for f in $(EXTRA_DIST); do \\
|
||||||
|
cp $$f $(examplesdir)/$$f; \\
|
||||||
|
done
|
||||||
|
install demos/libfpt.so $(examplesdir)/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 "\
|
||||||
|
/share/doc/g-golf/examples/gtk-4/" binary)))
|
||||||
|
(substitute* binary
|
||||||
|
(("\\(current-filename\\)")
|
||||||
|
(string-append "\"" installed-binary "\""))
|
||||||
|
(("\\(getcwd\\)")
|
||||||
|
(string-append "\"" #$output "\
|
||||||
|
/share/doc/g-golf/examples/gtk-4\""))
|
||||||
|
(("^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 "/\
|
||||||
|
share/doc/g-golf/examples/gtk-4/" 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"))))
|
||||||
|
;; Also create a copy in /bin for `guix shell'.
|
||||||
|
(copy-file installed-binary
|
||||||
|
(string-append #$output "/bin/" binary))))
|
||||||
|
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 "\
|
||||||
|
/share/doc/g-golf/examples/gtk-4/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 "G-Golf GTK 4 examples")
|
||||||
|
(description
|
||||||
|
"G-Golf port of (a subset of) the upstream @code{gtk4-demo} examples in
|
||||||
|
the @code{gtk:bin} Guix package output. Run @command{guix edit
|
||||||
|
g-golf-gtk-4-examples} for inspiration how to wrap G-Golf applications when
|
||||||
|
writing a Guix package.")))
|
||||||
|
|
||||||
(define-public g-wrap
|
(define-public g-wrap
|
||||||
(package
|
(package
|
||||||
(name "g-wrap")
|
(name "g-wrap")
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue