Chicken things

zilti/build-system/chicken.scm

@@ -0,0 +1,147 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 raingloom <raingloom@riseup.net>
+;;; Copyright © 2021 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2021 Xinglu Chen <public@yoctocell.xyz>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (zilti build-system chicken)
+  #:use-module (guix utils)
+  #:use-module (guix gexp)
+  #:use-module (guix store)
+  #:use-module (guix monads)
+  #:use-module (guix download)
+  #:use-module (guix search-paths)
+  #:use-module (guix build-system)
+  #:use-module (guix build-system gnu)
+  #:use-module (ice-9 match)
+  #:use-module (srfi srfi-1)
+  #:use-module (guix packages)
+  #:export (%chicken-build-system-modules
+            chicken-build
+            chicken-build-system
+            egg-uri))
+
+(define* (egg-uri name version #:optional (extension ".tar.gz"))
+  "Return a URI string for the CHICKEN egg corresponding to NAME and VERSION.
+EXTENSION is the file name extension, such as '.tar.gz'."
+  (string-append "https://code.call-cc.org/egg-tarballs/5/"
+                 name "/" name "-" version extension))
+
+(define %chicken-build-system-modules
+  ;; Build-side modules imported and used by default.
+  `((zilti build chicken-build-system)
+    (guix build union)
+    ,@%gnu-build-system-modules))
+
+(define (default-chicken)
+  "Return the default Chicken package."
+  ;; Lazily resolve the binding to avoid a circular dependency.
+  (let ((chicken (resolve-interface '(zilti packages chicken))))
+    (module-ref chicken 'chicken)))
+
+(define* (lower name
+                #:key source inputs native-inputs outputs system target
+                (chicken (default-chicken))
+                #:allow-other-keys
+                #:rest arguments)
+  "Return a bag for NAME."
+  (define private-keywords
+    '(#:target #:chicken #:inputs #:native-inputs #:outputs))
+
+  ;; TODO: cross-compilation support
+  (and (not target)
+       (bag
+         (name name)
+         (system system)
+         (host-inputs `(,@(if source
+                              `(("source" ,source))
+                              '())
+                        ,@inputs
+
+                        ;; Keep the standard inputs of 'gnu-build-system', since
+                        ;; Chicken compiles Scheme by using C as an intermediate
+                        ;; language.
+                        ,@(standard-packages)))
+         (build-inputs `(("chicken" ,chicken)
+                         ,@native-inputs))
+         (outputs outputs)
+         (build chicken-build)
+         (arguments
+          (substitute-keyword-arguments
+              (strip-keyword-arguments private-keywords arguments)
+            ((#:extra-directories extra-directories)
+             `(list ,@(append-map
+                       (lambda (name)
+                         (match (assoc name inputs)
+                           ((_ pkg)
+                            (match (package-transitive-propagated-inputs pkg)
+                              (((propagated-names . _) ...)
+                               (cons name propagated-names))))))
+                       extra-directories))))))))
+
+(define* (chicken-build name inputs
+                        #:key source
+                        (tests? #t)
+                        (parallel-build? #f)
+                        (build-flags ''())
+                        (configure-flags ''())
+                        (extra-directories ''())
+                        (phases '%standard-phases)
+                        (outputs '("out" "static"))
+                        (search-paths '())
+                        (egg-name "")
+                        (unpack-path "")
+                        (system (%current-system))
+                        (guile #f)
+                        (imported-modules %chicken-build-system-modules)
+                        (modules '((zilti build chicken-build-system)
+                                   (guix build union)
+                                   (guix build utils))))
+  (define builder
+    (with-imported-modules imported-modules
+      #~(begin
+          (use-modules #$@(sexp->gexp modules))
+          #$(with-build-variables inputs outputs
+              #~(chicken-build #:name #$name
+                               #:source #+source
+                               #:system #$system
+                               #:phases #$phases
+                               #:configure-flags #$configure-flags
+                               #:extra-directories #$extra-directories
+                               #:parallel-build? #$parallel-build?
+                               #:outputs #$(outputs->gexp outputs)
+                               #:search-paths '#$(sexp->gexp
+                                                  (map search-path-specification->sexp
+                                                       search-paths))
+                               #:egg-name #$egg-name
+                               #:unpack-path #$unpack-path
+                               #:build-flags #$build-flags
+                               #:tests? #$tests?
+                               #:inputs #$(input-tuples->gexp inputs))))))
+
+  (mlet %store-monad ((guile (package->derivation (or guile (default-guile))
+                                                  system #:graft? #f)))
+    (gexp->derivation name builder
+                      #:system system
+                      #:guile-for-build guile)))
+
+(define chicken-build-system
+  (build-system
+    (name 'chicken)
+    (description
+     "Build system for Chicken Scheme programs")
+    (lower lower)))

zilti/build/chicken-build-system.scm

@@ -0,0 +1,140 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 raingloom <raingloom@riseup.net>
+;;;
+;;; This file is part of GNU Guix.
+;;;
+;;; GNU Guix is free software; you can redistribute it and/or modify it
+;;; under the terms of the GNU General Public License as published by
+;;; the Free Software Foundation; either version 3 of the License, or (at
+;;; your option) any later version.
+;;;
+;;; GNU Guix 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 General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.
+
+(define-module (zilti build chicken-build-system)
+  #:use-module ((guix build gnu-build-system) #:prefix gnu:)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 ftw)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-26)
+  #:use-module (rnrs io ports)
+  #:use-module (rnrs bytevectors)
+  #:export (%standard-phases
+            chicken-build))
+
+;; CHICKEN_EGG_CACHE is where sources are fetched and binaries are built
+;; CHICKEN_INSTALL_REPOSITORY is where dependencies are looked up
+;; its first component is also where new eggs are installed.
+
+;; TODO: the binary version should be defined in one of the relevant modules
+;; instead of being hardcoded everywhere. Tried to do that but got undefined
+;; variable errors.
+
+(define (chicken-package? name)
+  (string-prefix? "chicken-" name))
+
+(define* (setup-chicken-environment #:key inputs outputs #:allow-other-keys)
+  (setenv "CHICKEN_INSTALL_REPOSITORY"
+          (string-append (assoc-ref outputs "out") "/var/lib/chicken/11/"))
+  (setenv "CHICKEN_INSTALL_PREFIX"
+          (string-append (assoc-ref outputs "out") "/bin/"))
+  (setenv "CHICKEN_REPOSITORY_PATH"
+          (string-append (getenv "CHICKEN_REPOSITORY_PATH")
+                         ":" (getenv "CHICKEN_INSTALL_REPOSITORY")))
+  (setenv "CHICKEN_EGG_CACHE" (getcwd))
+  #t)
+
+;; This is copied from go-build-system.scm so it could probably be simplified.
+;; I used it because the source of the egg needs to be unpacked into a directory
+;; that is named after the egg and I knew that the go build system does that.
+(define* (unpack #:key source egg-name unpack-path #:allow-other-keys)
+  "Relative to $CHICKEN_EGG_CACHE, unpack SOURCE in UNPACK-PATH, or EGG-NAME
+when UNPACK-PATH is unset.  If the SOURCE archive has a single top level
+directory, it is stripped so that the sources appear directly under UNPACK-PATH.
+When SOURCE is a directory, copy its content into UNPACK-PATH instead of
+unpacking."
+  (define (unpack-maybe-strip source dest)
+    (let* ((scratch-dir (string-append (or (getenv "TMPDIR") "/tmp")
+                                       "/scratch-dir"))
+           (out (mkdir-p scratch-dir)))
+      (with-directory-excursion scratch-dir
+        (if (string-suffix? ".zip" source)
+            (invoke "unzip" source)
+            (invoke "tar" "-xvf" source))
+        (let ((top-level-files (remove (lambda (x)
+                                         (member x '("." "..")))
+                                       (scandir "."))))
+          (match top-level-files
+            ((top-level-file)
+             (when (file-is-directory? top-level-file)
+               (copy-recursively top-level-file dest #:keep-mtime? #t)))
+            (_
+             (copy-recursively "." dest #:keep-mtime? #t)))))
+      (delete-file-recursively scratch-dir)))
+
+  (when (string-null? egg-name)
+    (display "WARNING: The egg name is unset.\n"))
+  (when (string-null? unpack-path)
+    (set! unpack-path egg-name))
+  (let ((dest (string-append (getenv "CHICKEN_EGG_CACHE") "/" unpack-path)))
+    (mkdir-p dest)
+    (if (file-is-directory? source)
+        (copy-recursively source dest #:keep-mtime? #t)
+        (unpack-maybe-strip source dest)))
+  #t)
+
+(define* (build #:key egg-name #:allow-other-keys)
+  "Build the Chicken egg named by EGG-NAME"
+  (invoke "echo" (getenv "CHICKEN_REPOSITORY_PATH"))
+  (invoke "chicken-install" "-cached" "-no-install" egg-name))
+
+(define* (install #:key egg-name #:allow-other-keys)
+  "Install the already built egg named by EGG-NAME"
+  (invoke "chicken-install" "-cached" egg-name))
+
+(define* (check #:key egg-name tests? #:allow-other-keys)
+  "Build and run tests for the Chicken egg EGG-NAME"
+  ;; there is no "-test-only" option, but we've already run install
+  ;; so this just runs tests.
+  ;; i think it's a fair assumption that phases won't be reordered.
+  (when tests?
+    (invoke "echo" (getenv "CHICKEN_REPOSITORY_PATH"))
+    (invoke "chicken-install" "-cached" "-test" "-no-install" egg-name)))
+
+(define* (stamp-egg-version #:key egg-name name #:allow-other-keys)
+  "Check if EGG-NAME.egg contains version information and add some if not."
+  (let* ((filename (string-append egg-name "/" egg-name ".egg"))
+         (egg-info (call-with-input-file filename read))
+         (ver? (find (lambda (i) (eqv? (car i) 'version)) egg-info))
+         (ver (substring name (1+ (string-rindex name #\-)))))
+    (when (not ver?)
+      (make-file-writable filename)
+      (call-with-output-file filename
+        (lambda (f) (write (cons `(version ,ver) egg-info) f))))))
+
+;; It doesn't look like Chicken generates any unnecessary references.
+;; So we don't have to remove them either. Nice.
+
+(define %standard-phases
+  (modify-phases gnu:%standard-phases
+    (replace 'unpack unpack)
+    (delete 'bootstrap)
+    (delete 'configure)
+    (delete 'patch-generated-file-shebangs)
+    (add-before 'unpack 'setup-chicken-environment setup-chicken-environment)
+    (add-before 'build 'stamp-egg-version stamp-egg-version)
+    (replace 'build build)
+    (delete 'check)
+    (replace 'install install)
+    (add-after 'install 'check check)))
+
+(define* (chicken-build #:key inputs (phases %standard-phases)
+                        #:allow-other-keys #:rest args)
+  "Build the given Chicken package, applying all of PHASES in order."
+  (apply gnu:gnu-build #:inputs inputs #:phases phases args))

zilti/packages/chicken.scm

@@ -21,7 +21,7 @@
 (define-module (zilti packages chicken)
   #:use-module (gnu packages)
   #:use-module (guix packages)
-  #:use-module (guix build-system chicken)
+  #:use-module (zilti build-system chicken)
   #:use-module (guix build-system gnu)
   #:use-module (guix download)
   #:use-module (guix git-download)
@@ -129,7 +129,7 @@ file indexing tool.")
 (define-public chicken-check-errors
   (package
     (name "chicken-check-errors")
-    (version "3.6.0")
+    (version "3.7.1")
     (source
      (origin
        (method url-fetch)
@@ -214,7 +214,7 @@ and manipulating lists and pairs.")
 (define-public chicken-srfi-13
   (package
     (name "chicken-srfi-13")
-    (version "0.3.2")
+    (version "0.3.4")
     (source (origin
               (method url-fetch)
               (uri (egg-uri "srfi-13" version))
@@ -261,7 +261,7 @@ a characters and be compared to other character sets")
 (define-public chicken-srfi-18
   (package
     (name "chicken-srfi-18")
-    (version "0.1.6")
+    (version "0.1.7")
     (source (origin
               (method url-fetch)
               (uri (egg-uri "srfi-18" version))
@@ -285,7 +285,7 @@ multiple processor cores is not available.")
 (define-public chicken-srfi-69
   (package
     (name "chicken-srfi-69")
-    (version "0.4.1")
+    (version "0.4.3")
     (source
      (origin
        (method svn-fetch)
@@ -340,6 +340,31 @@ variant records, as described in the book @i{Essentials of Programming
 Languages} by Friedman, Wand, and Haynes.")
     (license license:bsd-3)))
 
+(define-public chicken-fmt
+  (package
+   (name "chicken-fmt")
+   (version "0.8.11.2")
+   (source
+    (origin
+     (method url-fetch)
+     (uri (egg-uri "fmt" version))
+     (sha256
+      (base32
+       "1x7al8nknj1xbs6hjfs6gs2h6cjy29gnhplvqisbqdpzxyq5zs20"))))
+   (propagated-inputs
+    (list chicken-srfi-1
+          chicken-srfi-13
+          chicken-srfi-69
+          chicken-utf8))
+   (native-inputs
+    (list chicken-test))
+   (build-system chicken-build-system)
+   (arguments '(#:egg-name "fmt"))
+   (synopsis "A library of procedures for formatting Scheme objects to text in various ways")
+   (home-page "https://wiki.call-cc.org/eggref/5/fmt")
+   (description "A library of procedures for formatting Scheme objects to text in various ways")
+   (license license:bsd-2)))
+
 (define-public chicken-iset
   (package
     (name "chicken-iset")
@@ -369,6 +394,28 @@ Bit-vectors provide an abstract interface to bitwise operations typically done
 with integers.")
     (license license:bsd-3)))
 
+(define-public chicken-matchable
+  (package
+   (name "chicken-matchable")
+   (version "1.1")
+   (source
+    (origin
+     (method url-fetch)
+     (uri (egg-uri "matchable" version))
+     (sha256
+      (base32
+       "0bizkac4a926lbk0v2m05ysq359mzhfsqh973m72jc4gcj4azr5p"))))
+   (propagated-inputs
+    (list ))
+   (native-inputs
+    (list chicken-test))
+   (build-system chicken-build-system)
+   (arguments '(#:egg-name "matchable"))
+   (synopsis "This extension implements Andrew Wright's pattern matching macros.")
+   (home-page "https://wiki.call-cc.org/eggref/5/matchable")
+   (description "This extension implements Andrew Wright's pattern matching macros.")
+   (license license:bsd-2)))
+
 (define-public chicken-miscmacros
   (package
    (name "chicken-miscmacros")
@@ -394,7 +441,7 @@ with integers.")
 (define-public chicken-string-utils
   (package
    (name "chicken-string-utils")
-   (version "2.7.1")
+   (version "2.7.3")
    (source
     (origin
      (method url-fetch)
@@ -413,6 +460,28 @@ with integers.")
    (description "String utilities.")
    (license license:bsd-2)))
 
+(define-public chicken-sxml-transforms
+  (package
+   (name "chicken-sxml-transforms")
+   (version "1.4.3")
+   (source
+    (origin
+     (method url-fetch)
+     (uri (egg-uri "sxml-transforms" version))
+     (sha256
+      (base32
+       "0cvpqgjwz1p5vg8jwjr2p1l3hx9s02f083g84v16wv88y3d5rsbg"))))
+   (propagated-inputs
+    (list chicken-srfi-13))
+   (native-inputs
+    (list ))
+   (build-system chicken-build-system)
+   (arguments '(#:egg-name "sxml-transforms"))
+   (synopsis "This is the sxml-transforms extension library for Chicken Scheme.")
+   (home-page "https://wiki.call-cc.org/eggref/5/sxml-transforms")
+   (description "This is the sxml-transforms extension library for Chicken Scheme.")
+   (license license:bsd-2)))
+
 (define-public chicken-symbol-utils
   (package
    (name "chicken-symbol-utils")
@@ -438,7 +507,7 @@ with integers.")
 (define-public chicken-test
   (package
     (name "chicken-test")
-    (version "1.1")
+    (version "1.2")
     (source
      (origin
        (method svn-fetch)
@@ -506,7 +575,7 @@ with integers.")
 (define-public chicken-utf8
   (package
     (name "chicken-utf8")
-    (version "3.5.0")
+    (version "3.6.3")
     (source
      (origin
        (method url-fetch)
@@ -517,9 +586,9 @@ with integers.")
     ;; TODO do we really have to make these propagated?
     ;; I don't know Chicken's module system well enough to tell
     (propagated-inputs
-     (list chicken-iset))
+     (list chicken-iset chicken-srfi-69 chicken-regex))
     (native-inputs
-     (list chicken-srfi-69 chicken-regex))
+     (list chicken-test))
     (build-system chicken-build-system)
     (arguments '(#:egg-name "utf8"))
     (synopsis "Unicode support")
@@ -553,3 +622,30 @@ with integers.")
     (description
      "An apropos facility for CHICKEN Scheme.")
     (license license:bsd-2)))
+
+(define-public chicken-chicken-doc
+  (package
+   (name "chicken-chicken-doc")
+   (version "0.7.0")
+   (source
+    (origin
+     (method url-fetch)
+     (uri (egg-uri "chicken-doc" version))
+     (sha256
+      (base32
+       "1p7i5dsi9x8kfchh3xdw9ww9pz2p861v8vynqzwmbclpqjrspllh"))))
+   (propagated-inputs
+    (list chicken-matchable
+          chicken-fmt
+          chicken-sxml-transforms
+          chicken-srfi-1
+          chicken-srfi-13
+          chicken-srfi-69))
+   (native-inputs
+    (list ))
+   (build-system chicken-build-system)
+   (arguments '(#:egg-name "chicken-doc"))
+   (synopsis "chicken-doc is a tool for exploring Chicken documentation.")
+   (home-page "https://wiki.call-cc.org/eggref/5/doc")
+   (description "chicken-doc is a tool for exploring Chicken documentation.")
+   (license license:bsd-2)))

zilti/packages/hyprland.scm

@@ -79,40 +79,6 @@ Each database is contained in a specific package output, such as the
     (license (list license:gpl2+
                    license:expat)))) ;XFree86 1.0
 
-(define-public pixman
-  (package
-    (name "pixman")
-    (version "0.42.2")
-    (source
-     (origin
-       (method url-fetch)
-       (uri
-        (string-append
-         "https://www.cairographics.org/releases/pixman-"
-         version ".tar.gz"))
-       (sha256
-        (base32 "0pk298iqxqr64vk3z6nhjwr6vjg1971zfrjkqy5r9zd2mppq057a"))
-       (patches
-        (search-patches
-         "pixman-CVE-2016-5296.patch"))))
-    (build-system gnu-build-system)
-    (arguments
-     `(#:configure-flags
-       (list
-        "--disable-static"
-        "--enable-timers"
-        "--enable-gnuplot")))
-    (native-inputs
-     (list pkg-config))
-    (inputs
-     (list libpng zlib))
-    (synopsis "Low-level pixel manipulation library")
-    (description "Pixman is a low-level software library for pixel
-manipulation, providing features such as image compositing and trapezoid
-rasterisation.")
-    (home-page "http://www.pixman.org/")
-    (license license:expat)))
-
 (define-public libinput-1.24
   ;; Updating this will rebuild over 700 packages through libinput-minimal.
   (package
@@ -207,82 +173,6 @@ including drivers for chipsets produced by 3DFX, AMD (formerly ATI), Intel
 and Matrox.")
     (license license:x11)))
 
-(define-public wlroots-0.17
-  (package
-    (name "wlroots")
-    (version "0.17.0")
-    (source
-     (origin
-       (method git-fetch)
-       (uri (git-reference
-             (url "https://gitlab.freedesktop.org/wlroots/wlroots")
-             (commit version)))
-       (file-name (git-file-name name version))
-       (sha256
-        (base32 "11vb6xjvsjz7j2jkx00ygjp5xi63ni8ydd8wf3s0200ldr4ffjjm"))))
-    (build-system meson-build-system)
-    (arguments
-     `(#:configure-flags
-       '("-Dauto_features=enabled")
-       #:phases
-       (modify-phases
-        %standard-phases
-        (add-before 'configure 'hardcode-paths
-                    (lambda* (#:key inputs #:allow-other-keys)
-                      (substitute* "xwayland/server.c"
-                                   (("Xwayland") (string-append (assoc-ref inputs
-                                                                           "xorg-server-xwayland")
-                                                                "/bin/Xwayland")))
-                      #t))
-        (add-before 'configure 'fix-meson-file
-                    (lambda* (#:key native-inputs inputs #:allow-other-keys)
-                      (substitute* "backend/drm/meson.build"
-                                   (("/usr/share/hwdata/pnp.ids")
-                                    (string-append (assoc-ref (or native-inputs inputs) "hwdata")
-                                                   "/share/hwdata/pnp.ids"))))))))
-    (propagated-inputs
-     (list ;; As required by wlroots.pc.
-           eudev
-           ffmpeg-4
-           glslang
-           libxkbcommon
-           mesa
-           pixman
-           libcap
-           libdisplay-info
-           libinput-1.24
-           libpng
-           libseat
-           libxkbcommon
-           mesa
-           vulkan-loader
-           wayland
-           wayland-protocols
-           xcb-util-errors
-           xcb-util-renderutil
-           xcb-util-wm
-           xorg-server-xwayland))
-    (inputs
-     (list libdrm-2.4.118))
-    (native-inputs
-     (cons*
-       `(,hwdata "pnp")
-       cmake
-       hwdata
-       mesa-headers
-       vulkan-headers
-       pkg-config
-       wayland
-       (if (%current-target-system)
-         (list pkg-config-for-build)
-         '())))
-    (home-page "https://gitlab.freedesktop.org/wlroots/wlroots/")
-    (synopsis "Pluggable, composable, unopinionated modules for building a
-Wayland compositor")
-    (description "wlroots is a set of pluggable, composable, unopinionated
-modules for building a Wayland compositor.")
-    (license license:expat)))
-
 (define-public wlroots-master
   (package
    (name "wlroots")