From 4de445f3dae5f5b42d59003cceddecfb296fb73b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 31 Jul 2022 23:03:36 +0200 Subject: guix gc: '--delete-generations' now deletes old Home generations. This reverts commit 24c0518dd404cbb3c434fb6704f4f551bbc78693, thereby reinstating ba22560627f848f40891a56355ff26b6de1380bc, with an additional fix in (guix self). Fixes . Reported by "(" . * guix/scripts/gc.scm (guix-gc)[delete-generations]: Add call to 'home-generation-base'. * guix/self.scm (compiled-guix)[*core-cli-modules*]: Remove (guix scripts gc). * doc/guix.texi (Invoking guix gc): Document the change. --- guix/scripts/gc.scm | 6 ++++-- guix/self.scm | 1 + 2 files changed, 5 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/scripts/gc.scm b/guix/scripts/gc.scm index 043273f491..65cd4bdf8b 100644 --- a/guix/scripts/gc.scm +++ b/guix/scripts/gc.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2012-2013, 2015-2020, 2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -26,6 +26,7 @@ profile-generations generation-number) #:autoload (guix scripts package) (delete-generations) + #:autoload (gnu home) (home-generation-base) #:use-module (ice-9 match) #:use-module (ice-9 regex) #:use-module (srfi srfi-1) @@ -260,7 +261,8 @@ is deprecated; use '-D'~%")) (filter-map (lambda (root) (and (or (zero? (getuid)) (user-owned? root)) - (generation-profile root))) + (or (generation-profile root) + (home-generation-base root)))) (gc-roots))))) (for-each (lambda (profile) (delete-old-generations store profile pattern)) diff --git a/guix/self.scm b/guix/self.scm index d1ccec8a49..fc80e78804 100644 --- a/guix/self.scm +++ b/guix/self.scm @@ -929,6 +929,7 @@ itself." (('guix 'scripts 'deploy) #t) (('guix 'scripts 'home . _) #t) (('guix 'scripts 'import . _) #t) + (('guix 'scripts 'gc) #t) ;autoloads (gnu home) (('guix 'pack) #t) (_ #f)) (scheme-modules* source "guix/scripts")) -- cgit v1.2.3 From eef8e2ec46c4155980815e00a394428c0c3de075 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 19 Jul 2022 16:52:05 -0400 Subject: gnu: qttools: Rename to qttools-5. Automated with: git grep -l qttools | xargs sed 's/\bqttools\b/\0-5/g' -i git checkout NEWS --- gnu/packages/animation.scm | 2 +- gnu/packages/astronomy.scm | 2 +- gnu/packages/audio.scm | 10 ++-- gnu/packages/benchmark.scm | 2 +- gnu/packages/bittorrent.scm | 2 +- gnu/packages/connman.scm | 2 +- gnu/packages/databases.scm | 2 +- gnu/packages/display-managers.scm | 2 +- gnu/packages/djvu.scm | 2 +- gnu/packages/education.scm | 6 +- gnu/packages/electronics.scm | 2 +- gnu/packages/emulators.scm | 2 +- gnu/packages/engineering.scm | 8 +-- gnu/packages/finance.scm | 24 ++++---- gnu/packages/game-development.scm | 4 +- gnu/packages/games.scm | 12 ++-- gnu/packages/geo.scm | 8 +-- gnu/packages/gps.scm | 4 +- gnu/packages/graphics.scm | 2 +- gnu/packages/hardware.scm | 4 +- gnu/packages/image-processing.scm | 6 +- gnu/packages/image-viewers.scm | 6 +- gnu/packages/image.scm | 2 +- gnu/packages/irc.scm | 2 +- gnu/packages/jami.scm | 2 +- gnu/packages/kde-frameworks.scm | 66 +++++++++++----------- gnu/packages/kde-multimedia.scm | 2 +- gnu/packages/kde-pim.scm | 20 +++---- gnu/packages/kde-utils.scm | 2 +- gnu/packages/kde.scm | 16 +++--- gnu/packages/lego.scm | 2 +- gnu/packages/linphone.scm | 2 +- gnu/packages/lxqt.scm | 52 ++++++++--------- gnu/packages/maths.scm | 8 +-- gnu/packages/messaging.scm | 6 +- gnu/packages/music.scm | 36 ++++++------ gnu/packages/networking.scm | 2 +- gnu/packages/password-utils.scm | 4 +- gnu/packages/patches/xygrib-fix-finding-data.patch | 2 +- gnu/packages/photo.scm | 2 +- gnu/packages/python-xyz.scm | 2 +- gnu/packages/qt.scm | 26 ++++----- gnu/packages/radio.scm | 8 +-- gnu/packages/robotics.scm | 2 +- gnu/packages/scribus.scm | 2 +- gnu/packages/security-token.scm | 6 +- gnu/packages/sync.scm | 4 +- gnu/packages/synergy.scm | 2 +- gnu/packages/telegram.scm | 2 +- gnu/packages/telephony.scm | 4 +- gnu/packages/text-editors.scm | 2 +- gnu/packages/video.scm | 8 +-- guix/lint.scm | 4 +- 53 files changed, 207 insertions(+), 207 deletions(-) (limited to 'guix') diff --git a/gnu/packages/animation.scm b/gnu/packages/animation.scm index c7f80a4b6a..ba8ce00fbd 100644 --- a/gnu/packages/animation.scm +++ b/gnu/packages/animation.scm @@ -448,7 +448,7 @@ language.") ("qtmultimedia-5" ,qtmultimedia-5) ("libsndfile" ,libsndfile))) (native-inputs - (list qttools)) + (list qttools-5)) (home-page "https://www.lostmarble.com/papagayo/") (synopsis "Lip-syncing for animations") (description diff --git a/gnu/packages/astronomy.scm b/gnu/packages/astronomy.scm index 95659104ce..acac8449ab 100644 --- a/gnu/packages/astronomy.scm +++ b/gnu/packages/astronomy.scm @@ -615,7 +615,7 @@ deconvolution). Such post-processing is not performed by Stackistry.") `(("gettext" ,gettext-minimal) ; xgettext is used at compile time ("perl" ,perl) ; for pod2man ("qtbase" ,qtbase-5) ; Qt MOC is needed at compile time - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (arguments `(#:test-target "test" #:configure-flags (list "-DENABLE_TESTING=1" diff --git a/gnu/packages/audio.scm b/gnu/packages/audio.scm index f0ffeed210..aad86bac06 100644 --- a/gnu/packages/audio.scm +++ b/gnu/packages/audio.scm @@ -587,7 +587,7 @@ implementation of Adaptive Multi Rate Narrowband and Wideband liblo qtbase-5)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "http://alsamodular.sourceforge.net/") (synopsis "Realtime modular synthesizer and effect processor") (description @@ -3097,7 +3097,7 @@ different audio devices such as ALSA or PulseAudio.") (inputs (list jack-1 alsa-lib portaudio qtbase-5 qtx11extras)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "https://qjackctl.sourceforge.io/") (synopsis "Jack server control application") (description "Control a Jack server. Allows you to plug various sources @@ -3218,7 +3218,7 @@ link REQUIRED)")))))) (string-append ide "/bin")) (delete-file scide))))))) (native-inputs - (list ableton-link pkg-config qttools xorg-server-for-tests)) + (list ableton-link pkg-config qttools-5 xorg-server-for-tests)) (inputs (list jack-1 libsndfile fftw @@ -3903,7 +3903,7 @@ interface.") (arguments `(#:tests? #f)) ; no "check" phase (native-inputs - (list qttools pkg-config)) + (list qttools-5 pkg-config)) (inputs (list fluidsynth qtbase-5 qtx11extras)) (home-page "https://qsynth.sourceforge.io") @@ -5456,7 +5456,7 @@ Rate} 3600x2250 bit/s vocoder used in various radio systems.") portaudio ;for portaudio examples qtbase-5 ;for Qt examples qtdeclarative-5 - qttools)) + qttools-5)) (inputs (list jack-1 ;for JACK examples qtquickcontrols-5)) ;for Qt examples diff --git a/gnu/packages/benchmark.scm b/gnu/packages/benchmark.scm index 4ea12e4cf3..7be932f528 100644 --- a/gnu/packages/benchmark.scm +++ b/gnu/packages/benchmark.scm @@ -499,7 +499,7 @@ and options. With careful benchmarking, different hardware can be compared.") (substitute* "src/benchmark.cpp" (("\"fio\"") (format #f "~s" (search-input-file inputs "bin/fio"))))))))) - (native-inputs (list extra-cmake-modules qttools)) + (native-inputs (list extra-cmake-modules qttools-5)) (inputs (list fio qtbase-5)) (home-page "https://github.com/JonMagon/KDiskMark") (synopsis "Simple disk benchmark tool") diff --git a/gnu/packages/bittorrent.scm b/gnu/packages/bittorrent.scm index fe235d4b3b..43fc287b95 100644 --- a/gnu/packages/bittorrent.scm +++ b/gnu/packages/bittorrent.scm @@ -470,7 +470,7 @@ desktops.") (wrap-qt-program "qbittorrent" #:output out #:inputs inputs)) #t))))) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs `(("boost" ,boost) ("libtorrent-rasterbar" ,libtorrent-rasterbar) diff --git a/gnu/packages/connman.scm b/gnu/packages/connman.scm index 71dff3588f..f4e6e43ec8 100644 --- a/gnu/packages/connman.scm +++ b/gnu/packages/connman.scm @@ -165,7 +165,7 @@ sharing) to clients via USB, ethernet, WiFi, cellular and Bluetooth.") (inputs (list qtbase-5)) (native-inputs - (list qttools)) + (list qttools-5)) (build-system gnu-build-system) (arguments '(#:phases diff --git a/gnu/packages/databases.scm b/gnu/packages/databases.scm index 4a28aa79cb..9535b65dbd 100644 --- a/gnu/packages/databases.scm +++ b/gnu/packages/databases.scm @@ -4782,7 +4782,7 @@ a Gtk.Grid Widget.") qscintilla qtbase-5 sqlite)) - (native-inputs (list qttools)) + (native-inputs (list qttools-5)) (home-page "https://sqlitebrowser.org/") (synopsis "Database browser for SQLite") (description "Sqlitebrowser is a high quaility, visual, open source tool to diff --git a/gnu/packages/display-managers.scm b/gnu/packages/display-managers.scm index 32ec5c3141..efeea2924d 100644 --- a/gnu/packages/display-managers.scm +++ b/gnu/packages/display-managers.scm @@ -78,7 +78,7 @@ "0hcdysw8ibr66vk8i7v56l0v5ijvhlq67v4460mc2xf2910g2m72")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules pkg-config qttools)) + (list extra-cmake-modules pkg-config qttools-5)) (inputs (list elogind glib diff --git a/gnu/packages/djvu.scm b/gnu/packages/djvu.scm index b85193ccdb..92b4b6dce7 100644 --- a/gnu/packages/djvu.scm +++ b/gnu/packages/djvu.scm @@ -107,7 +107,7 @@ utilities.") (file-name (git-file-name name version)))) (build-system gnu-build-system) (native-inputs - (list autoconf automake libtool pkg-config qttools)) + (list autoconf automake libtool pkg-config qttools-5)) (inputs (list djvulibre glib libxt libtiff qtbase-5)) (arguments diff --git a/gnu/packages/education.scm b/gnu/packages/education.scm index aabf3dfc21..c5666fb02e 100644 --- a/gnu/packages/education.scm +++ b/gnu/packages/education.scm @@ -174,7 +174,7 @@ of categories with some of the activities available in that category. gettext-minimal kdoctools perl - qttools + qttools-5 xorg-server-for-tests)) (inputs (list openssl @@ -540,7 +540,7 @@ specialized device.") (symlink (string-append openboard "/OpenBoard") (string-append bin "/openboard"))))))))) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list alsa-lib coreutils-minimal ;for patched 'env' shebang @@ -991,7 +991,7 @@ formats.") (arguments '(#:tests? #f)) ; no test target (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list libeb qtbase-5 diff --git a/gnu/packages/electronics.scm b/gnu/packages/electronics.scm index 342294de13..15e7318926 100644 --- a/gnu/packages/electronics.scm +++ b/gnu/packages/electronics.scm @@ -373,7 +373,7 @@ such as: (rmdir "doc/pulseview") (rmdir "doc")))))))) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list boost glib diff --git a/gnu/packages/emulators.scm b/gnu/packages/emulators.scm index ba7fa1dbe2..386e127e1e 100644 --- a/gnu/packages/emulators.scm +++ b/gnu/packages/emulators.scm @@ -744,7 +744,7 @@ The following systems are supported: (list "-DUSE_LZMA=OFF" ;do not use bundled LZMA "-DUSE_LIBZIP=OFF"))) ;use "zlib" instead (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list ffmpeg libedit diff --git a/gnu/packages/engineering.scm b/gnu/packages/engineering.scm index 303dd0b737..57efaee50b 100644 --- a/gnu/packages/engineering.scm +++ b/gnu/packages/engineering.scm @@ -762,7 +762,7 @@ ready for production.") (substitute* "qelectrotech.pro" (("\\/usr\\/local") out)) (invoke "qmake"))))))) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list kcoreaddons kwidgetsaddons qtbase-5 qtsvg-5 sqlite)) (home-page "https://qelectrotech.org/") @@ -2120,7 +2120,7 @@ parallel computing platforms. It also supports serial execution.") (inputs (list qtbase-5 qtsvg-5 zlib)) (native-inputs - (list qttools ; for lrelease + (list qttools-5 ; for lrelease unzip)) (arguments `(#:phases @@ -2452,7 +2452,7 @@ comments."))) (native-inputs (list doxygen graphviz - qttools + qttools-5 pkg-config python-pyside-2-tools swig)) @@ -3715,7 +3715,7 @@ netlists from the drawn schematic, allowing the simulation of the circuit.") (base32 "08rqhl6a5a8s67a8yl16944zgcsnnb08xfv4klzyqwlvaqgfp783")))) (build-system gnu-build-system) - (native-inputs (list qttools)) + (native-inputs (list qttools-5)) (inputs (list qtbase-5 qtserialport)) (arguments (list #:tests? #f ; no tests. diff --git a/gnu/packages/finance.scm b/gnu/packages/finance.scm index b7937a310a..5ff345acc0 100644 --- a/gnu/packages/finance.scm +++ b/gnu/packages/finance.scm @@ -143,7 +143,7 @@ pkg-config python ; for the tests util-linux ; provides the hexdump command for tests - qttools)) + qttools-5)) (inputs (list bdb-4.8 ; 4.8 required for compatibility boost @@ -159,12 +159,12 @@ (assoc-ref %build-inputs "boost")) ;; XXX: The configure script looks up Qt paths by ;; `pkg-config --variable=host_bins Qt5Core`, which fails to pick - ;; up executables residing in 'qttools', so we specify them here. + ;; up executables residing in 'qttools-5', so we specify them here. (string-append "ac_cv_path_LRELEASE=" - (assoc-ref %build-inputs "qttools") + (assoc-ref %build-inputs "qttools-5") "/bin/lrelease") (string-append "ac_cv_path_LUPDATE=" - (assoc-ref %build-inputs "qttools") + (assoc-ref %build-inputs "qttools-5") "/bin/lupdate")) #:phases (modify-phases %standard-phases @@ -698,7 +698,7 @@ blockchain.") pkg-config protobuf python - qttools)) + qttools-5)) (inputs (list boost cppzmq @@ -1543,7 +1543,7 @@ Trezor wallet.") (list pkg-config python ; for the tests util-linux ; provides the hexdump command for tests - qttools)) + qttools-5)) (inputs (list bdb-5.3 boost @@ -1657,7 +1657,7 @@ following three utilities are included with the library: pkg-config python ; for the tests util-linux ; provides the hexdump command for tests - qttools)) + qttools-5)) (inputs (list bdb-4.8 boost @@ -1677,12 +1677,12 @@ following three utilities are included with the library: (assoc-ref %build-inputs "boost")) ;; XXX: The configure script looks up Qt paths by ;; `pkg-config --variable=host_bins Qt5Core`, which fails to pick - ;; up executables residing in 'qttools', so we specify them here. + ;; up executables residing in 'qttools-5', so we specify them here. (string-append "ac_cv_path_LRELEASE=" - (assoc-ref %build-inputs "qttools") + (assoc-ref %build-inputs "qttools-5") "/bin/lrelease") (string-append "ac_cv_path_LUPDATE=" - (assoc-ref %build-inputs "qttools") + (assoc-ref %build-inputs "qttools-5") "/bin/lupdate") "--disable-static") #:phases @@ -1731,7 +1731,7 @@ a Qt GUI.") (string-append "PREFIX=" %output) "features=")))))) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list python qtbase-5 rocksdb zlib)) (home-page "https://gitlab.com/FloweeTheHub/fulcrum/") @@ -1798,7 +1798,7 @@ like Flowee the Hub, which Fulcrum connects to over RPC.") openssl qtbase-5)) (native-inputs - (list pkg-config qttools util-linux)) ; provides the hexdump command for tests + (list pkg-config qttools-5 util-linux)) ; provides the hexdump command for tests (home-page "https://flowee.org") (synopsis "Flowee infrastructure tools and services") (description diff --git a/gnu/packages/game-development.scm b/gnu/packages/game-development.scm index f426532cb1..70bd4c0251 100644 --- a/gnu/packages/game-development.scm +++ b/gnu/packages/game-development.scm @@ -522,7 +522,7 @@ formats such as PNG.") (inputs (list qtbase-5 qtdeclarative-5 qtsvg-5 zlib)) (native-inputs - (list qttools)) + (list qttools-5)) (arguments '(#:phases (modify-phases %standard-phases @@ -531,7 +531,7 @@ formats such as PNG.") (substitute* "translations/translations.pro" (("LRELEASE =.*") (string-append "LRELEASE = " - (assoc-ref inputs "qttools") + (assoc-ref inputs "qttools-5") "/bin/lrelease\n"))) (let ((out (assoc-ref outputs "out"))) (invoke "qmake" diff --git a/gnu/packages/games.scm b/gnu/packages/games.scm index a851a6853a..8b655cc0e4 100644 --- a/gnu/packages/games.scm +++ b/gnu/packages/games.scm @@ -995,7 +995,7 @@ want what you have.") qtbase-5 qtmultimedia-5 qtsvg-5 - qttools + qttools-5 qtwebsockets-5 xz zlib)) @@ -2504,7 +2504,7 @@ and defeat them with your bubbles!") (setenv "XDG_RUNTIME_DIR" (getcwd)) #t))))) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs `(("glm" ,glm) ("libmodplug" ,libmodplug) @@ -7203,7 +7203,7 @@ making Yamagi Quake II one of the most solid Quake II implementations available. (native-inputs `(("cmake" ,cmake-minimal) ("gettext-minimal" ,gettext-minimal) - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (synopsis "Realistic physics puzzle game") (description "The Butterfly Effect (tbe) is a game that uses realistic physics simulations to combine lots of simple mechanical @@ -9279,7 +9279,7 @@ and also provides the base for the FlightGear Flight Simulator.") (native-inputs `(("cppunit" ,cppunit) ("pkg-config" ,pkg-config) - ("qttools" ,qttools) + ("qttools-5" ,qttools-5) ("flightgear-data" ,(origin (method url-fetch) @@ -9407,7 +9407,7 @@ play with up to four players simultaneously. It has network support.") ("sdl" ,(sdl-union (list sdl2 sdl2-mixer sdl2-net sdl2-ttf sdl2-image))))) (native-inputs - (list clang-9 ghc pkg-config qttools)) + (list clang-9 ghc pkg-config qttools-5)) (home-page "https://hedgewars.org/") (synopsis "Turn-based artillery game featuring fighting hedgehogs") (description @@ -11883,7 +11883,7 @@ and chess engines.") (base32 "01fjchil2h6ry2ywr0dwjw2g7zd29580cr4c74d5z74h999lp6nh")))) (build-system qt-build-system) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list qtbase-5 qtmultimedia-5 qtspeech qtsvg-5 zlib)) (arguments diff --git a/gnu/packages/geo.scm b/gnu/packages/geo.scm index b8125ffe6e..fe2174b106 100644 --- a/gnu/packages/geo.scm +++ b/gnu/packages/geo.scm @@ -1495,7 +1495,7 @@ map display. Downloads map data from a number of websites, including (string-append "\"" font "/share/fonts/\""))))))) #:tests? #f)) ; no tests (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list bzip2 font-liberation @@ -1952,7 +1952,7 @@ using the dataset of topographical information collected by (base32 "184fqmsfzr3b333ssizjk6gvv7mncmygq8dj5r7rsvs5md26z2ys")))) (build-system qt-build-system) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list gdal libjpeg-turbo @@ -2199,7 +2199,7 @@ track your position right from your laptop.") ("zlib" ,zlib))) (native-inputs `(("doxygen" ,doxygen) - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (home-page "https://www.openorienteering.org/apps/mapper/") (synopsis "OpenOrienteering Mapper (OOM)") (description @@ -2634,7 +2634,7 @@ growing set of geoscientific methods.") pkg-config python-mock python-nose2 - qttools + qttools-5 shellcheck xorg-server-for-tests)) (home-page "https://qgis.org") diff --git a/gnu/packages/gps.scm b/gnu/packages/gps.scm index b117ff4222..e528807de7 100644 --- a/gnu/packages/gps.scm +++ b/gnu/packages/gps.scm @@ -84,7 +84,7 @@ (inputs (list expat libusb qtbase-5 zlib)) (native-inputs - (list which qttools libxml2)) ;'xmllint' needed for the KML tests + (list which qttools-5 libxml2)) ;'xmllint' needed for the KML tests (home-page "https://www.gpsbabel.org/") (synopsis "Convert and exchange data with GPS and map programs") (description @@ -196,7 +196,7 @@ coordinates as well as partial support for adjustments in global coordinate syst (inputs (list qtbase-5 qtlocation qtsvg-5)) (native-inputs - (list qttools)) + (list qttools-5)) (home-page "https://www.gpxsee.org") (synopsis "GPS log file viewer and analyzer") (description diff --git a/gnu/packages/graphics.scm b/gnu/packages/graphics.scm index f7307e8f61..38e6533a43 100644 --- a/gnu/packages/graphics.scm +++ b/gnu/packages/graphics.scm @@ -1438,7 +1438,7 @@ exec -a \"$0\" ~a/.brdf-real~%" (chmod "brdf" #o555))) #t))))) (native-inputs - (list qttools)) ;for 'qmake' + (list qttools-5)) ;for 'qmake' (inputs (list qtbase-5 mesa glew freeglut zlib)) (home-page "https://www.disneyanimation.com/technology/brdf.html") diff --git a/gnu/packages/hardware.scm b/gnu/packages/hardware.scm index 27567bb38e..68c4667662 100644 --- a/gnu/packages/hardware.scm +++ b/gnu/packages/hardware.scm @@ -453,7 +453,7 @@ support.") (wrap-qt-program "ckb-next" #:output out #:inputs inputs))))))) - (native-inputs (list qttools pkg-config)) + (native-inputs (list qttools-5 pkg-config)) (inputs (list qtbase-5 zlib libdbusmenu-qt @@ -534,7 +534,7 @@ calibrated, and restored when the calibration is applied.") (arguments '(#:tests? #f)) ; No test suite (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list ddcutil glib qtbase-5)) (home-page "https://www.ddcutil.com/") diff --git a/gnu/packages/image-processing.scm b/gnu/packages/image-processing.scm index d4b13cc90e..158d470828 100644 --- a/gnu/packages/image-processing.scm +++ b/gnu/packages/image-processing.scm @@ -770,7 +770,7 @@ including 2D color images.") (add-after 'unpack 'qt-chdir (lambda _ (chdir "gmic-qt") #t)))))) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (modify-inputs (package-inputs gmic) (prepend gmic qtbase-5))) @@ -1109,7 +1109,7 @@ combine the information contained in both.") zlib)) (native-inputs `(("googletest" ,googletest) - ("qttools" ,qttools) + ("qttools-5" ,qttools-5) ("pkg-config" ,pkg-config) ("c3d-src" ,(let* ((commit "f521358db26e00002c911cc47bf463b043942ad3") @@ -1224,7 +1224,7 @@ substituted by matching images.") "0kixwjb2x457dq7927hkh34c803p7yh1pmn6n61rk9shqrcg492h")))) (build-system qt-build-system) (native-inputs - (list qttools)) + (list qttools-5)) (inputs `(("boost" ,boost) ("libjpeg" ,libjpeg-turbo) diff --git a/gnu/packages/image-viewers.scm b/gnu/packages/image-viewers.scm index 045fdae882..88dbba866b 100644 --- a/gnu/packages/image-viewers.scm +++ b/gnu/packages/image-viewers.scm @@ -516,7 +516,7 @@ It supports JPEG, PNG and GIF formats.") "188q0l63nfasqfvwbq4mwx2vh7wsfi2bq9n5nksddspl1qz01lnp")))) (build-system cmake-build-system) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list qtbase-5 qtdeclarative-5 @@ -671,7 +671,7 @@ For PDF support, install the @emph{mupdf} package.") (invoke "qmake" "tests.pro") (invoke "make" "tests")))))))) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list qtbase-5 qtimageformats qtsvg-5)) (home-page "https://interversehq.com/qview/") @@ -924,7 +924,7 @@ archives.") ("qtsvg-5" ,qtsvg-5))) (native-inputs `(("pkg-config" ,pkg-config) - ("qtlinguist" ,qttools))) + ("qtlinguist" ,qttools-5))) (synopsis "Image viewer supporting all common formats") (description "Nomacs is a simple to use image lounge featuring semi-transparent widgets that display additional information such as metadata, diff --git a/gnu/packages/image.scm b/gnu/packages/image.scm index 90554143d0..4b31ba41a0 100644 --- a/gnu/packages/image.scm +++ b/gnu/packages/image.scm @@ -1828,7 +1828,7 @@ parsing, viewing, modifying, and saving this metadata.") "1p7gqs5vqzbddlgl38lbanchwb14m6lx8f2cn2c5p0vyqwvqqv52")))) (build-system qt-build-system) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list qtbase-5 qtsvg-5)) (arguments diff --git a/gnu/packages/irc.scm b/gnu/packages/irc.scm index 67a86cbfc1..efb32a39e0 100644 --- a/gnu/packages/irc.scm +++ b/gnu/packages/irc.scm @@ -126,7 +126,7 @@ (let ((inxi (search-input-file inputs "/bin/inxi"))) (symlink inxi "data/scripts/inxi"))))))) (native-inputs - (list extra-cmake-modules pkg-config qttools)) + (list extra-cmake-modules pkg-config qttools-5)) (inputs (list boost inxi-minimal diff --git a/gnu/packages/jami.scm b/gnu/packages/jami.scm index 22d2f0c5ce..e5c29981d3 100644 --- a/gnu/packages/jami.scm +++ b/gnu/packages/jami.scm @@ -598,7 +598,7 @@ decentralized calling using P2P-DHT.") (("Qt::AA_UseOpenGLES") "Qt::AA_UseDesktopOpenGL"))))))) (native-inputs - (list pkg-config python qttools doxygen graphviz)) + (list pkg-config python qttools-5 doxygen graphviz)) (inputs (list jami-libclient libnotify diff --git a/gnu/packages/kde-frameworks.scm b/gnu/packages/kde-frameworks.scm index 6fc0b5f10c..391db94f3a 100644 --- a/gnu/packages/kde-frameworks.scm +++ b/gnu/packages/kde-frameworks.scm @@ -185,7 +185,7 @@ common build settings used in software produced by the KDE community.") (native-inputs ;; TODO: Think about adding pulseaudio. Is it required for sound? ;; TODO: Add building the super experimental QML support - (list extra-cmake-modules pkg-config qttools)) + (list extra-cmake-modules pkg-config qttools-5)) (inputs (list qtbase-5)) (arguments @@ -222,7 +222,7 @@ common build settings used in software produced by the KDE community.") "1wk1ip2w7fkh65zk6rilj314dna0hgsv2xhjmpr5w08xa8sii1y5")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules pkg-config qttools)) + (list extra-cmake-modules pkg-config qttools-5)) (inputs (list qtbase-5 phonon @@ -489,7 +489,7 @@ and the older vCalendar.") "0y9n2a5n18pasdmrp0xb84hla9l27yj2x3k4p1c041sd9nkwixpk")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules gperf qttools)) + (list extra-cmake-modules gperf qttools-5)) (inputs (list qtbase-5)) (home-page "https://community.kde.org/Frameworks") @@ -523,7 +523,7 @@ Internet).") "1s3h4hfpw7c0894cifj66bj1yhx8g94ckvl71jm7qqsb5x5h6y9n")))) (build-system cmake-build-system) (native-inputs - (list dbus extra-cmake-modules inetutils qttools + (list dbus extra-cmake-modules inetutils qttools-5 xorg-server-for-tests)) (inputs (list qtbase-5)) @@ -585,7 +585,7 @@ propagate their changes to their respective configuration files.") "10a7zys3limsawl7lk9ggymk3msk2bp0y8hp0jmsvk3l405pd1ps")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules qttools shared-mime-info + (list extra-cmake-modules qttools-5 shared-mime-info ;; TODO: FAM: File alteration notification http://oss.sgi.com/projects/fam xorg-server-for-tests)) ; for the tests (inputs @@ -641,7 +641,7 @@ many more.") (patches (search-patches "kdbusaddons-kinit-file-name.patch")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules dbus qttools)) + (list extra-cmake-modules dbus qttools-5)) (inputs (list qtbase-5 qtx11extras kinit-bootstrap)) ;; kinit-bootstrap: kinit package which does not depend on kdbusaddons. (arguments @@ -681,7 +681,7 @@ as well as an API to create KDED modules.") "0wadknnf472rqg2xnqzs5v23qzqfr336wj6d96yg2ayqm0chbppy")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list avahi ; alternativly dnssd could be used qtbase-5)) @@ -773,7 +773,7 @@ interfaces in the areas of colors, fonts, text, images, keyboard input.") (display "[testDefaultRegions]\n*\n"))) #t))))) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list qtbase-5 qtdeclarative-5)) (home-page "https://invent.kde.org/frameworks/kholidays") @@ -868,7 +868,7 @@ or user activity.") (properties `((upstream-name . "kirigami2"))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list kwindowsystem ;; TODO: Find a way to activate this optional include without @@ -952,7 +952,7 @@ model to observers "04vlmkvc3y5h7cpb6kdv9gha5axxkimhqh44mdg2ncyn4sas6j68")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list qtbase-5)) (home-page "https://community.kde.org/Frameworks") @@ -977,7 +977,7 @@ to flat and hierarchical lists.") "1wj4n2a8iz9ml1y0012xkpsx3dfp5gl2dn80sifrzvkxjxrhwach")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list qtbase-5)) (home-page "https://community.kde.org/Frameworks") @@ -1004,7 +1004,7 @@ pixel units.") "12jn7lqsp86329spai7n1n8i65nwhxh8gp33wkq543h7w3i2a3jb")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules perl qttools + (list extra-cmake-modules perl qttools-5 ;; Optional, for compile-time validation of syntax definition files: qtxmlpatterns)) (inputs @@ -1088,7 +1088,7 @@ represented by a QPoint or a QSize.") "03l37lh219np7pqfa56r2v7n5s5xg4rjq005qng4b5izd95ri56j")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools xorg-server-for-tests)) + (list extra-cmake-modules qttools-5 xorg-server-for-tests)) (inputs (list qtbase-5)) (arguments @@ -1127,7 +1127,7 @@ configuration pages, message boxes, and password requests.") pkg-config dbus ; for the tests openbox ; for the tests - qttools + qttools-5 xorg-server-for-tests)) ; for the tests (inputs `(("libxrender" ,libxrender) @@ -1373,7 +1373,7 @@ feel.") (setenv "DBUS_FATAL_WARNINGS" "0") (invoke "dbus-launch" "ctest" ".")))))) (native-inputs - (list bison dbus extra-cmake-modules flex qttools)) + (list bison dbus extra-cmake-modules flex qttools-5)) (inputs `(("qtbase" ,qtbase-5) ("qtdeclarative-5" ,qtdeclarative-5) @@ -1401,7 +1401,7 @@ system.") "0b88h5fw1n8zyrg0vq3lj2jbjjyh0mk64lj6ab3643kxzqxbn30w")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules pkg-config qttools)) + (list extra-cmake-modules pkg-config qttools-5)) (inputs (list hunspell ;; TODO: hspell (for Hebrew), Voikko (for Finish) @@ -1503,7 +1503,7 @@ with other frameworks.") "0nmdz7ra3hpg0air4lfkzilv7cwx3zxs29k7sh8l3i1fs3qpjwxm")))) (build-system cmake-build-system) (native-inputs - (list dbus extra-cmake-modules qttools)) + (list dbus extra-cmake-modules qttools-5)) (inputs (list kcoreaddons polkit-qt qtbase-5)) (arguments @@ -1546,7 +1546,7 @@ utilities.") "1pjgya8wi28jx63hcdi9v5f5487gzbkw2j1iganhd7bhcb8s7zpy")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list kconfig kwidgetsaddons qtbase-5)) (home-page "https://community.kde.org/Frameworks") @@ -1800,7 +1800,7 @@ formats.") "13kdczzyyh17hf6vlhh4li5bn4yq5bab5xa8mm63r9rynxihgclf")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list kcoreaddons kwidgetsaddons qtbase-5 qtx11extras)) (home-page "https://community.kde.org/Frameworks") @@ -1824,7 +1824,7 @@ asynchronous jobs.") "01bn23xw2n53h9nl99lm3cjnqs8s66bmwkzf6fkpg9rzkykizbyc")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules dbus qttools)) + (list extra-cmake-modules dbus qttools-5)) (inputs (list kcodecs kconfig @@ -2134,7 +2134,7 @@ by which applications, and what documents have been linked to which activity.") (propagated-inputs (list kwidgetsaddons)) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list kauth kcodecs @@ -2236,7 +2236,7 @@ KCModules can be created with the KConfigWidgets framework.") ki18n ;; todo: PythonModuleGeneration qtbase-5 - qttools)) + qttools-5)) (arguments `(#:phases (modify-phases %standard-phases @@ -2362,7 +2362,7 @@ started on demand.") "0dr6gcag2yzx8fvxis4x403jrcisywds95cywmiyz3pb5727cak2")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list kconfig kcoreaddons @@ -2431,7 +2431,7 @@ with su and ssh respectively.") "0y9ja3znkvzdbjfs91dwr4cmvl9fk97zpz2lkf0f9zhm2nw6q008")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list kconfig kcoreaddons @@ -2500,7 +2500,7 @@ emoticons coming from different providers.") "0hmqigc8myiwwh7m6y2cm4vn0d3kmrhia179hyb84vpvvn3lm93z")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules pkg-config qttools)) + (list extra-cmake-modules pkg-config qttools-5)) (inputs (list kconfig kcrash @@ -2534,7 +2534,7 @@ window does not need focus for them to be activated.") "09bqpf3drqyfc81vgab9bsh1wm5qbzdwqjlczhax38660nnvh0r9")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules qttools shared-mime-info)) + (list extra-cmake-modules qttools-5 shared-mime-info)) (inputs (list karchive kauth @@ -2661,7 +2661,7 @@ consumption.") kxmlgui solid)) (native-inputs - (list dbus qttools extra-cmake-modules)) + (list dbus qttools-5 extra-cmake-modules)) (inputs `(;; TODO: LibACL , ("krb5" ,mit-krb5) @@ -3133,7 +3133,7 @@ library.") (propagated-inputs (list ki18n sonnet)) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list kauth kcodecs @@ -3213,7 +3213,7 @@ the passwords on KDE work spaces.") (propagated-inputs (list kconfig kconfigwidgets)) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list attica kauth @@ -3549,7 +3549,7 @@ workspace.") networkmanager-qt openssl qtsvg-5 - qttools + qttools-5 qtx11extras)) ;; FIXME: Use Guix ca-bundle.crt in etc/xdg/ksslcalist and ;; share/kf5/kssl/ca-bundle.crt @@ -3698,7 +3698,7 @@ support.") (base32 "0976faazhxhhi1wpvpcs8hwb2knz0z7j44v3ay3hw73rq4p3bipm")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules kdoctools qttools)) + (list extra-cmake-modules kdoctools qttools-5)) (inputs (list ki18n kjs qtbase-5 qtsvg-5)) (home-page "https://community.kde.org/Frameworks") @@ -3722,7 +3722,7 @@ QObjects, so you can script your applications.") (base32 "0lrm4y727nhwaivl37zpmnrwx048gfhyjw19m6q5z9p37lk43jja")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules kdoctools qttools)) + (list extra-cmake-modules kdoctools qttools-5)) (inputs (list kcompletion kcoreaddons @@ -3758,7 +3758,7 @@ KParts instead.") (base32 "12b527l12rcf421p613ydbacilp9v9iy90ma35w21sdf9a15k675")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules kdoctools qttools)) + (list extra-cmake-modules kdoctools qttools-5)) (inputs (list kcompletion kcoreaddons diff --git a/gnu/packages/kde-multimedia.scm b/gnu/packages/kde-multimedia.scm index ac86489a95..39295f589d 100644 --- a/gnu/packages/kde-multimedia.scm +++ b/gnu/packages/kde-multimedia.scm @@ -322,7 +322,7 @@ This package is part of the KDE multimedia module.") kdoctools libxslt python-wrapper - qttools)) + qttools-5)) (inputs (list chromaprint flac diff --git a/gnu/packages/kde-pim.scm b/gnu/packages/kde-pim.scm index f0f5683ac5..faf5e702f3 100644 --- a/gnu/packages/kde-pim.scm +++ b/gnu/packages/kde-pim.scm @@ -58,7 +58,7 @@ "akonadi-not-relocatable.patch")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools shared-mime-info)) + (list extra-cmake-modules qttools-5 shared-mime-info)) (inputs (list boost kconfig @@ -537,7 +537,7 @@ one of the APIs mentioned above.") (properties `((upstream-name . "calendarsupport"))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list akonadi akonadi-calendar @@ -769,7 +769,7 @@ package.") (properties `((upstream-name . "eventviews"))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list akonadi akonadi-calendar @@ -1108,7 +1108,7 @@ manager from KDE.") (properties `((upstream-name . "mailcommon"))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules dbus gnupg qttools)) + (list extra-cmake-modules dbus gnupg qttools-5)) (inputs (list akonadi akonadi-contacts @@ -1496,7 +1496,7 @@ application \"Parts\" to be embedded as a Kontact component (or plugin).") (base32 "04lz3ldrr0lpy9zpsg9ja1i9gxzlcjpqcwn3g7l4jjdky4frcr2r")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules dbus qttools kdoctools)) + (list extra-cmake-modules dbus qttools-5 kdoctools)) (inputs (list akonadi akonadi-calendar @@ -1620,7 +1620,7 @@ Virtual Contact File}) files to the KPeople contact management library.") (properties `((upstream-name . "pimcommon"))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list karchive akonadi @@ -1678,7 +1678,7 @@ Virtual Contact File}) files to the KPeople contact management library.") (base32 "0j6d4sv405c3x0ww75qsww94apidsb8aaqf59akhv96zmv0vx5wy")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list grantlee kcodecs @@ -1791,7 +1791,7 @@ and allows one to view/extract message formatted text in Rich Text Format.") (base32 "0bask561laxgkgm3rxfpyxqs6jx1l9xjk058lhycq0pik6vwhdha")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list akonadi akonadi-contacts @@ -1838,7 +1838,7 @@ and allows one to view/extract message formatted text in Rich Text Format.") (base32 "0nvd5fqrvyb7c3g7rf1lxbbv38q9sqnhd6irgx7awwgw92inxky4")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list cyrus-sasl ki18n @@ -1873,7 +1873,7 @@ various Google services.") (base32 "0rijpmqyx4mrr7csik3vkfcra7kfywk6yz548fmq3ha8wa9ax8fv")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules kdoctools qttools)) + (list extra-cmake-modules kdoctools qttools-5)) (inputs (list boost gpgme diff --git a/gnu/packages/kde-utils.scm b/gnu/packages/kde-utils.scm index 512c2acfef..98bc8f7b86 100644 --- a/gnu/packages/kde-utils.scm +++ b/gnu/packages/kde-utils.scm @@ -407,7 +407,7 @@ either be created or generated from a image.") (base32 "03wsv83l1cay2dpcsksad124wzan7kh8zxdw1h0yicn398kdbck4")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules kdoctools qttools shared-mime-info)) + (list extra-cmake-modules kdoctools qttools-5 shared-mime-info)) (inputs (list kbookmarks kcmutils diff --git a/gnu/packages/kde.scm b/gnu/packages/kde.scm index c43758ef7f..933bfcd04b 100644 --- a/gnu/packages/kde.scm +++ b/gnu/packages/kde.scm @@ -261,7 +261,7 @@ browser for easy news reading.") `("MLT_PREFIX" ":" = (,#$(this-package-input "mlt")))))))))) (native-inputs - (list extra-cmake-modules pkg-config qttools)) + (list extra-cmake-modules pkg-config qttools-5)) (inputs (list bash-minimal breeze ; make dark them available easily @@ -318,7 +318,7 @@ projects.") (base32 "02ip5r67hjfpywkm3mz86n6wbqcr7996ifzfd2fyzsvm4998hi4y")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules pkg-config shared-mime-info qttools)) + (list extra-cmake-modules pkg-config shared-mime-info qttools-5)) (inputs `(("boost" ,boost) ("clang" ,clang) @@ -436,7 +436,7 @@ for some KDevelop language plugins (Ruby, PHP, CSS...).") "kdiagram-Fix-missing-link-libraries.patch")))) (build-system qt-build-system) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (inputs (list qtbase-5 qtsvg-5)) (home-page "https://invent.kde.org/graphics/kdiagram") @@ -690,7 +690,7 @@ cards.") (inputs (list qtbase-5)) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) (home-page "https://techbase.kde.org/Projects/Snorenotify") (synopsis "Qt notification framework") (description "Snorenotify is a multi platform Qt notification framework. @@ -804,7 +804,7 @@ communicate with each other. Here's a few things KDE Connect can do: ("extra-cmake-modules" ,extra-cmake-modules) ("pkg-config" ,pkg-config) ("python" ,python-wrapper) - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (inputs (list breeze ;for dark themes breeze-icons ;for icons @@ -917,7 +917,7 @@ unmount drives and view them in a file manager.") "0fx17s6fj1pxl1mgfrqhchk8sihkbji1x8y3nhb1r0971wzd1nsc")))) (build-system cmake-build-system) (native-inputs - (list extra-cmake-modules perl python qttools kdoctools)) + (list extra-cmake-modules perl python qttools-5 kdoctools)) (inputs (list qtbase-5 karchive ki18n kio kdbusaddons)) ;; Note: The 'hotshot2calltree' and 'pprof2calltree' scripts depend on @@ -1007,7 +1007,7 @@ Python, PHP, and Perl.") "-DBUILD_TOUCH=YES" "-DBUILD_MARBLE_TESTS=FALSE"))) (native-inputs - (list extra-cmake-modules qttools)) + (list extra-cmake-modules qttools-5)) ;; One optional dependency missing: libwlocate. (inputs (list gpsd @@ -1216,7 +1216,7 @@ or Bonjour by other projects).") (build-system qt-build-system) (native-inputs (list extra-cmake-modules - qttools + qttools-5 ;; For optional component "Survey target expression parser" bison flex diff --git a/gnu/packages/lego.scm b/gnu/packages/lego.scm index 19a4a5eba0..39823dfee8 100644 --- a/gnu/packages/lego.scm +++ b/gnu/packages/lego.scm @@ -113,7 +113,7 @@ restrictions that stem from limitations of the standard RCX firmware.") "1ifbxngkbmg6d8vv08amxbnfvlyjdwzykrjp98lbwvgb0b843ygq")))) (build-system gnu-build-system) (native-inputs - (list qttools)) ; for lrelease + (list qttools-5)) ; for lrelease (inputs (list mesa qtbase-5 zlib)) (arguments diff --git a/gnu/packages/linphone.scm b/gnu/packages/linphone.scm index 47fb94dc68..7b5efeb588 100644 --- a/gnu/packages/linphone.scm +++ b/gnu/packages/linphone.scm @@ -843,7 +843,7 @@ and video calls or instant messaging capabilities to an application.") (symlink (string-append liblinphone "/share/belr/grammars") grammar-dest))))))) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list bctoolbox belcard diff --git a/gnu/packages/lxqt.scm b/gnu/packages/lxqt.scm index 9ff1de942c..eab9a24d1d 100644 --- a/gnu/packages/lxqt.scm +++ b/gnu/packages/lxqt.scm @@ -234,7 +234,7 @@ in Qt.") qtsvg-5 qtx11extras)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (home-page "https://lxqt-project.org") (synopsis "Core utility library for all LXQt components") (description "liblxqt provides the basic libraries shared by the @@ -287,7 +287,7 @@ and memory usage or network traffic.") qtsvg-5 qtx11extras)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f ; no tests #:phases @@ -329,7 +329,7 @@ LXQt and the system it's running on.") qtsvg-5 qtx11extras)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f ; no tests #:phases @@ -382,7 +382,7 @@ the operating system LXQt is running on.") xkeyboard-config zlib)) (native-inputs - (list pkg-config lxqt-build-tools qttools)) + (list pkg-config lxqt-build-tools qttools-5)) ;; XXX: This is a workaround so libkscreen can find the backends as we ;; dont have a way specify them. We may want to patch like Nix does. (propagated-inputs @@ -446,7 +446,7 @@ configuration of both LXQt and the underlying operating system.") qtsvg-5 qtx11extras)) (native-inputs - (list pkg-config qttools lxqt-build-tools)) + (list pkg-config qttools-5 lxqt-build-tools)) (arguments '(#:tests? #f ; no tests #:phases @@ -492,7 +492,7 @@ as a whole and are not limited to distinct applications.") qtsvg-5 qtx11extras)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f ; no test target #:phases @@ -537,7 +537,7 @@ according to the Desktop Notifications Specification.") qtsvg-5 qtx11extras)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f ; no tests #:phases @@ -590,7 +590,7 @@ of other programs.") xcb-util xkeyboard-config)) (native-inputs - (list pkg-config lxqt-build-tools qttools)) + (list pkg-config lxqt-build-tools qttools-5)) (propagated-inputs ;; Propagating KWINDOWSYSTEM so that the list of opened applications ;; shows up in lxqt-panel's taskbar plugin. @@ -649,7 +649,7 @@ of other programs.") qtsvg-5 qtx11extras)) (native-inputs - (list pkg-config polkit lxqt-build-tools qttools)) + (list pkg-config polkit lxqt-build-tools qttools-5)) (arguments '(#:tests? #f ; no test target #:phases @@ -696,7 +696,7 @@ LXQt.") qtx11extras solid)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f ; no tests #:phases @@ -742,7 +742,7 @@ when laptop batteries are low on power.") qtsvg-5 qtx11extras)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f ; no tests #:phases @@ -782,7 +782,7 @@ Qt with LXQt.") qtsvg-5 qtx11extras)) (native-inputs - (list pkg-config qttools lxqt-build-tools)) + (list pkg-config qttools-5 lxqt-build-tools)) (arguments '(#:tests? #f ; no tests #:phases @@ -829,7 +829,7 @@ allows for launching applications or shutting down the system.") qtx11extras xdg-user-dirs)) (native-inputs - (list pkg-config lxqt-build-tools qttools)) + (list pkg-config lxqt-build-tools qttools-5)) (arguments `(#:tests? #f #:phases @@ -897,7 +897,7 @@ for the LXQt desktop environment.") qtx11extras sudo)) (native-inputs - (list pkg-config qttools lxqt-build-tools)) + (list pkg-config qttools-5 lxqt-build-tools)) (arguments '(#:tests? #f ; no tests #:phases @@ -978,7 +978,7 @@ for LXQt.") qtbase-5 qtx11extras)) (native-inputs - (list pkg-config lxqt-build-tools qttools)) + (list pkg-config lxqt-build-tools qttools-5)) (home-page "https://lxqt-project.org") (synopsis "Qt binding for libfm") (description "libfm-qt is the Qt port of libfm, a library providing @@ -1000,7 +1000,7 @@ components to build desktop file managers which belongs to LXDE.") (inputs (list libfm-qt qtbase-5 qtx11extras)) (native-inputs - (list pkg-config qttools lxqt-build-tools)) + (list pkg-config qttools-5 lxqt-build-tools)) (arguments '(#:tests? #f ; no tests #:phases @@ -1038,7 +1038,7 @@ LXDE.") (inputs (list libconfig qtbase-5)) (native-inputs - (list lxqt-build-tools pkg-config qttools)) + (list lxqt-build-tools pkg-config qttools-5)) (arguments '(#:tests? #f ; no tests #:phases @@ -1070,7 +1070,7 @@ manager Compton.") (inputs (list libexif libfm-qt qtbase-5 qtsvg-5 qtx11extras)) (native-inputs - (list pkg-config lxqt-build-tools qttools)) + (list pkg-config lxqt-build-tools qttools-5)) (arguments '(#:tests? #f)) ; no tests (home-page "https://lxqt-project.org") @@ -1103,7 +1103,7 @@ image viewer.") qtbase-5 qtx11extras)) (native-inputs - (list lxqt-build-tools pkg-config qttools)) + (list lxqt-build-tools pkg-config qttools-5)) (arguments '(#:tests? #f)) ; no tests (home-page "https://lxqt-project.org") @@ -1127,7 +1127,7 @@ window manager OpenBox.") (inputs (list glib pcre pulseaudio qtbase-5 qtx11extras)) (native-inputs - (list pkg-config lxqt-build-tools qttools)) + (list pkg-config lxqt-build-tools qttools-5)) (arguments '(#:tests? #f)) ; no tests (home-page "https://lxqt-project.org") @@ -1156,7 +1156,7 @@ window manager OpenBox.") qtbase-5 qtx11extras)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f)) ; no tests (home-page "https://lxqt-project.org") @@ -1180,7 +1180,7 @@ processes currently in existence, much like code{top} or code{ps}.") (inputs (list qtbase-5 utf8proc)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f)) ; no tests (home-page "https://lxqt-project.org") @@ -1203,7 +1203,7 @@ processes currently in existence, much like code{top} or code{ps}.") (inputs (list qtbase-5 qtx11extras qtermwidget)) (native-inputs - (list lxqt-build-tools qttools)) + (list lxqt-build-tools qttools-5)) (arguments '(#:tests? #f)) ; no tests (home-page "https://lxqt-project.org") @@ -1227,7 +1227,7 @@ QTermWidget.") (inputs (list kwindowsystem libqtxdg qtbase-5 qtsvg-5 qtx11extras)) (native-inputs - (list pkg-config perl qttools)) + (list pkg-config perl qttools-5)) (arguments '(#:tests? #f)) ; no tests (home-page "https://lxqt-project.org") @@ -1252,7 +1252,7 @@ easily publishing them on internet image hosting services.") (inputs (list glib json-glib libfm-qt qtbase-5 qtx11extras)) (native-inputs - (list pkg-config lxqt-build-tools qttools)) + (list pkg-config lxqt-build-tools qttools-5)) (arguments '(#:tests? #f)) (home-page "https://lxqt-project.org") @@ -1289,7 +1289,7 @@ like @command{tar} and @command{zip}.") libqtxdg)) (native-inputs `(("lxqt-build-tools" ,lxqt-build-tools) - ("qtlinguist" ,qttools))) + ("qtlinguist" ,qttools-5))) (arguments `(#:tests? #f ; no tests #:phases diff --git a/gnu/packages/maths.scm b/gnu/packages/maths.scm index 72a8957200..89f98ec2b6 100644 --- a/gnu/packages/maths.scm +++ b/gnu/packages/maths.scm @@ -2783,7 +2783,7 @@ script files.") ("qt" ,qtbase-5) ,@(package-inputs octave-cli))) (native-inputs - `(("qttools" , qttools) ;for lrelease + `(("qttools-5" , qttools-5) ;for lrelease ("texlive" ,(texlive-updmap.cfg (list texlive-epsf))) ; for texi2dvi ,@(package-native-inputs octave-cli))) (arguments @@ -3069,7 +3069,7 @@ ASCII text files using Gmsh's own scripting language.") (native-inputs (list pkg-config ;;("python-astropy" ,python-astropy) ;; FIXME: Package this. - qttools python-sip-4)) + qttools-5 python-sip-4)) (inputs (list ghostscript ;optional, for EPS/PS output python-dbus @@ -5468,7 +5468,7 @@ evaluates expressions using the standard order of operations.") (build-system gnu-build-system) (native-inputs `(("gettext" ,gettext-minimal) ("qtbase" ,qtbase-5) - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (inputs (list libx11 zlib libpng gsl)) ;; The upstream project file ("XaoS.pro") and the Makefile it generates are ;; not enough for this package to install properly. These phases fix that. @@ -7147,7 +7147,7 @@ functions.") "0vh7cd1915bjqzkdp3sk25ngy8cq624mkh8c53c5bnzk357kb0fk")))) (build-system cmake-build-system) (inputs (list qtbase-5)) - (native-inputs (list qttools)) + (native-inputs (list qttools-5)) (arguments `(#:phases (modify-phases %standard-phases diff --git a/gnu/packages/messaging.scm b/gnu/packages/messaging.scm index e5dd078561..58ac95f42c 100644 --- a/gnu/packages/messaging.scm +++ b/gnu/packages/messaging.scm @@ -1810,7 +1810,7 @@ instant messenger with audio and video chat capabilities.") ,(list (search-input-directory inputs "lib/qt5/plugins/")))))))))) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list ffmpeg filteraudio @@ -2468,7 +2468,7 @@ for the Matrix protocol. It is built on to of @code{Boost.Asio}.") xcb-util-wm zlib)) (native-inputs - (list asciidoc doxygen graphviz pkg-config qttools)) + (list asciidoc doxygen graphviz pkg-config qttools-5)) (home-page "https://github.com/Nheko-Reborn/nheko") (synopsis "Desktop client for Matrix using Qt and C++14") (description "@code{Nheko} want to provide a native desktop app for the @@ -2502,7 +2502,7 @@ notification, emojis, E2E encryption, and voip calls.") qtquickcontrols-5 qtquickcontrols2-5 qtsvg-5 - qttools + qttools-5 xdg-utils)) (arguments `(#:tests? #f)) ; no tests diff --git a/gnu/packages/music.scm b/gnu/packages/music.scm index 1147512980..844e756094 100644 --- a/gnu/packages/music.scm +++ b/gnu/packages/music.scm @@ -435,7 +435,7 @@ score, keyboard, guitar, drum and controller views.") `(("gettext" ,gettext-minimal) ("googletest" ,googletest) ("pkg-config" ,pkg-config) - ("qtlinguist" ,qttools))) + ("qtlinguist" ,qttools-5))) (inputs (list boost chromaprint @@ -529,7 +529,7 @@ playing your music.") `(("gettext" ,gettext-minimal) ("googletest" ,googletest) ("pkg-config" ,pkg-config) - ("qtlinguist" ,qttools) + ("qtlinguist" ,qttools-5) ("xorg-server" ,xorg-server-for-tests))) (inputs (list alsa-lib @@ -768,7 +768,7 @@ settings (aliasing, linear interpolation and cubic interpolation).") (native-inputs `(("cppunit" ,cppunit) ("pkg-config" ,pkg-config) - ("qtlinguist" ,qttools))) + ("qtlinguist" ,qttools-5))) (inputs (list alsa-lib jack-1 @@ -2226,7 +2226,7 @@ users to select LV2 plugins and run them with jalv.") (list benchmark googletest python-wrapper - qttools + qttools-5 xorg-server-for-tests)) (inputs (list bash-minimal @@ -2303,7 +2303,7 @@ perform creative live mixes with digital music files.") qtbase-5 qtsvg-5)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "https://synthv1.sourceforge.io") (synopsis "Polyphonic subtractive synthesizer") (description @@ -2336,7 +2336,7 @@ oscillators and stereo effects.") qtbase-5 qtsvg-5)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "https://drumkv1.sourceforge.io") (synopsis "Drum-kit sampler synthesizer with stereo effects") (description @@ -2369,7 +2369,7 @@ effects.") qtbase-5 qtsvg-5)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "https://samplv1.sourceforge.io") (synopsis "Polyphonic sampler synthesizer with stereo effects") (description @@ -2402,7 +2402,7 @@ effects.") qtbase-5 qtsvg-5)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "https://padthv1.sourceforge.io") (synopsis "Polyphonic additive synthesizer") (description @@ -2928,7 +2928,7 @@ browser.") "/manpages/docbook.xsl"))) #t))))) (inputs - (list qtbase-5 qtsvg-5 qttools alsa-lib)) + (list qtbase-5 qtsvg-5 qttools-5 alsa-lib)) (native-inputs (list pkg-config libxslt ; for xsltproc @@ -2975,7 +2975,7 @@ backends, including ALSA, OSS, Network and FluidSynth.") (list drumstick qtbase-5 qtsvg-5 qtx11extras)) (native-inputs (list libxslt ;for xsltproc - docbook-xsl qttools pkg-config)) + docbook-xsl qttools-5 pkg-config)) (home-page "https://vmpk.sourceforge.io/") (synopsis "Virtual MIDI piano keyboard") (description @@ -3316,7 +3316,7 @@ from the command line.") suil zlib)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "https://qtractor.org/") (synopsis "Audio/MIDI multi-track sequencer") (description @@ -4423,7 +4423,7 @@ plugins, a switch trigger, a toggle switch, and a peakmeter.") (inputs (list qtbase-5 alsa-lib jack-1 liblo lv2)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "http://qmidiarp.sourceforge.net/") (synopsis "MIDI arpeggiator") (description "QMidiArp is an advanced MIDI arpeggiator, programmable step @@ -4449,7 +4449,7 @@ modules running in parallel.") (inputs (list qtbase-5 alsa-lib)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (home-page "http://alsamodular.sourceforge.net/") (synopsis "MIDI event router and filter") (description "QMidiRoute is a MIDI event router and filter. MIDI note, @@ -4592,7 +4592,7 @@ are a C compiler and glib. Full API documentation and examples are included.") "\""))))))) (native-inputs `(("pkg-config" ,pkg-config) - ("qttools" ,qttools) + ("qttools-5" ,qttools-5) ;; rpmalloc is a public domain memory allocator. This version specified ;; below is the version required by LMMS. ;; To get the new commit of rpmalloc to use here, run @@ -4764,7 +4764,7 @@ includes LV2 plugins and a JACK standalone client.") qtsvg-5 qtxmlpatterns)) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (synopsis "Music composition and notation software") (description "MuseScore is a music score typesetter. Its main purpose is the creation @@ -4836,7 +4836,7 @@ sample library.") `(("perl" ,perl) ("pkg-config" ,pkg-config) ("python" ,python-wrapper) - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (home-page "https://muse-sequencer.github.io/") (synopsis "MIDI/Audio sequencer") (description "MusE is a MIDI/Audio sequencer with recording and editing @@ -5021,7 +5021,7 @@ specification and header.") wavpack zlib)) (native-inputs - (list pkg-config qttools)) ;for qtlinguist + (list pkg-config qttools-5)) ;for qtlinguist (synopsis "Music composition and editing environment based around a MIDI sequencer") (description "Rosegarden is a music composition and editing environment @@ -5569,7 +5569,7 @@ discard bad quality ones. `(("gettext" ,gettext-minimal) ("hicolor-icon-theme" ,hicolor-icon-theme) ("itstool" ,itstool) - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (synopsis "Musical instrument tuner") (description "FMIT is a graphical utility for tuning musical instruments, with error and volume history, and advanced features.") diff --git a/gnu/packages/networking.scm b/gnu/packages/networking.scm index 7c6d0757ea..7ea5cd7d20 100644 --- a/gnu/packages/networking.scm +++ b/gnu/packages/networking.scm @@ -1650,7 +1650,7 @@ of the same name.") perl pkg-config python-wrapper - qttools)) + qttools-5)) (synopsis "Network traffic analyzer") (description "Wireshark is a network protocol analyzer, or @dfn{packet sniffer}, that lets you capture and interactively browse the contents of diff --git a/gnu/packages/password-utils.scm b/gnu/packages/password-utils.scm index 7db592549d..0069fdd74c 100644 --- a/gnu/packages/password-utils.scm +++ b/gnu/packages/password-utils.scm @@ -165,7 +165,7 @@ human.") (lambda* (#:key inputs #:allow-other-keys) (wrap-qt-program "keepassxc" #:output #$output #:inputs inputs)))))) (native-inputs - (list qttools ruby-asciidoctor)) + (list qttools-5 ruby-asciidoctor)) (inputs (list argon2 botan @@ -697,7 +697,7 @@ key URIs using the standard otpauth:// scheme.") (setenv "QT_QPA_PLATFORM" "offscreen") #t))))) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list qtbase-5 qtsvg-5)) (home-page "https://qtpass.org") diff --git a/gnu/packages/patches/xygrib-fix-finding-data.patch b/gnu/packages/patches/xygrib-fix-finding-data.patch index 0b718b0eff..d1db2d8807 100644 --- a/gnu/packages/patches/xygrib-fix-finding-data.patch +++ b/gnu/packages/patches/xygrib-fix-finding-data.patch @@ -124,7 +124,7 @@ index 2c9d3ab4da03..1190cc780182 100644 +- GEN_TRANSLATION (DEFAULT: ON) +``` +Create targets to generate translation files. -+Turning this off removes the need for qt-linguist, part of qttools qt5 submodule, during build. ++Turning this off removes the need for qt-linguist, part of qttools-5 qt5 submodule, during build. +``` ### macOS diff --git a/gnu/packages/photo.scm b/gnu/packages/photo.scm index 45e951884b..19c171a9bb 100644 --- a/gnu/packages/photo.scm +++ b/gnu/packages/photo.scm @@ -609,7 +609,7 @@ and enhance them.") (string-append "PREFIX=" out) "Photoflare.pro"))))))) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list graphicsmagick libomp qtbase-5)) (home-page "https://photoflare.io") diff --git a/gnu/packages/python-xyz.scm b/gnu/packages/python-xyz.scm index ac7c0d6066..216970ace9 100644 --- a/gnu/packages/python-xyz.scm +++ b/gnu/packages/python-xyz.scm @@ -25034,7 +25034,7 @@ with features similar to the @command{wget} utility.") python-translation-finder python-watchdog)) (native-inputs - (list qttools fontforge)) + (list qttools-5 fontforge)) (home-page "https://framagit.org/tyreunom/offlate") (synopsis "Offline translation interface for online translation tools") (description "Offlate offers a unified interface for different translation diff --git a/gnu/packages/qt.scm b/gnu/packages/qt.scm index 488cfa6120..f0278c00a0 100644 --- a/gnu/packages/qt.scm +++ b/gnu/packages/qt.scm @@ -187,7 +187,7 @@ (add-after 'install 'qt-wrap (assoc-ref qt:%standard-phases 'qt-wrap))))) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list qtbase-5 qtsvg-5)) (synopsis "Qt5 Configuration Tool") @@ -1701,7 +1701,7 @@ native APIs where it makes sense."))) (description "The Qt Location module provides an interface for location, positioning and geolocation plugins."))) -(define-public qttools +(define-public qttools-5 (package (inherit qtsvg-5) (name "qttools") (version "5.15.2") @@ -1735,7 +1735,7 @@ that helps in Qt development."))) "0gk74hk488k9ldacxbxcranr3arf8ifqg8kz9nm1rgdgd59p36d2")) (patches (search-patches "qtscript-disable-tests.patch")))) (native-inputs - (list perl qttools)) + (list perl qttools-5)) (inputs (list qtbase-5)) (synopsis "Qt Script module") @@ -2031,7 +2031,7 @@ message."))) (arguments `(#:tests? #f)) ;no test (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list enchant qtbase-5)) (home-page "https://github.com/manisandro/qtspell") @@ -2915,7 +2915,7 @@ module provides support functions to the automatically generated code.") ("qtsensors" ,qtsensors) ("qtserialport" ,qtserialport) ("qtsvg-5" ,qtsvg-5) - ("qttools" ,qttools) + ("qttools-5" ,qttools-5) ("qtwebchannel-5" ,qtwebchannel-5) ("qtwebkit" ,qtwebkit) ("qtwebsockets-5" ,qtwebsockets-5) @@ -3260,7 +3260,7 @@ This package provides the Python bindings."))) "1zk6r2vc1q48qs7mw2h47bpgrfbb9r7lf9cwq4sb1a4nls87zznk")))) (build-system cmake-build-system) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list libsecret qtbase-5)) (arguments @@ -3404,7 +3404,7 @@ that can be only started once per user. (base32 "0hf0mpca248xlqn7xnzkfj8drf19gdyg5syzklvq8pibxiixwxj0")))) (build-system gnu-build-system) (inputs - (list qtbase-5 qtsvg-5 qttools)) + (list qtbase-5 qtsvg-5 qttools-5)) (arguments `(#:phases (modify-phases %standard-phases @@ -3552,7 +3552,7 @@ time Web content can be enhanced with native controls.") "09fz6v8rp28997f235yaifj8p4vvsyv45knc1iivgdvx7msgcd0m")))) (build-system cmake-build-system) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list qtbase-5 qtdeclarative-5)) (home-page "https://filcuc.github.io/DOtherSide/index.html") @@ -3589,7 +3589,7 @@ a binding language: (build-system cmake-build-system) (arguments `(#:tests? #f)) ; There are no tests (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list qtbase-5)) (home-page "https://gitlab.com/mattia.basaglia/Qt-Color-Widgets") @@ -3741,7 +3741,7 @@ color-related widgets.") (native-inputs `(("cmake" ,cmake-minimal) ("python" ,python-wrapper) - ("qttools" ,qttools) + ("qttools-5" ,qttools-5) ("which" ,which))) (arguments `(#:tests? #f @@ -3780,7 +3780,7 @@ color-related widgets.") "qtsensors" "qtspeech" "qtsvg-5" - "qttools" + "qttools-5" "qtwebchannel-5" "qtwebengine-5" "qtwebsockets-5" @@ -3873,7 +3873,7 @@ generate Python bindings for your C or C++ code.") (lambda* (#:key make-flags #:allow-other-keys) (apply invoke (cons "qmake" make-flags))))))) (native-inputs - (list qtbase-5 qttools)) + (list qtbase-5 qttools-5)) (inputs (list glu)) (home-page "http://libqglviewer.com") @@ -3928,7 +3928,7 @@ being fully customizable and easy to extend.") (install-file file include-dir)) (find-files "." "\\.h$")))))))) (inputs (list qtbase-5)) - (native-inputs (list qttools)) + (native-inputs (list qttools-5)) (home-page "https://simsys.github.io") (synopsis "Binary editor widget for Qt") (description diff --git a/gnu/packages/radio.scm b/gnu/packages/radio.scm index 5f9767c896..9cd64999a1 100644 --- a/gnu/packages/radio.scm +++ b/gnu/packages/radio.scm @@ -1290,7 +1290,7 @@ instances over the network, and general QSO and DXpedition logging.") (base32 "0nciw9smrfcsirlwyny5r9h7sk2zvm40m56y1hxpgpmbnh6mqikh")))) (build-system qt-build-system) (native-inputs - (list asciidoc gfortran pkg-config qttools ruby-asciidoctor)) + (list asciidoc gfortran pkg-config qttools-5 ruby-asciidoctor)) (inputs `(("boost" ,boost) ("fftw" ,fftw) @@ -1327,7 +1327,7 @@ weak-signal conditions.") (base32 "1lw9q7ggh2jlasipl3v5pkbabysjr6baw15lnmg664ah3fwdrvnx")))) (build-system qt-build-system) (native-inputs - (list asciidoc gfortran pkg-config qttools ruby-asciidoctor)) + (list asciidoc gfortran pkg-config qttools-5 ruby-asciidoctor)) (inputs (list boost @@ -1373,7 +1373,7 @@ focused on DXing and being shaped by community of DXers.JTDX") #t)))) (build-system qt-build-system) (native-inputs - (list asciidoc gfortran pkg-config qttools ruby-asciidoctor)) + (list asciidoc gfortran pkg-config qttools-5 ruby-asciidoctor)) (inputs `(("boost" ,boost) ("fftw" ,fftw) @@ -1745,7 +1745,7 @@ intended for people who want to learn receiving and sending morse code.") (base32 "1s1aj223n57rpc95rih98z08xnyhq2zp02byzrc3f7s01fv3nj0l")))) (build-system qt-build-system) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list qtbase-5 qtmultimedia-5)) (arguments diff --git a/gnu/packages/robotics.scm b/gnu/packages/robotics.scm index 7266aa81f3..0b0ecaf027 100644 --- a/gnu/packages/robotics.scm +++ b/gnu/packages/robotics.scm @@ -119,7 +119,7 @@ hundred times faster than real-time.") protobuf-3.5 ;for logging qtbase-5 qtsvg-5 - qttools ;for libQt5Help, needed by "studio" + qttools-5 ;for libQt5Help, needed by "studio" qtwebkit qtx11extras eudev diff --git a/gnu/packages/scribus.scm b/gnu/packages/scribus.scm index 6f557d2b2b..a1d81f5697 100644 --- a/gnu/packages/scribus.scm +++ b/gnu/packages/scribus.scm @@ -91,7 +91,7 @@ qtdeclarative-5 zlib)) (native-inputs - (list pkg-config qttools util-linux)) + (list pkg-config qttools-5 util-linux)) (home-page "https://www.scribus.net") (synopsis "Desktop publishing and page layout program") (description diff --git a/gnu/packages/security-token.scm b/gnu/packages/security-token.scm index 5d95aebf14..84bd92b6f7 100644 --- a/gnu/packages/security-token.scm +++ b/gnu/packages/security-token.scm @@ -759,7 +759,7 @@ an unprivileged user.") (build-system cmake-build-system) (arguments '(#:configure-flags (list "-DBUILD_TESTING=on"))) - (native-inputs (list pkg-config qttools)) + (native-inputs (list pkg-config qttools-5)) (inputs (list catch-framework2)) (home-page "https://github.com/tplgy/cppcodec") (synopsis "Header library to encode/decode base64, base64url, etc.") @@ -783,7 +783,7 @@ base64url, base32, base32hex and hex.") (build-system cmake-build-system) (arguments `(#:tests? #f)) ;no test suite - (native-inputs (list pkg-config qttools)) + (native-inputs (list pkg-config qttools-5)) (inputs (list cppcodec hidapi libnitrokey @@ -853,7 +853,7 @@ devices.") (build-system cmake-build-system) (native-inputs - (list pkg-config qttools)) + (list pkg-config qttools-5)) (inputs (list qtbase-5 qtsvg-5 diff --git a/gnu/packages/sync.scm b/gnu/packages/sync.scm index 5b82e0ca3d..8c174c98ba 100644 --- a/gnu/packages/sync.scm +++ b/gnu/packages/sync.scm @@ -174,7 +174,7 @@ ("perl" ,perl) ("pkg-config" ,pkg-config) ("python" ,python-wrapper) - ("qttools" ,qttools) + ("qttools-5" ,qttools-5) ("ruby" ,ruby))) (inputs (list appstream @@ -347,7 +347,7 @@ See also: megacmd, the official tool set by MEGA.") ("extra-cmake-modules" ,extra-cmake-modules) ("perl" ,perl) ("pkg-config" ,pkg-config) - ("qtlinguist" ,qttools))) + ("qtlinguist" ,qttools-5))) (inputs (list qtbase-5 qtkeychain sqlite zlib)) (home-page "https://owncloud.org") diff --git a/gnu/packages/synergy.scm b/gnu/packages/synergy.scm index df109e862b..bae784d65c 100644 --- a/gnu/packages/synergy.scm +++ b/gnu/packages/synergy.scm @@ -73,7 +73,7 @@ (("/usr") out)) #t)))))) (native-inputs - (list qttools)) ; for Qt5LinguistTools + (list qttools-5)) ; for Qt5LinguistTools (inputs `(("avahi" ,avahi) ("python" ,python-wrapper) diff --git a/gnu/packages/telegram.scm b/gnu/packages/telegram.scm index d62dc831b3..873ff6246b 100644 --- a/gnu/packages/telegram.scm +++ b/gnu/packages/telegram.scm @@ -383,7 +383,7 @@ Telegram project, for its use in telegram desktop client.") ("gtk+:bin" ,gtk+ "bin") ("pkg-config" ,pkg-config) ("python" ,python-wrapper) - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (inputs `(("alsa" ,alsa-lib) ("c++-gsl" ,c++-gsl) diff --git a/gnu/packages/telephony.scm b/gnu/packages/telephony.scm index c711c3512f..14c7087125 100644 --- a/gnu/packages/telephony.scm +++ b/gnu/packages/telephony.scm @@ -653,7 +653,7 @@ address of one of the participants.") ;; xiph-rnnoise ; TODO: unbundle rnnoise )) (native-inputs - (list pkg-config python qttools)) + (list pkg-config python qttools-5)) (synopsis "Low-latency, high quality voice chat software") (description "Mumble is an low-latency, high quality voice chat @@ -695,7 +695,7 @@ Mumble consists of two applications for separate usage: "-DWITH_G729=On" ; For G729 Codec Support "-DWITH_SPEEX=On"))) ; For Speex Codec Support (native-inputs - (list bison flex qttools)) + (list bison flex qttools-5)) (inputs (list alsa-lib bcg729 diff --git a/gnu/packages/text-editors.scm b/gnu/packages/text-editors.scm index 345454bd62..485661fe6b 100644 --- a/gnu/packages/text-editors.scm +++ b/gnu/packages/text-editors.scm @@ -663,7 +663,7 @@ scripts/input/X11/C/Shell/HTML/Dired): 49KB. "19cf55b86yj2b5hdazbyw4iyp6xq155243aiyg4m0vhwh0h79nwh")))) (build-system gnu-build-system) (native-inputs - (list pkg-config qttools)) ; for lrelease + (list pkg-config qttools-5)) ; for lrelease (inputs (list hunspell qtbase-5 diff --git a/gnu/packages/video.scm b/gnu/packages/video.scm index 184dca8eff..04049fd9c8 100644 --- a/gnu/packages/video.scm +++ b/gnu/packages/video.scm @@ -1012,7 +1012,7 @@ H.264 (MPEG-4 AVC) video streams.") ("perl" ,perl) ("pkg-config" ,pkg-config) ("po4a" ,po4a) - ("qttools" ,qttools) + ("qttools-5" ,qttools-5) ("ruby" ,ruby))) (arguments `(#:configure-flags @@ -2242,7 +2242,7 @@ projects while introducing many more.") "12nvcl0cfix1xay9hfi7856vg4lpv8y5b0a22212bsjbvl5g22rc")))) (build-system qt-build-system) (native-inputs - (list qttools)) + (list qttools-5)) (inputs (list bash-minimal qtbase-5 zlib mpv)) (arguments @@ -2875,7 +2875,7 @@ for use with HTML5 video.") `(("perl" ,perl) ("pkg-config" ,pkg-config) ("python" ,python-wrapper) - ("qttools" ,qttools) + ("qttools-5" ,qttools-5) ("yasm" ,yasm))) ;; FIXME: Once packaged, add libraries not found during the build. (inputs @@ -4844,7 +4844,7 @@ transitions, and effects and then export your film to many common formats.") (native-inputs `(("pkg-config" ,pkg-config) ("python-wrapper" ,python-wrapper) - ("qttools" ,qttools))) + ("qttools-5" ,qttools-5))) (inputs (list bash-minimal ffmpeg diff --git a/guix/lint.scm b/guix/lint.scm index 73581b518f..edba1c2663 100644 --- a/guix/lint.scm +++ b/guix/lint.scm @@ -492,7 +492,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "kdoctools" "libtool" "m4" - "qttools" + "qttools-5" "yasm" "nasm" "fasm" "python-coverage" "python-cython" @@ -507,7 +507,7 @@ of a package, and INPUT-NAMES, a list of package specifications such as "scdoc" "swig" "qmake" - "qttools" + "qttools-5" "texinfo" "xorg-server-for-tests" "yelp-tools"))) -- cgit v1.2.3 From 1f466ed6be932526fc69e72ffd50390691d0d382 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Tue, 19 Jul 2022 23:04:25 -0400 Subject: build: qt: Add qtbase argument and wrap Qt environment variables exactly. * guix/build-system/qt.scm (default-qtbase): New variable. (lower) <#:qtbase>: Add argument... [build-inputs]: ... and propagate it here. (qt-build): Add qtbase argument. (qt-cross-build): Likewise. * guix/build/qt-utils.scm (%default-qt-major-version): New variable. (variables-for-wrapping): Add qt-major-version argument, and use it to format the various path prefixes. Wrap QT environment variables exactly. (wrap-qt-program*): Add qt-major-version argument, and pass it to variables-for-wrapping. (wrap-qt-program): Add qt-major-version argument, and pass it to wrap-qt-program*. (wrap-all-qt-programs): Add qtbase argument, and extract the major version from it, passing it to wrap-qt-program*. --- guix/build-system/qt.scm | 14 ++++++++++++++ guix/build/qt-utils.scm | 44 +++++++++++++++++++++++++++++++------------- 2 files changed, 45 insertions(+), 13 deletions(-) (limited to 'guix') diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index a0b968cef3..bd47ade3fc 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2017 Ricardo Wurmus ;;; Copyright © 2019 Hartmut Goebel ;;; Copyright © 2020 Jakub Kądziołka +;;; Copyright © 2022 Maxim Cournoyer ;;; ;;; This file is part of GNU Guix. ;;; @@ -67,11 +68,19 @@ (let ((module (resolve-interface '(gnu packages cmake)))) (module-ref module 'cmake-minimal))) +(define (default-qtbase) + "Return the default qtbase package." + + ;; Do not use `@' to avoid introducing circular dependencies. + (let ((module (resolve-interface '(gnu packages qt)))) + (module-ref module 'qtbase-5))) + ;; This barely is a copy from (guix build-system cmake), only adjusted to use ;; the variables defined here. (define* (lower name #:key source inputs native-inputs outputs system target (cmake (default-cmake)) + (qtbase (default-qtbase)) #:allow-other-keys #:rest arguments) "Return a bag for NAME." @@ -87,6 +96,7 @@ `(("source" ,source)) '()) ,@`(("cmake" ,cmake)) + ,@`(("qtbase" ,qtbase)) ,@native-inputs ,@(if target ;; Use the standard cross inputs of @@ -112,6 +122,7 @@ (define* (qt-build name inputs #:key + qtbase source (guile #f) (outputs '("out")) (configure-flags ''()) (search-paths '()) @@ -150,6 +161,7 @@ provides a 'CMakeLists.txt' file as its build system." #:phases #$(if (pair? phases) (sexp->gexp phases) phases) + #:qtbase #$qtbase #:qt-wrap-excluded-outputs #$qt-wrap-excluded-outputs #:qt-wrap-excluded-inputs #$qt-wrap-excluded-inputs #:configure-flags #$configure-flags @@ -181,6 +193,7 @@ provides a 'CMakeLists.txt' file as its build system." #:key source target build-inputs target-inputs host-inputs + qtbase (guile #f) (outputs '("out")) (configure-flags ''()) @@ -237,6 +250,7 @@ build system." search-path-specification->sexp native-search-paths) #:phases #$phases + #:qtbase #$qtbase #:configure-flags #$configure-flags #:make-flags #$make-flags #:out-of-source? #$out-of-source? diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index fa018a93ac..180b3aad77 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -3,7 +3,7 @@ ;;; Copyright © 2019, 2020, 2021 Hartmut Goebel ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2021 Ludovic Courtès -;;; Copyright © 2021 Maxim Cournoyer +;;; Copyright © 2021, 2022 Maxim Cournoyer ;;; Copyright © 2021 Brendan Tildesley ;;; ;;; This file is part of GNU Guix. @@ -26,10 +26,13 @@ #:use-module (ice-9 match) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) + #:use-module (srfi srfi-71) #:export (wrap-qt-program wrap-all-qt-programs %qt-wrap-excluded-inputs)) +(define %default-qt-major-version "5") + (define %qt-wrap-excluded-inputs '(list "cmake" "extra-cmake-modules" "qttools")) @@ -37,7 +40,9 @@ ;; facilities for per-application data directories, such as ;; /share/quassel. Thus, we include the output directory even if it doesn't ;; contain any of the standard subdirectories. -(define (variables-for-wrapping base-directories output-directory) +(define* (variables-for-wrapping base-directories output-directory + #:key + (qt-major-version %default-qt-major-version)) (define (collect-sub-dirs base-directories file-type subdirectory selectors) ;; Append SUBDIRECTORY and each of BASE-DIRECTORIES, and return the subset @@ -82,17 +87,20 @@ "/applications" "/cursors" "/fonts" "/icons" "/glib-2.0/schemas" "/mime" "/sounds" "/themes" "/wallpapers") '("XDG_CONFIG_DIRS" suffix directory "/etc/xdg") - ;; The following variables can be extended by the user, but not - ;; overridden, to ensure proper operation. - '("QT_PLUGIN_PATH" prefix directory "/lib/qt5/plugins") - '("QML2_IMPORT_PATH" prefix directory "/lib/qt5/qml") + ;; We wrap exactly to avoid potentially mixing Qt5/Qt6 components, which + ;; would cause warnings, perhaps problems. + `("QT_PLUGIN_PATH" = directory + ,(format #f "/lib/qt~a/plugins" qt-major-version)) + `("QML2_IMPORT_PATH" = directory + ,(format #f "/lib/qt~a/qml" qt-major-version)) ;; QTWEBENGINEPROCESS_PATH accepts a single value, which makes 'exact the ;; most suitable environment variable type for it. - '("QTWEBENGINEPROCESS_PATH" = regular - "/lib/qt5/libexec/QtWebEngineProcess")))) + `("QTWEBENGINEPROCESS_PATH" = regular + ,(format #f "/lib/qt~a/libexec/QtWebEngineProcess" qt-major-version))))) (define* (wrap-qt-program* program #:key inputs output-dir - qt-wrap-excluded-inputs) + qt-wrap-excluded-inputs + (qt-major-version %default-qt-major-version)) (define input-directories (filter-map @@ -104,12 +112,14 @@ (let ((vars-to-wrap (variables-for-wrapping (cons output-dir input-directories) - output-dir))) + output-dir + #:qt-major-version qt-major-version))) (when (not (null? vars-to-wrap)) (apply wrap-program program vars-to-wrap)))) (define* (wrap-qt-program program-name #:key inputs output - (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs)) + (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) + (qt-major-version %default-qt-major-version)) "Wrap the specified program (which must reside in the OUTPUT's \"/bin\" directory) with suitably set environment variables. @@ -117,9 +127,11 @@ This is like qt-build-systems's phase \"qt-wrap\", but only the named program is wrapped." (wrap-qt-program* (string-append output "/bin/" program-name) #:output-dir output #:inputs inputs - #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs)) + #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs + #:qt-major-version qt-major-version)) (define* (wrap-all-qt-programs #:key inputs outputs + qtbase (qt-wrap-excluded-outputs '()) (qt-wrap-excluded-inputs %qt-wrap-excluded-inputs) #:allow-other-keys) @@ -131,6 +143,11 @@ Wrapping is not applied to outputs whose name is listed in QT-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not to contain any Qt binaries, and where wrapping would gratuitously add a dependency of that output on Qt." + (define qt-major-version + (let ((_ version (package-name->name+version + (strip-store-file-name qtbase)))) + (first (string-split version #\.)))) + (define (find-files-to-wrap output-dir) (append-map (lambda (dir) @@ -149,7 +166,8 @@ add a dependency of that output on Qt." (unless (member output qt-wrap-excluded-outputs) (for-each (cut wrap-qt-program* <> #:output-dir output-dir #:inputs inputs - #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs) + #:qt-wrap-excluded-inputs qt-wrap-excluded-inputs + #:qt-major-version qt-major-version) (find-files-to-wrap output-dir)))))) (for-each handle-output outputs)) -- cgit v1.2.3 From cce7427f95c51a04675c4b954b02623cdb8bc7c6 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 Aug 2022 10:56:45 +0200 Subject: download: 'url-fetch' closes its HTTP/HTTPS port. * guix/build/download.scm (url-fetch)[fetch]: In the http/https case, close PORT before returning. --- guix/build/download.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 41583e8143..951ca3a57a 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -744,6 +744,7 @@ otherwise simply ignore them." (progress-reporter/file (uri-abbreviation uri) size))) (newline))) + (close-port port) file))) ((ftp) (false-if-exception* (ftp-fetch uri file -- cgit v1.2.3 From 4905b5b83904366d068bde899aae15288cc1adcb Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Mon, 1 Aug 2022 11:58:39 -0400 Subject: build-system: qt: Ensure a default value is provided for #:qtbase. * guix/build-system/qt.scm (qt-build)[qtbase]: Specify a default value. Lower it using ungexp-native. (qt-cross-build): Likewise. Reported-by: Maxime Devos and others. --- guix/build-system/qt.scm | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/build-system/qt.scm b/guix/build-system/qt.scm index bd47ade3fc..a9bf728f25 100644 --- a/guix/build-system/qt.scm +++ b/guix/build-system/qt.scm @@ -122,7 +122,7 @@ (define* (qt-build name inputs #:key - qtbase + (qtbase (default-qtbase)) source (guile #f) (outputs '("out")) (configure-flags ''()) (search-paths '()) @@ -161,7 +161,7 @@ provides a 'CMakeLists.txt' file as its build system." #:phases #$(if (pair? phases) (sexp->gexp phases) phases) - #:qtbase #$qtbase + #:qtbase #+qtbase #:qt-wrap-excluded-outputs #$qt-wrap-excluded-outputs #:qt-wrap-excluded-inputs #$qt-wrap-excluded-inputs #:configure-flags #$configure-flags @@ -193,7 +193,7 @@ provides a 'CMakeLists.txt' file as its build system." #:key source target build-inputs target-inputs host-inputs - qtbase + (qtbase (default-qtbase)) (guile #f) (outputs '("out")) (configure-flags ''()) @@ -250,7 +250,7 @@ build system." search-path-specification->sexp native-search-paths) #:phases #$phases - #:qtbase #$qtbase + #:qtbase #+qtbase #:configure-flags #$configure-flags #:make-flags #$make-flags #:out-of-source? #$out-of-source? -- cgit v1.2.3 From 6b5ef03a2582ab23228478018fd356e17db1daea Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Fri, 1 Jul 2022 16:37:44 +0200 Subject: guix: build: Switch from asdf:compile-system to asdf:load-system. According to the ASDF manual: This will make sure all the files in the system are compiled, but not necessarily load any of them in the current image; on most systems, it will _not_ load all compiled files in the current image. This function exists for symmetry with 'load-system' but is not recommended unless you are writing build scripts and know what you're doing. * guix/build/lisp-utils.scm (compile-systems): Switch from asdf:compile-system to asdf:load-system. Signed-off-by: Guillaume Le Vaillant --- guix/build/lisp-utils.scm | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 17d2637f87..8403c94cb5 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson ;;; Copyright © 2020 Guillaume Le Vaillant +;;; Copyright © 2022 Pierre Neidhardt ;;; ;;; This file is part of GNU Guix. ;;; @@ -116,7 +117,7 @@ Load ASD-FILES first." `(asdf:load-asd (truename ,asd-file))) asd-files) ,@(map (lambda (system) - `(asdf:compile-system ,system)) + `(asdf:load-system ,system)) systems)))) (define (test-system system asd-files test-asd-file) -- cgit v1.2.3 From 6181f1f26310146ae509af2074c55f87e8f21a96 Mon Sep 17 00:00:00 2001 From: Pierre Neidhardt Date: Fri, 1 Jul 2022 17:17:32 +0200 Subject: build-system: asdf: Let ASDF locate the .asd files. This approach has many benefits: - It simplifies the build system. - The package definitions are easier to write. - It fixes a bug with systems that call asdf:clear-system which would cause the load to fail. See for instance test systems using Prove. * guix/build-system/asdf.scm (package-with-build-system): Remove 'asd-files' and replace 'test-asd-file' by 'asd-test-systems'. (lower): Same. * guix/build/asdf-build-system.scm (source-asd-file): Remove since ASDF does it better than us. (find-asd-files): Same. (build): Remove unused asd-files argument. (check): Remove asd-files argument and replace asd-systems by asd-test-systems. * guix/build/lisp-utils.scm (compile-systems): Call to ASDF to find the systems. (test-system): Same. Signed-off-by: Guillaume Le Vaillant --- guix/build-system/asdf.scm | 14 +++++++++----- guix/build/asdf-build-system.scm | 29 +++++++---------------------- guix/build/lisp-utils.scm | 35 +++++++++++++++-------------------- 3 files changed, 31 insertions(+), 47 deletions(-) (limited to 'guix') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index a0f4634db0..46b0742f6e 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -2,6 +2,7 @@ ;;; Copyright © 2016, 2017 Andy Patterson ;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant ;;; Copyright © 2021 Ludovic Courtès +;;; Copyright © 2022 Pierre Neidhardt ;;; ;;; This file is part of GNU Guix. ;;; @@ -202,7 +203,7 @@ set up using CL source package conventions." (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:asd-files #:lisp #:asd-systems #:test-asd-file) + '(#:tests? #:lisp #:asd-systems #:asd-test-systems) (package-arguments pkg)) (package-arguments pkg))) @@ -270,9 +271,8 @@ set up using CL source package conventions." (lambda* (name inputs #:key source outputs (tests? #t) - (asd-files ''()) (asd-systems ''()) - (test-asd-file #f) + (asd-test-systems ''()) (phases '%standard-phases) (search-paths '()) (system (%current-system)) @@ -292,6 +292,11 @@ set up using CL source package conventions." `(quote ,(list package-name))) asd-systems)) + (define test-systems + (if (null? (cadr asd-test-systems)) + systems + asd-test-systems)) + (define builder (with-imported-modules imported-modules #~(begin @@ -302,9 +307,8 @@ set up using CL source package conventions." (%lisp-type #$lisp-type)) (asdf-build #:name #$name #:source #+source - #:asd-files #$asd-files #:asd-systems #$systems - #:test-asd-file #$test-asd-file + #:asd-test-systems #$test-systems #:system #$system #:tests? #$tests? #:phases #$phases diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 6186613e52..0a3c55c6c4 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -1,6 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson ;;; Copyright © 2020, 2021 Guillaume Le Vaillant +;;; Copyright © 2022 Pierre Neidhardt ;;; ;;; This file is part of GNU Guix. ;;; @@ -78,16 +79,6 @@ (,(library-directory object-output) :**/ :*.*.*))) -(define (source-asd-file output name asd-file) - (string-append (lisp-source-directory output name) "/" asd-file)) - -(define (find-asd-files output name asd-files) - (if (null? asd-files) - (find-files (lisp-source-directory output name) "\\.asd$") - (map (lambda (asd-file) - (source-asd-file output name asd-file)) - asd-files))) - (define (copy-files-to-output out name) "Copy all files from the current directory to OUT. Create an extra link to any system-defining files in the source to a convenient location. This is @@ -190,7 +181,7 @@ if it's present in the native-inputs." (setenv "XDG_CONFIG_DIRS" (string-append out "/etc"))) #t) -(define* (build #:key outputs inputs asd-files asd-systems +(define* (build #:key outputs inputs asd-systems #:allow-other-keys) "Compile the system." (let* ((out (library-output outputs)) @@ -198,26 +189,20 @@ if it's present in the native-inputs." (source-path (string-append out (%lisp-source-install-prefix))) (translations (wrap-output-translations `(,(output-translation source-path - out)))) - (asd-files (find-asd-files out system-name asd-files))) + out))))) (setenv "ASDF_OUTPUT_TRANSLATIONS" (replace-escaped-macros (format #f "~S" translations))) (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache - (compile-systems asd-systems asd-files)) + (compile-systems asd-systems (lisp-source-directory out system-name))) #t) -(define* (check #:key tests? outputs inputs asd-files asd-systems - test-asd-file +(define* (check #:key tests? outputs inputs asd-test-systems #:allow-other-keys) "Test the system." (let* ((out (library-output outputs)) - (system-name (main-system-name out)) - (asd-files (find-asd-files out system-name asd-files)) - (test-asd-file - (and=> test-asd-file - (cut source-asd-file out system-name <>)))) + (system-name (main-system-name out))) (if tests? - (test-system (first asd-systems) asd-files test-asd-file) + (test-system asd-test-systems (lisp-source-directory out system-name)) (format #t "test suite not run~%"))) #t) diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 8403c94cb5..7c5d865338 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -108,38 +108,33 @@ with PROGRAM." "--eval" "(quit)")) (_ (error "The LISP provided is not supported at this time.")))) -(define (compile-systems systems asd-files) +(define (compile-systems systems directory) "Use a lisp implementation to compile the SYSTEMS using asdf. Load ASD-FILES first." (lisp-eval-program `((require :asdf) - ,@(map (lambda (asd-file) - `(asdf:load-asd (truename ,asd-file))) - asd-files) + (asdf:initialize-source-registry + (list :source-registry (list :tree (uiop:ensure-pathname ,directory + :truenamize t + :ensure-directory t)) + :inherit-configuration)) ,@(map (lambda (system) `(asdf:load-system ,system)) systems)))) -(define (test-system system asd-files test-asd-file) +(define (test-system test-systems directory) "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILES first. Also load TEST-ASD-FILE if necessary." (lisp-eval-program `((require :asdf) - ,@(map (lambda (asd-file) - `(asdf:load-asd (truename ,asd-file))) - asd-files) - ,@(if test-asd-file - `((asdf:load-asd (truename ,test-asd-file))) - ;; Try some likely files. - (map (lambda (file) - `(when (uiop:file-exists-p ,file) - (asdf:load-asd (truename ,file)))) - (list - (string-append system "-tests.asd") - (string-append system "-test.asd") - "tests.asd" - "test.asd"))) - (asdf:test-system ,system)))) + (asdf:initialize-source-registry + (list :source-registry (list :tree (uiop:ensure-pathname ,directory + :truenamize t + :ensure-directory t)) + :inherit-configuration)) + ,@(map (lambda (system) + `(asdf:test-system ,system)) + test-systems)))) (define (string->lisp-keyword . strings) "Return a lisp keyword for the concatenation of STRINGS." -- cgit v1.2.3 From c232375340354f5f137b7495a85ed1df1e0f74c5 Mon Sep 17 00:00:00 2001 From: Guillaume Le Vaillant Date: Wed, 3 Aug 2022 11:46:17 +0200 Subject: build-system: asdf: Add asd-operation parameter. The 'asd-operation' parameter can be used to specify the ASDF operation to use in the build phase. It's default value is "load-system". * guix/build-system/asdf.scm (package-with-build-system, asdf-build): Add 'asd-operation' parameter. * guix/build/asdf-buid-system.scm (build): Add 'asd-operation' parameter and use it. * guix/build/lisp-utils.scm (compile-systems): Add 'asd-operation' parameter and use it. --- guix/build-system/asdf.scm | 6 ++++-- guix/build/asdf-build-system.scm | 8 +++++--- guix/build/lisp-utils.scm | 12 +++++------- 3 files changed, 14 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/build-system/asdf.scm b/guix/build-system/asdf.scm index 46b0742f6e..74a3e47da1 100644 --- a/guix/build-system/asdf.scm +++ b/guix/build-system/asdf.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson -;;; Copyright © 2019, 2020, 2021 Guillaume Le Vaillant +;;; Copyright © 2019, 2020, 2021, 2022 Guillaume Le Vaillant ;;; Copyright © 2021 Ludovic Courtès ;;; Copyright © 2022 Pierre Neidhardt ;;; @@ -203,7 +203,7 @@ set up using CL source package conventions." (define base-arguments (if target-is-source? (strip-keyword-arguments - '(#:tests? #:lisp #:asd-systems #:asd-test-systems) + '(#:tests? #:lisp #:asd-systems #:asd-test-systems #:asd-operation) (package-arguments pkg)) (package-arguments pkg))) @@ -273,6 +273,7 @@ set up using CL source package conventions." (tests? #t) (asd-systems ''()) (asd-test-systems ''()) + (asd-operation "load-system") (phases '%standard-phases) (search-paths '()) (system (%current-system)) @@ -309,6 +310,7 @@ set up using CL source package conventions." #:source #+source #:asd-systems #$systems #:asd-test-systems #$test-systems + #:asd-operation #$asd-operation #:system #$system #:tests? #$tests? #:phases #$phases diff --git a/guix/build/asdf-build-system.scm b/guix/build/asdf-build-system.scm index 0a3c55c6c4..92154e7d34 100644 --- a/guix/build/asdf-build-system.scm +++ b/guix/build/asdf-build-system.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson -;;; Copyright © 2020, 2021 Guillaume Le Vaillant +;;; Copyright © 2020, 2021, 2022 Guillaume Le Vaillant ;;; Copyright © 2022 Pierre Neidhardt ;;; ;;; This file is part of GNU Guix. @@ -181,7 +181,7 @@ if it's present in the native-inputs." (setenv "XDG_CONFIG_DIRS" (string-append out "/etc"))) #t) -(define* (build #:key outputs inputs asd-systems +(define* (build #:key outputs inputs asd-systems asd-operation #:allow-other-keys) "Compile the system." (let* ((out (library-output outputs)) @@ -193,7 +193,9 @@ if it's present in the native-inputs." (setenv "ASDF_OUTPUT_TRANSLATIONS" (replace-escaped-macros (format #f "~S" translations))) (setenv "HOME" out) ; ecl's asdf sometimes wants to create $HOME/.cache - (compile-systems asd-systems (lisp-source-directory out system-name))) + (compile-systems asd-systems + (lisp-source-directory out system-name) + asd-operation)) #t) (define* (check #:key tests? outputs inputs asd-test-systems diff --git a/guix/build/lisp-utils.scm b/guix/build/lisp-utils.scm index 7c5d865338..646d4a3365 100644 --- a/guix/build/lisp-utils.scm +++ b/guix/build/lisp-utils.scm @@ -1,6 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2016, 2017 Andy Patterson -;;; Copyright © 2020 Guillaume Le Vaillant +;;; Copyright © 2020, 2022 Guillaume Le Vaillant ;;; Copyright © 2022 Pierre Neidhardt ;;; ;;; This file is part of GNU Guix. @@ -108,9 +108,8 @@ with PROGRAM." "--eval" "(quit)")) (_ (error "The LISP provided is not supported at this time.")))) -(define (compile-systems systems directory) - "Use a lisp implementation to compile the SYSTEMS using asdf. -Load ASD-FILES first." +(define (compile-systems systems directory operation) + "Use a lisp implementation to compile the SYSTEMS using asdf." (lisp-eval-program `((require :asdf) (asdf:initialize-source-registry @@ -119,12 +118,11 @@ Load ASD-FILES first." :ensure-directory t)) :inherit-configuration)) ,@(map (lambda (system) - `(asdf:load-system ,system)) + (list (string->symbol (string-append "asdf:" operation)) system)) systems)))) (define (test-system test-systems directory) - "Use a lisp implementation to test SYSTEM using asdf. Load ASD-FILES first. -Also load TEST-ASD-FILE if necessary." + "Use a lisp implementation to test the TEST-SYSTEMS using asdf." (lisp-eval-program `((require :asdf) (asdf:initialize-source-registry -- cgit v1.2.3 From dd573ceea73295c7a872088ecd91e5f0fd74bf2b Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 Aug 2022 11:01:52 +0200 Subject: download: Do not wrap TLS port on GnuTLS >= 3.7.7. The custom input/output port wrapping the TLS session record port would introduce overhead, and it would also prevent its uses in a non-blocking context--e.g., with Fibers. The port close mechanism added in GnuTLS 3.7.7 allows us to get rid of that wrapper. * guix/build/download.scm (wrap-record-port-for-gnutls<3.7.7): New procedure, with code formerly in 'tls-wrap'. (tls-wrap): Check for 'set-session-record-port-close!' and use it when available; otherwise call 'wrap-record-port-for-gnutls<3.7.7'. --- guix/build/download.scm | 102 +++++++++++++++++++++++++----------------------- 1 file changed, 54 insertions(+), 48 deletions(-) (limited to 'guix') diff --git a/guix/build/download.scm b/guix/build/download.scm index 951ca3a57a..db0a39084b 100644 --- a/guix/build/download.scm +++ b/guix/build/download.scm @@ -245,6 +245,54 @@ way." (set-exception-printer! 'tls-certificate-error print-tls-certificate-error) +(define (wrap-record-port-for-gnutls<3.7.7 record port) + "Return a port that wraps RECORD to ensure that closing it also closes PORT, +the actual socket port, and its file descriptor. Make sure it does not +introduce extra buffering (custom ports are buffered by default as of Guile +3.0.5). + +This wrapper is unnecessary with GnuTLS >= 3.7.7, which can automatically +close SESSION's file descriptor when RECORD is closed." + (define (read! bv start count) + (define read + (catch 'gnutls-error + (lambda () + (get-bytevector-n! record bv start count)) + (lambda (key err proc . rest) + ;; When responding to "Connection: close" requests, some servers + ;; close the connection abruptly after sending the response body, + ;; without doing a proper TLS connection termination. Treat it as + ;; EOF. This is fixed in GnuTLS 3.7.7. + (if (eq? err error/premature-termination) + the-eof-object + (apply throw key err proc rest))))) + + (if (eof-object? read) + 0 + read)) + (define (write! bv start count) + (put-bytevector record bv start count) + (force-output record) + count) + (define (get-position) + (port-position record)) + (define (set-position! new-position) + (set-port-position! record new-position)) + (define (close) + (unless (port-closed? port) + (close-port port)) + (unless (port-closed? record) + (close-port record))) + + (define (unbuffered port) + (setvbuf port 'none) + port) + + (unbuffered + (make-custom-binary-input/output-port "gnutls wrapped port" read! write! + get-position set-position! + close))) + (define* (tls-wrap port server #:key (verify-certificate? #t)) "Return PORT wrapped in a TLS connection to SERVER. SERVER must be a DNS host name without trailing dot." @@ -317,55 +365,13 @@ host name without trailing dot." (apply throw args)))) (let ((record (session-record-port session))) - (define (read! bv start count) - (define read - (catch 'gnutls-error - (lambda () - (get-bytevector-n! record bv start count)) - (lambda (key err proc . rest) - ;; When responding to "Connection: close" requests, some - ;; servers close the connection abruptly after sending the - ;; response body, without doing a proper TLS connection - ;; termination. Treat it as EOF. - (if (eq? err error/premature-termination) - the-eof-object - (apply throw key err proc rest))))) - - (if (eof-object? read) - 0 - read)) - (define (write! bv start count) - (put-bytevector record bv start count) - (force-output record) - count) - (define (get-position) - (port-position record)) - (define (set-position! new-position) - (set-port-position! record new-position)) - (define (close) - (unless (port-closed? port) - (close-port port)) - (unless (port-closed? record) - (close-port record))) - - (define (unbuffered port) - (setvbuf port 'none) - port) - (setvbuf record 'block) - - ;; Return a port that wraps RECORD to ensure that closing it also - ;; closes PORT, the actual socket port, and its file descriptor. - ;; Make sure it does not introduce extra buffering (custom ports - ;; are buffered by default as of Guile 3.0.5). - ;; XXX: This wrapper would be unnecessary if GnuTLS could - ;; automatically close SESSION's file descriptor when RECORD is - ;; closed, but that doesn't seem to be possible currently (as of - ;; 3.6.9). - (unbuffered - (make-custom-binary-input/output-port "gnutls wrapped port" read! write! - get-position set-position! - close))))) + (if (module-defined? (resolve-interface '(gnutls)) + 'set-session-record-port-close!) ;GnuTLS >= 3.7.7 + (let ((close-wrapped-port (lambda (_) (close-port port)))) + (set-session-record-port-close! record close-wrapped-port) + record) + (wrap-record-port-for-gnutls<3.7.7 record port))))) (define (ensure-uri uri-or-string) ;XXX: copied from (web http) (cond -- cgit v1.2.3 From f44c13560885a8751fe59ba2e512a726c1674b1e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 3 Aug 2022 23:01:01 +0200 Subject: guix build: Print hints when -s or --target is passed an invalid string. * guix/scripts/build.scm (%standard-cross-build-options) (%standard-native-build-options): Print hints when the target/system is not found. --- guix/scripts/build.scm | 29 +++++++++++++++++++++++++---- 1 file changed, 25 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/scripts/build.scm b/guix/scripts/build.scm index 75bbb701ae..06d9ad1f0c 100644 --- a/guix/scripts/build.scm +++ b/guix/scripts/build.scm @@ -373,8 +373,19 @@ use '--no-offload' instead~%"))) (first (member arg (targets)))))) (if t (apply values (alist-cons 'target t result) rest) - (leave (G_ "'~a' is not a supported target~%") - arg))))))) + (let ((closest (string-closest arg (targets) + #:threshold 5))) + (report-error + (G_ "'~a' is not a supported cross-compilation target~%") + arg) + (if closest + (display-hint + (format #f (G_ "Did you mean @code{~a}? +Try @option{--list-targets} to view available targets.~%") + closest)) + (display-hint (G_ "\ +Try @option{--list-targets} to view available targets.~%"))) + (exit 1)))))))) (define %standard-native-build-options ;; Build options related to native builds. @@ -389,8 +400,18 @@ use '--no-offload' instead~%"))) (first (member arg (systems)))))) (if s (apply values (alist-cons 'system s result) rest) - (leave (G_ "'~a' is not a supported system~%") - arg))))))) + (let ((closest (string-closest arg (systems) + #:threshold 5))) + (report-error (G_ "'~a' is not a supported system~%") + arg) + (if closest + (display-hint + (format #f (G_ "Did you mean @code{~a}? +Try @option{--list-systems} to view available system types.~%") + closest)) + (display-hint (G_ "\ +Try @option{--list-systems} to view available system types.~%"))) + (exit 1)))))))) ;;; -- cgit v1.2.3 From ae1f12018112573bf142596b78d75dbfd723d859 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 4 Aug 2022 11:13:48 +0200 Subject: environment: Report "command not found" from the child process. Fixes a bug whereby, for example: guix shell bash -- bash -c xyz would erroneously print: guix shell: error: bash: command not found simply because the parent process could not distinguish that 127 from a "genuine" 127 used by convention for "command not found". * guix/scripts/environment.scm (launch-environment): Before exiting, report a "command not found" error and suggest a command name. (validate-exit-status): Remove. (launch-environment/fork): Remove call (launch-environment/container)[exit/status*]: Remove. Call 'exit/status' instead of it. --- guix/scripts/environment.scm | 27 ++++++++++----------------- 1 file changed, 10 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/scripts/environment.scm b/guix/scripts/environment.scm index 3216235937..2493134470 100644 --- a/guix/scripts/environment.scm +++ b/guix/scripts/environment.scm @@ -408,7 +408,14 @@ regexps in WHITE-LIST." (lambda () (apply execlp program program args)) (lambda _ - ;; Following established convention, exit with 127 upon ENOENT. + ;; Report the error from here because the parent process cannot + ;; distinguish between the conventional 127 exit code and a process + ;; that exited with 127 for other reasons (e.g., "sh -c xyz"). + (report-error (G_ "~a: command not found~%") program) + (suggest-command-name profile command) + + ;; Following established convention, exit with 127 (aka. EX_NOTFOUND) + ;; upon ENOENT. (primitive-_exit 127)))))) (define (child-shell-environment shell profile manifest) @@ -581,17 +588,6 @@ command name." (display-hint (format #f (G_ "Did you mean '~a'?~%") closest))))))))) -(define (validate-exit-status profile command status) - "When STATUS, an integer as returned by 'waitpid', is 127, raise a \"command -not found\" error. Otherwise return STATUS." - ;; Most likely, exit value 127 means ENOENT. - (when (eqv? (status:exit-val status) 127) - (report-error (G_ "~a: command not found~%") - (first command)) - (suggest-command-name profile command) - (exit 1)) - status) - (define* (launch-environment/fork command profile manifest #:key pure? (white-list '())) "Run COMMAND in a new process with an environment containing PROFILE, with @@ -604,7 +600,7 @@ regexps in WHITE-LIST." #:white-list white-list)) (pid (match (waitpid pid) ((_ . status) - (validate-exit-status profile command status)))))) + status))))) (define* (launch-environment/container #:key command bash user user-mappings profile manifest link-profile? network? @@ -625,9 +621,6 @@ WHILE-LIST." (and (file-exists? (file-system-mapping-source mapping)) (file-system-mapping->bind-mount mapping))) - (define (exit/status* status) - (exit/status (validate-exit-status profile command status))) - (mlet %store-monad ((reqs (inputs->requisites (list (direct-store-path bash) profile)))) (return @@ -684,7 +677,7 @@ WHILE-LIST." '()) (map file-system-mapping->bind-mount mappings)))) - (exit/status* + (exit/status (call-with-container file-systems (lambda () ;; Setup global shell. -- cgit v1.2.3 From a956c7df87536717e4e04af11ae6d73dcb7a2ce7 Mon Sep 17 00:00:00 2001 From: Maxim Cournoyer Date: Thu, 4 Aug 2022 11:47:03 -0400 Subject: build: qt-utils: Fix another regression. This fixes another regression introduced with 1f466ed6be932526fc69e72ffd50390691d0d382, which affected the packages bitmask, hime, hime, nimf and vorta. The fix is to provide a default qt-major-version when #:qtbase is missing, such as when borrowing the qt-wrap phase in a package not using the Qt build system. * guix/build/qt-utils.scm (wrap-all-qt-programs)[qt-major-version]: Fall-back to %default-qt-major-version when #:qtbase is #f. Reported-by: John Kehayias and others. --- guix/build/qt-utils.scm | 10 +++++++--- 1 file changed, 7 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/build/qt-utils.scm b/guix/build/qt-utils.scm index 180b3aad77..2e47f1bc02 100644 --- a/guix/build/qt-utils.scm +++ b/guix/build/qt-utils.scm @@ -144,9 +144,13 @@ QT-WRAP-EXCLUDED-OUTPUTS. This is useful when an output is known not to contain any Qt binaries, and where wrapping would gratuitously add a dependency of that output on Qt." (define qt-major-version - (let ((_ version (package-name->name+version - (strip-store-file-name qtbase)))) - (first (string-split version #\.)))) + (if qtbase + (let ((_ version (package-name->name+version + (strip-store-file-name qtbase)))) + (first (string-split version #\.))) + ;; Provide a fall-back for build systems not having a #:qtbase + ;; argument. + %default-qt-major-version)) (define (find-files-to-wrap output-dir) (append-map -- cgit v1.2.3 From 68edaf467fccd93103f08a5a225f7b475454694b Mon Sep 17 00:00:00 2001 From: Antero Mejr Date: Sat, 25 Jun 2022 21:30:32 +0000 Subject: utils: Add as-for-target. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (as-for-target): New function. Signed-off-by: Ludovic Courtès --- guix/utils.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index 329ef62dde..b992b49815 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -15,6 +15,7 @@ ;;; Copyright © 2018 Steve Sprang ;;; Copyright © 2022 Taiju HIGASHI ;;; Copyright © 2022 Denis 'GNUtoo' Carikli +;;; Copyright © 2022 Antero Mejr ;;; ;;; This file is part of GNU Guix. ;;; @@ -103,6 +104,7 @@ target-riscv64? target-64bit? ar-for-target + as-for-target cc-for-target cxx-for-target ld-for-target @@ -742,6 +744,11 @@ architecture (x86_64)?" (string-append target "-ar") "ar")) +(define* (as-for-target #:optional (target (%current-target-system))) + (if target + (string-append target "-as") + "as")) + (define* (cc-for-target #:optional (target (%current-target-system))) (if target (string-append target "-gcc") -- cgit v1.2.3 From 94e0fb1eb7409b3cd1a3e0528c2f199c5a2f48d5 Mon Sep 17 00:00:00 2001 From: Vivien Kraus Date: Tue, 19 Jul 2022 20:05:45 +0200 Subject: utils: Add target-mips64el?. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * guix/utils.scm (target-mips64el?): New function. It detects whether the target system is mips64el. Signed-off-by: Ludovic Courtès --- guix/utils.scm | 5 +++++ 1 file changed, 5 insertions(+) (limited to 'guix') diff --git a/guix/utils.scm b/guix/utils.scm index b992b49815..aca0af4e4b 100644 --- a/guix/utils.scm +++ b/guix/utils.scm @@ -102,6 +102,7 @@ target-ppc64le? target-powerpc? target-riscv64? + target-mips64el? target-64bit? ar-for-target as-for-target @@ -734,6 +735,10 @@ architecture (x86_64)?" "Is the architecture of TARGET a 'riscv64' machine?" (string-prefix? "riscv64" target)) +(define* (target-mips64el? #:optional (target (or (%current-target-system) + (%current-system)))) + (string-prefix? "mips64el-" target)) + (define* (target-64bit? #:optional (system (or (%current-target-system) (%current-system)))) (any (cut string-prefix? <> system) '("x86_64" "aarch64" "mips64" -- cgit v1.2.3 From d11a432adffe9308eafec6b77cddd3145029109e Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 5 Aug 2022 15:26:17 +0200 Subject: guix system: Remove unused 'read-operating-system' procedure. * guix/scripts/system.scm (read-operating-system): Remove. * gnu/ci.scm: Remove unused (guix scripts system) import. --- gnu/ci.scm | 1 - guix/scripts/system.scm | 5 ----- 2 files changed, 6 deletions(-) (limited to 'guix') diff --git a/gnu/ci.scm b/gnu/ci.scm index f476e22731..9389b43824 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -39,7 +39,6 @@ #:use-module ((guix licenses) #:select (gpl3+ license? license-name)) #:use-module ((guix utils) #:select (%current-system)) - #:use-module ((guix scripts system) #:select (read-operating-system)) #:use-module ((guix scripts pack) #:select (lookup-compressor self-contained-tarball)) #:use-module (gnu bootloader) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index bfde0a88ca..be6e839941 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -91,7 +91,6 @@ #:use-module (ice-9 match) #:use-module (rnrs bytevectors) #:export (guix-system - read-operating-system service-node-type shepherd-service-node-type)) @@ -107,10 +106,6 @@ (gnu services) (gnu system shadow)))) -(define (read-operating-system file) - "Read the operating-system declaration from FILE and return it." - (load* file %user-module)) - ;;; ;;; Installation. -- cgit v1.2.3 From 74fbbb1661bfcb49591daadcf06a66a4fd6d2c45 Mon Sep 17 00:00:00 2001 From: Maxime Devos Date: Tue, 2 Aug 2022 14:13:26 +0200 Subject: build-system/perl: Support cross-compilation of some Perl packages. * guix/build-system/perl.scm: Add info on cross-compilation. (lower)[private-keywords]: Remove #:target when cross-compiling. (lower)[target]: Set. (host-inputs)[perl]: New entry. (host-inputs)[(standard-packages)]: Move to ... (build-inputs)[(standard-packages)]: ... here when cross-compiling. (build-inputs)[standard-cross-packages]: Add when cross-compiling. (target-inputs): New entry when cross-compiling. (build): Use perl-cross-build when cross-compiling. (perl-cross-build): New procedure. Signed-off-by: Mathieu Othacehe --- guix/build-system/perl.scm | 122 ++++++++++++++++++++++++++++++++++++++------- 1 file changed, 105 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/build-system/perl.scm b/guix/build-system/perl.scm index db0a916fb2..43ec2fdcb6 100644 --- a/guix/build-system/perl.scm +++ b/guix/build-system/perl.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2021 Ludovic Courtès +;;; Copyright © 2022 Maxime Devos ;;; ;;; This file is part of GNU Guix. ;;; @@ -29,13 +30,17 @@ #:use-module (ice-9 match) #:export (%perl-build-system-modules perl-build + perl-cross-build perl-build-system)) ;; Commentary: ;; ;; Standard build procedure for Perl packages using the "makefile ;; maker"---i.e., "perl Makefile.PL". This is implemented as an extension of -;; `gnu-build-system'. +;; `gnu-build-system'. Cross-compilation is supported for some simple Perl +;; packages, but not for any Perl packages that do things like XS (Perl's FFI), +;; which makes C-style shared libraries, as it is currently not known how to +;; tell Perl to properly cross-compile. ;; ;; Code: @@ -59,24 +64,44 @@ #:rest arguments) "Return a bag for NAME." (define private-keywords - '(#:target #:perl #:inputs #:native-inputs)) + `(#:perl #:inputs #:native-inputs + ,@(if target '() '(#:target)))) - (and (not target) ;XXX: no cross-compilation - (bag - (name name) - (system system) - (host-inputs `(,@(if source - `(("source" ,source)) - '()) - ,@inputs + (bag + (name name) + (system system) (target target) + (host-inputs `(,@(if source + `(("source" ,source)) + '()) + ,@inputs + ;; For interpreters in #! (shebang) + ,@(if target + `(("perl" ,perl)) + '()) - ;; Keep the standard inputs of 'gnu-build-system'. - ,@(standard-packages))) - (build-inputs `(("perl" ,perl) - ,@native-inputs)) - (outputs outputs) - (build perl-build) - (arguments (strip-keyword-arguments private-keywords arguments))))) + ;; Keep the standard inputs of 'gnu-build-system'. + ;; TODO: make this unconditional, putting this into + ;; 'build-inputs'. + ,@(if target + '() + (standard-packages)))) + (build-inputs `(("perl" ,perl) + ,@native-inputs + ,@(if target + (standard-cross-packages target 'host) + '()) + ,@(if target + (standard-packages) + '()))) + ;; Keep the standard inputs of 'gnu-build-system'. + (target-inputs (if target + (standard-cross-packages target 'target) + '())) + (outputs outputs) + (build (if target + perl-cross-build + perl-build)) + (arguments (strip-keyword-arguments private-keywords arguments)))) (define* (perl-build name inputs #:key source @@ -127,6 +152,69 @@ provides a `Makefile.PL' file as its build system." (gexp->derivation name build #:system system #:target #f + #:graft? #f + #:guile-for-build guile))) + +(define* (perl-cross-build name #:key + source + target + build-inputs host-inputs target-inputs + (search-paths '()) + (native-search-paths '()) + (tests? #f) ; usually not possible when cross-compiling + (parallel-build? #t) + (parallel-tests? #t) + (make-maker? #f) + (make-maker-flags ''()) + (module-build-flags ''()) + (phases '(@ (guix build perl-build-system) + %standard-phases)) + (outputs '("out")) + (system (%current-system)) + (build (nix-system->gnu-triplet system)) + (guile #f) + (imported-modules %perl-build-system-modules) + (modules '((guix build perl-build-system) + (guix build utils)))) + "Cross-build SOURCE to TARGET using PERL, and with INPUTS. This assumes +that SOURCE provides a `Makefile.PL' file as its build system and does not use +XS or similar." + (define inputs + #~(append #$(input-tuples->gexp host-inputs) + #+(input-tuples->gexp target-inputs))) + (define builder + (with-imported-modules imported-modules + #~(begin + (use-modules #$@(sexp->gexp modules)) + (perl-build #:name #$name + #:source #+source + #:search-paths '#$(sexp->gexp + (map search-path-specification->sexp + search-paths)) + #:native-search-paths + '#$(sexp->gexp + (map search-path-specification->sexp + native-search-paths)) + #:make-maker? #$make-maker? + #:make-maker-flags #$make-maker-flags + #:module-build-flags #$(sexp->gexp module-build-flags) + #:phases #$phases + #:build #$build + #:system #$system + #:target #$target + #:test-target "test" + #:tests? #$tests? + #:parallel-build? #$parallel-build? + #:parallel-tests? #$parallel-tests? + #:outputs #$(outputs->gexp outputs) + #:inputs #$inputs + #:native-inputs #+(input-tuples->gexp build-inputs))))) + (mlet %store-monad ((guile (package->derivation (or guile (default-guile)) + system #:graft? #f))) + (gexp->derivation name builder + #:system system + #:target target + #:graft? #false #:guile-for-build guile))) (define perl-build-system -- cgit v1.2.3 From ad8beb6325acf067387ac6387f9ee1b6f84893b4 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Sun, 7 Aug 2022 11:53:32 +0200 Subject: lint: Add '-e'. * guix/scripts/lint.scm (show-help, %options): Add '-e'. (guix-lint): Call 'specification->package' while traversing OPTS. Add case for 'expression pair. Adjust 'for-each' loop to expect packages. * doc/guix.texi (Invoking guix lint): Document it. --- doc/guix.texi | 10 ++++++++++ guix/scripts/lint.scm | 22 ++++++++++++++-------- 2 files changed, 24 insertions(+), 8 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 21cee4e369..d6460a785f 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -14359,6 +14359,16 @@ names returned by @option{--list-checkers}. Only disable the checkers specified in a comma-separated list using the names returned by @option{--list-checkers}. +@item --expression=@var{expr} +@itemx -e @var{expr} +Consider the package @var{expr} evaluates to. + +This is useful to unambiguously designate packages, as in this example: + +@example +guix lint -c archival -e '(@@ (gnu packages guile) guile-3.0)' +@end example + @item --no-network @itemx -n Only enable the checkers that do not depend on Internet access. diff --git a/guix/scripts/lint.scm b/guix/scripts/lint.scm index c72dc3caad..9920c3ee62 100644 --- a/guix/scripts/lint.scm +++ b/guix/scripts/lint.scm @@ -1,7 +1,7 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2014 Cyril Roelandt ;;; Copyright © 2014, 2015 Eric Bavier -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2013-2020, 2022 Ludovic Courtès ;;; Copyright © 2015, 2016 Mathieu Lirzin ;;; Copyright © 2016 Danny Milosavljevic ;;; Copyright © 2016 Hartmut Goebel @@ -108,6 +108,8 @@ run the checkers on all packages.\n")) exclude the specified checkers")) (display (G_ " -n, --no-network only run checkers that do not access the network")) + (display (G_ " + -e, --expression=EXPR consider the package EXPR evaluates to")) (display (G_ " -L, --load-path=DIR prepend DIR to the package module search path")) @@ -161,9 +163,11 @@ run the checkers on all packages.\n")) (exit 0))) (option '(#\l "list-checkers") #f #f (lambda (opt name arg result) - (alist-cons 'list? - #t - result))) + (alist-cons 'list? #t result))) + (option '(#\e "expression") #t #f + (lambda (opt name arg result) + (alist-cons 'expression arg result))) + (option '(#\V "version") #f #f (lambda args (show-version-and-exit "guix lint"))))) @@ -184,8 +188,10 @@ run the checkers on all packages.\n")) (let* ((opts (parse-options)) (args (filter-map (match-lambda - (('argument . value) - value) + (('argument . spec) + (specification->package spec)) + (('expression . exp) + (read/eval-package-expression exp)) (_ #f)) (reverse opts))) (no-checkers (or (assoc-ref opts 'exclude) '())) @@ -219,7 +225,7 @@ run the checkers on all packages.\n")) (fold-packages (lambda (p r) (run-checkers p checkers #:store store)) '())) (else - (for-each (lambda (spec) - (run-checkers (specification->package spec) checkers + (for-each (lambda (package) + (run-checkers package checkers #:store store)) args))))))))) -- cgit v1.2.3 From 5817e222faf46f76fbdb66ba8fd6c8cd643aefb5 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 20 Jul 2022 19:11:21 +0200 Subject: style: Move reader and printer to (guix read-print). * guix/scripts/style.scm (, read-with-comments) (vhashq, %special-forms, %newline-forms, prefix?) (special-form-lead, newline-form?, escaped-string) (string-width, canonicalize-comment, pretty-print-with-comments) (object->string*): Move to... * guix/read-print.scm: ... here. New file. * guix/scripts/import.scm: Adjust accordingly. * tests/style.scm: Move 'test-pretty-print' and tests to... * tests/read-print.scm: ... here. New file. * Makefile.am (MODULES): Add 'guix/read-print.scm'. (SCM_TESTS): Add 'tests/read-print.scm'. --- Makefile.am | 2 + guix/read-print.scm | 490 ++++++++++++++++++++++++++++++++++++++++++++++++ guix/scripts/import.scm | 4 +- guix/scripts/style.scm | 457 +------------------------------------------- tests/read-print.scm | 209 +++++++++++++++++++++ tests/style.scm | 181 ------------------ 6 files changed, 705 insertions(+), 638 deletions(-) create mode 100644 guix/read-print.scm create mode 100644 tests/read-print.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index e5363140fb..2cda20e61c 100644 --- a/Makefile.am +++ b/Makefile.am @@ -130,6 +130,7 @@ MODULES = \ guix/cve.scm \ guix/workers.scm \ guix/least-authority.scm \ + guix/read-print.scm \ guix/ipfs.scm \ guix/platform.scm \ guix/platforms/arm.scm \ @@ -524,6 +525,7 @@ SCM_TESTS = \ tests/profiles.scm \ tests/publish.scm \ tests/pypi.scm \ + tests/read-print.scm \ tests/records.scm \ tests/scripts.scm \ tests/search-paths.scm \ diff --git a/guix/read-print.scm b/guix/read-print.scm new file mode 100644 index 0000000000..69ab8ac8b3 --- /dev/null +++ b/guix/read-print.scm @@ -0,0 +1,490 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021-2022 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix read-print) + #:use-module (ice-9 control) + #:use-module (ice-9 match) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 vlist) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (pretty-print-with-comments + read-with-comments + object->string* + + comment? + comment->string + comment-margin? + canonicalize-comment)) + +;;; Commentary: +;;; +;;; This module provides a comment-preserving reader and a comment-preserving +;;; pretty-printer smarter than (ice-9 pretty-print). +;;; +;;; Code: + + +;;; +;;; Comment-preserving reader. +;;; + +;; A comment. +(define-record-type + (comment str margin?) + comment? + (str comment->string) + (margin? comment-margin?)) + +(define (read-with-comments port) + "Like 'read', but include objects when they're encountered." + ;; Note: Instead of implementing this functionality in 'read' proper, which + ;; is the best approach long-term, this code is a layer on top of 'read', + ;; such that we don't have to rely on a specific Guile version. + (define dot (list 'dot)) + (define (dot? x) (eq? x dot)) + + (define (reverse/dot lst) + ;; Reverse LST and make it an improper list if it contains DOT. + (let loop ((result '()) + (lst lst)) + (match lst + (() result) + (((? dot?) . rest) + (let ((dotted (reverse rest))) + (set-cdr! (last-pair dotted) (car result)) + dotted)) + ((x . rest) (loop (cons x result) rest))))) + + (let loop ((blank-line? #t) + (return (const 'unbalanced))) + (match (read-char port) + ((? eof-object? eof) + eof) ;oops! + (chr + (cond ((eqv? chr #\newline) + (loop #t return)) + ((char-set-contains? char-set:whitespace chr) + (loop blank-line? return)) + ((memv chr '(#\( #\[)) + (let/ec return + (let liip ((lst '())) + (liip (cons (loop (match lst + (((? comment?) . _) #t) + (_ #f)) + (lambda () + (return (reverse/dot lst)))) + lst))))) + ((memv chr '(#\) #\])) + (return)) + ((eq? chr #\') + (list 'quote (loop #f return))) + ((eq? chr #\`) + (list 'quasiquote (loop #f return))) + ((eq? chr #\,) + (list (match (peek-char port) + (#\@ + (read-char port) + 'unquote-splicing) + (_ + 'unquote)) + (loop #f return))) + ((eqv? chr #\;) + (unread-char chr port) + (comment (read-line port 'concat) + (not blank-line?))) + (else + (unread-char chr port) + (match (read port) + ((and token '#{.}#) + (if (eq? chr #\.) dot token)) + (token token)))))))) + +;;; +;;; Comment-preserving pretty-printer. +;;; + +(define-syntax vhashq + (syntax-rules (quote) + ((_) vlist-null) + ((_ (key (quote (lst ...))) rest ...) + (vhash-consq key '(lst ...) (vhashq rest ...))) + ((_ (key value) rest ...) + (vhash-consq key '((() . value)) (vhashq rest ...))))) + +(define %special-forms + ;; Forms that are indented specially. The number is meant to be understood + ;; like Emacs' 'scheme-indent-function' symbol property. When given an + ;; alist instead of a number, the alist gives "context" in which the symbol + ;; is a special form; for instance, context (modify-phases) means that the + ;; symbol must appear within a (modify-phases ...) expression. + (vhashq + ('begin 1) + ('lambda 2) + ('lambda* 2) + ('match-lambda 1) + ('match-lambda* 2) + ('define 2) + ('define* 2) + ('define-public 2) + ('define*-public 2) + ('define-syntax 2) + ('define-syntax-rule 2) + ('define-module 2) + ('define-gexp-compiler 2) + ('let 2) + ('let* 2) + ('letrec 2) + ('letrec* 2) + ('match 2) + ('when 2) + ('unless 2) + ('package 1) + ('origin 1) + ('operating-system 1) + ('modify-inputs 2) + ('modify-phases 2) + ('add-after '(((modify-phases) . 3))) + ('add-before '(((modify-phases) . 3))) + ('replace '(((modify-phases) . 2))) ;different from 'modify-inputs' + ('substitute* 2) + ('substitute-keyword-arguments 2) + ('call-with-input-file 2) + ('call-with-output-file 2) + ('with-output-to-file 2) + ('with-input-from-file 2))) + +(define %newline-forms + ;; List heads that must be followed by a newline. The second argument is + ;; the context in which they must appear. This is similar to a special form + ;; of 1, except that indent is 1 instead of 2 columns. + (vhashq + ('arguments '(package)) + ('sha256 '(origin source package)) + ('base32 '(sha256 origin)) + ('git-reference '(uri origin source)) + ('search-paths '(package)) + ('native-search-paths '(package)) + ('search-path-specification '()))) + +(define (prefix? candidate lst) + "Return true if CANDIDATE is a prefix of LST." + (let loop ((candidate candidate) + (lst lst)) + (match candidate + (() #t) + ((head1 . rest1) + (match lst + (() #f) + ((head2 . rest2) + (and (equal? head1 head2) + (loop rest1 rest2)))))))) + +(define (special-form-lead symbol context) + "If SYMBOL is a special form in the given CONTEXT, return its number of +arguments; otherwise return #f. CONTEXT is a stack of symbols lexically +surrounding SYMBOL." + (match (vhash-assq symbol %special-forms) + (#f #f) + ((_ . alist) + (any (match-lambda + ((prefix . level) + (and (prefix? prefix context) (- level 1)))) + alist)))) + +(define (newline-form? symbol context) + "Return true if parenthesized expressions starting with SYMBOL must be +followed by a newline." + (match (vhash-assq symbol %newline-forms) + (#f #f) + ((_ . prefix) + (prefix? prefix context)))) + +(define (escaped-string str) + "Return STR with backslashes and double quotes escaped. Everything else, in +particular newlines, is left as is." + (list->string + `(#\" + ,@(string-fold-right (lambda (chr lst) + (match chr + (#\" (cons* #\\ #\" lst)) + (#\\ (cons* #\\ #\\ lst)) + (_ (cons chr lst)))) + '() + str) + #\"))) + +(define (string-width str) + "Return the \"width\" of STR--i.e., the width of the longest line of STR." + (apply max (map string-length (string-split str #\newline)))) + +(define (canonicalize-comment c) + "Canonicalize comment C, ensuring it has the \"right\" number of leading +semicolons." + (let ((line (string-trim-both + (string-trim (comment->string c) (char-set #\;))))) + (comment (string-append + (if (comment-margin? c) + ";" + (if (string-null? line) + ";;" ;no trailing space + ";; ")) + line "\n") + (comment-margin? c)))) + +(define* (pretty-print-with-comments port obj + #:key + (format-comment identity) + (indent 0) + (max-width 78) + (long-list 5)) + "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns +and assuming the current column is INDENT. Comments present in OBJ are +included in the output. + +Lists longer than LONG-LIST are written as one element per line. Comments are +passed through FORMAT-COMMENT before being emitted; a useful value for +FORMAT-COMMENT is 'canonicalize-comment'." + (define (list-of-lists? head tail) + ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of + ;; 'let' bindings. + (match head + ((thing _ ...) ;proper list + (and (not (memq thing + '(quote quasiquote unquote unquote-splicing))) + (pair? tail))) + (_ #f))) + + (let loop ((indent indent) + (column indent) + (delimited? #t) ;true if comes after a delimiter + (context '()) ;list of "parent" symbols + (obj obj)) + (define (print-sequence context indent column lst delimited?) + (define long? + (> (length lst) long-list)) + + (let print ((lst lst) + (first? #t) + (delimited? delimited?) + (column column)) + (match lst + (() + column) + ((item . tail) + (define newline? + ;; Insert a newline if ITEM is itself a list, or if TAIL is long, + ;; but only if ITEM is not the first item. Also insert a newline + ;; before a keyword. + (and (or (pair? item) long? + (and (keyword? item) + (not (eq? item #:allow-other-keys)))) + (not first?) (not delimited?) + (not (comment? item)))) + + (when newline? + (newline port) + (display (make-string indent #\space) port)) + (let ((column (if newline? indent column))) + (print tail + (keyword? item) ;keep #:key value next to one another + (comment? item) + (loop indent column + (or newline? delimited?) + context + item))))))) + + (define (sequence-would-protrude? indent lst) + ;; Return true if elements of LST written at INDENT would protrude + ;; beyond MAX-WIDTH. This is implemented as a cheap test with false + ;; negatives to avoid actually rendering all of LST. + (find (match-lambda + ((? string? str) + (>= (+ (string-width str) 2 indent) max-width)) + ((? symbol? symbol) + (>= (+ (string-width (symbol->string symbol)) indent) + max-width)) + ((? boolean?) + (>= (+ 2 indent) max-width)) + (() + (>= (+ 2 indent) max-width)) + (_ ;don't know + #f)) + lst)) + + (define (special-form? head) + (special-form-lead head context)) + + (match obj + ((? comment? comment) + (if (comment-margin? comment) + (begin + (display " " port) + (display (comment->string (format-comment comment)) + port)) + (begin + ;; When already at the beginning of a line, for example because + ;; COMMENT follows a margin comment, no need to emit a newline. + (unless (= column indent) + (newline port) + (display (make-string indent #\space) port)) + (display (comment->string (format-comment comment)) + port))) + (display (make-string indent #\space) port) + indent) + (('quote lst) + (unless delimited? (display " " port)) + (display "'" port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('quasiquote lst) + (unless delimited? (display " " port)) + (display "`" port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('unquote lst) + (unless delimited? (display " " port)) + (display "," port) + (loop indent (+ column (if delimited? 1 2)) #t context lst)) + (('unquote-splicing lst) + (unless delimited? (display " " port)) + (display ",@" port) + (loop indent (+ column (if delimited? 2 3)) #t context lst)) + (('gexp lst) + (unless delimited? (display " " port)) + (display "#~" port) + (loop indent (+ column (if delimited? 2 3)) #t context lst)) + (('ungexp obj) + (unless delimited? (display " " port)) + (display "#$" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + (('ungexp-native obj) + (unless delimited? (display " " port)) + (display "#+" port) + (loop indent (+ column (if delimited? 2 3)) #t context obj)) + (('ungexp-splicing lst) + (unless delimited? (display " " port)) + (display "#$@" port) + (loop indent (+ column (if delimited? 3 4)) #t context lst)) + (('ungexp-native-splicing lst) + (unless delimited? (display " " port)) + (display "#+@" port) + (loop indent (+ column (if delimited? 3 4)) #t context lst)) + (((? special-form? head) arguments ...) + ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second + ;; and following arguments are less indented. + (let* ((lead (special-form-lead head context)) + (context (cons head context)) + (head (symbol->string head)) + (total (length arguments))) + (unless delimited? (display " " port)) + (display "(" port) + (display head port) + (unless (zero? lead) + (display " " port)) + + ;; Print the first LEAD arguments. + (let* ((indent (+ column 2 + (if delimited? 0 1))) + (column (+ column 1 + (if (zero? lead) 0 1) + (if delimited? 0 1) + (string-length head))) + (initial-indent column)) + (define new-column + (let inner ((n lead) + (arguments (take arguments (min lead total))) + (column column)) + (if (zero? n) + (begin + (newline port) + (display (make-string indent #\space) port) + indent) + (match arguments + (() column) + ((head . tail) + (inner (- n 1) tail + (loop initial-indent column + (= n lead) + context + head))))))) + + ;; Print the remaining arguments. + (let ((column (print-sequence + context indent new-column + (drop arguments (min lead total)) + #t))) + (display ")" port) + (+ column 1))))) + ((head tail ...) + (let* ((overflow? (>= column max-width)) + (column (if overflow? + (+ indent 1) + (+ column (if delimited? 1 2)))) + (newline? (or (newline-form? head context) + (list-of-lists? head tail))) ;'let' bindings + (context (cons head context))) + (if overflow? + (begin + (newline port) + (display (make-string indent #\space) port)) + (unless delimited? (display " " port))) + (display "(" port) + + (let* ((new-column (loop column column #t context head)) + (indent (if (or (>= new-column max-width) + (not (symbol? head)) + (sequence-would-protrude? + (+ new-column 1) tail) + newline?) + column + (+ new-column 1)))) + (when newline? + ;; Insert a newline right after HEAD. + (newline port) + (display (make-string indent #\space) port)) + + (let ((column + (print-sequence context indent + (if newline? indent new-column) + tail newline?))) + (display ")" port) + (+ column 1))))) + (_ + (let* ((str (if (string? obj) + (escaped-string obj) + (object->string obj))) + (len (string-width str))) + (if (and (> (+ column 1 len) max-width) + (not delimited?)) + (begin + (newline port) + (display (make-string indent #\space) port) + (display str port) + (+ indent len)) + (begin + (unless delimited? (display " " port)) + (display str port) + (+ column (if delimited? 0 1) len)))))))) + +(define (object->string* obj indent . args) + "Pretty-print OBJ with INDENT columns as the initial indent. ARGS are +passed as-is to 'pretty-print-with-comments'." + (call-with-output-string + (lambda (port) + (apply pretty-print-with-comments port obj + #:indent indent + args)))) diff --git a/guix/scripts/import.scm b/guix/scripts/import.scm index 71ab4b4fed..bd3cfd2dc3 100644 --- a/guix/scripts/import.scm +++ b/guix/scripts/import.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2020, 2021 Ludovic Courtès +;;; Copyright © 2012-2014, 2020-2022 Ludovic Courtès ;;; Copyright © 2014 David Thompson ;;; Copyright © 2018 Kyle Meyer ;;; Copyright © 2019, 2022 Ricardo Wurmus @@ -25,7 +25,7 @@ (define-module (guix scripts import) #:use-module (guix ui) #:use-module (guix scripts) - #:use-module (guix scripts style) + #:use-module (guix read-print) #:use-module (guix utils) #:use-module (srfi srfi-1) #:use-module (srfi srfi-11) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 9fd652beb1..e2530e80c0 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -37,468 +37,15 @@ #:use-module (guix utils) #:use-module (guix i18n) #:use-module (guix diagnostics) + #:use-module (guix read-print) #:use-module (ice-9 control) #:use-module (ice-9 match) - #:use-module (ice-9 rdelim) - #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) #:use-module (srfi srfi-26) #:use-module (srfi srfi-34) #:use-module (srfi srfi-37) - #:export (pretty-print-with-comments - read-with-comments - canonicalize-comment - - guix-style)) - - -;;; -;;; Comment-preserving reader. -;;; - -;; A comment. -(define-record-type - (comment str margin?) - comment? - (str comment->string) - (margin? comment-margin?)) - -(define (read-with-comments port) - "Like 'read', but include objects when they're encountered." - ;; Note: Instead of implementing this functionality in 'read' proper, which - ;; is the best approach long-term, this code is a layer on top of 'read', - ;; such that we don't have to rely on a specific Guile version. - (define dot (list 'dot)) - (define (dot? x) (eq? x dot)) - - (define (reverse/dot lst) - ;; Reverse LST and make it an improper list if it contains DOT. - (let loop ((result '()) - (lst lst)) - (match lst - (() result) - (((? dot?) . rest) - (let ((dotted (reverse rest))) - (set-cdr! (last-pair dotted) (car result)) - dotted)) - ((x . rest) (loop (cons x result) rest))))) - - (let loop ((blank-line? #t) - (return (const 'unbalanced))) - (match (read-char port) - ((? eof-object? eof) - eof) ;oops! - (chr - (cond ((eqv? chr #\newline) - (loop #t return)) - ((char-set-contains? char-set:whitespace chr) - (loop blank-line? return)) - ((memv chr '(#\( #\[)) - (let/ec return - (let liip ((lst '())) - (liip (cons (loop (match lst - (((? comment?) . _) #t) - (_ #f)) - (lambda () - (return (reverse/dot lst)))) - lst))))) - ((memv chr '(#\) #\])) - (return)) - ((eq? chr #\') - (list 'quote (loop #f return))) - ((eq? chr #\`) - (list 'quasiquote (loop #f return))) - ((eq? chr #\,) - (list (match (peek-char port) - (#\@ - (read-char port) - 'unquote-splicing) - (_ - 'unquote)) - (loop #f return))) - ((eqv? chr #\;) - (unread-char chr port) - (comment (read-line port 'concat) - (not blank-line?))) - (else - (unread-char chr port) - (match (read port) - ((and token '#{.}#) - (if (eq? chr #\.) dot token)) - (token token)))))))) - -;;; -;;; Comment-preserving pretty-printer. -;;; - -(define-syntax vhashq - (syntax-rules (quote) - ((_) vlist-null) - ((_ (key (quote (lst ...))) rest ...) - (vhash-consq key '(lst ...) (vhashq rest ...))) - ((_ (key value) rest ...) - (vhash-consq key '((() . value)) (vhashq rest ...))))) - -(define %special-forms - ;; Forms that are indented specially. The number is meant to be understood - ;; like Emacs' 'scheme-indent-function' symbol property. When given an - ;; alist instead of a number, the alist gives "context" in which the symbol - ;; is a special form; for instance, context (modify-phases) means that the - ;; symbol must appear within a (modify-phases ...) expression. - (vhashq - ('begin 1) - ('lambda 2) - ('lambda* 2) - ('match-lambda 1) - ('match-lambda* 2) - ('define 2) - ('define* 2) - ('define-public 2) - ('define*-public 2) - ('define-syntax 2) - ('define-syntax-rule 2) - ('define-module 2) - ('define-gexp-compiler 2) - ('let 2) - ('let* 2) - ('letrec 2) - ('letrec* 2) - ('match 2) - ('when 2) - ('unless 2) - ('package 1) - ('origin 1) - ('operating-system 1) - ('modify-inputs 2) - ('modify-phases 2) - ('add-after '(((modify-phases) . 3))) - ('add-before '(((modify-phases) . 3))) - ('replace '(((modify-phases) . 2))) ;different from 'modify-inputs' - ('substitute* 2) - ('substitute-keyword-arguments 2) - ('call-with-input-file 2) - ('call-with-output-file 2) - ('with-output-to-file 2) - ('with-input-from-file 2))) - -(define %newline-forms - ;; List heads that must be followed by a newline. The second argument is - ;; the context in which they must appear. This is similar to a special form - ;; of 1, except that indent is 1 instead of 2 columns. - (vhashq - ('arguments '(package)) - ('sha256 '(origin source package)) - ('base32 '(sha256 origin)) - ('git-reference '(uri origin source)) - ('search-paths '(package)) - ('native-search-paths '(package)) - ('search-path-specification '()))) - -(define (prefix? candidate lst) - "Return true if CANDIDATE is a prefix of LST." - (let loop ((candidate candidate) - (lst lst)) - (match candidate - (() #t) - ((head1 . rest1) - (match lst - (() #f) - ((head2 . rest2) - (and (equal? head1 head2) - (loop rest1 rest2)))))))) - -(define (special-form-lead symbol context) - "If SYMBOL is a special form in the given CONTEXT, return its number of -arguments; otherwise return #f. CONTEXT is a stack of symbols lexically -surrounding SYMBOL." - (match (vhash-assq symbol %special-forms) - (#f #f) - ((_ . alist) - (any (match-lambda - ((prefix . level) - (and (prefix? prefix context) (- level 1)))) - alist)))) - -(define (newline-form? symbol context) - "Return true if parenthesized expressions starting with SYMBOL must be -followed by a newline." - (match (vhash-assq symbol %newline-forms) - (#f #f) - ((_ . prefix) - (prefix? prefix context)))) - -(define (escaped-string str) - "Return STR with backslashes and double quotes escaped. Everything else, in -particular newlines, is left as is." - (list->string - `(#\" - ,@(string-fold-right (lambda (chr lst) - (match chr - (#\" (cons* #\\ #\" lst)) - (#\\ (cons* #\\ #\\ lst)) - (_ (cons chr lst)))) - '() - str) - #\"))) - -(define (string-width str) - "Return the \"width\" of STR--i.e., the width of the longest line of STR." - (apply max (map string-length (string-split str #\newline)))) - -(define (canonicalize-comment c) - "Canonicalize comment C, ensuring it has the \"right\" number of leading -semicolons." - (let ((line (string-trim-both - (string-trim (comment->string c) (char-set #\;))))) - (comment (string-append - (if (comment-margin? c) - ";" - (if (string-null? line) - ";;" ;no trailing space - ";; ")) - line "\n") - (comment-margin? c)))) - -(define* (pretty-print-with-comments port obj - #:key - (format-comment identity) - (indent 0) - (max-width 78) - (long-list 5)) - "Pretty-print OBJ to PORT, attempting to at most MAX-WIDTH character columns -and assuming the current column is INDENT. Comments present in OBJ are -included in the output. - -Lists longer than LONG-LIST are written as one element per line. Comments are -passed through FORMAT-COMMENT before being emitted; a useful value for -FORMAT-COMMENT is 'canonicalize-comment'." - (define (list-of-lists? head tail) - ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of - ;; 'let' bindings. - (match head - ((thing _ ...) ;proper list - (and (not (memq thing - '(quote quasiquote unquote unquote-splicing))) - (pair? tail))) - (_ #f))) - - (let loop ((indent indent) - (column indent) - (delimited? #t) ;true if comes after a delimiter - (context '()) ;list of "parent" symbols - (obj obj)) - (define (print-sequence context indent column lst delimited?) - (define long? - (> (length lst) long-list)) - - (let print ((lst lst) - (first? #t) - (delimited? delimited?) - (column column)) - (match lst - (() - column) - ((item . tail) - (define newline? - ;; Insert a newline if ITEM is itself a list, or if TAIL is long, - ;; but only if ITEM is not the first item. Also insert a newline - ;; before a keyword. - (and (or (pair? item) long? - (and (keyword? item) - (not (eq? item #:allow-other-keys)))) - (not first?) (not delimited?) - (not (comment? item)))) - - (when newline? - (newline port) - (display (make-string indent #\space) port)) - (let ((column (if newline? indent column))) - (print tail - (keyword? item) ;keep #:key value next to one another - (comment? item) - (loop indent column - (or newline? delimited?) - context - item))))))) - - (define (sequence-would-protrude? indent lst) - ;; Return true if elements of LST written at INDENT would protrude - ;; beyond MAX-WIDTH. This is implemented as a cheap test with false - ;; negatives to avoid actually rendering all of LST. - (find (match-lambda - ((? string? str) - (>= (+ (string-width str) 2 indent) max-width)) - ((? symbol? symbol) - (>= (+ (string-width (symbol->string symbol)) indent) - max-width)) - ((? boolean?) - (>= (+ 2 indent) max-width)) - (() - (>= (+ 2 indent) max-width)) - (_ ;don't know - #f)) - lst)) - - (define (special-form? head) - (special-form-lead head context)) - - (match obj - ((? comment? comment) - (if (comment-margin? comment) - (begin - (display " " port) - (display (comment->string (format-comment comment)) - port)) - (begin - ;; When already at the beginning of a line, for example because - ;; COMMENT follows a margin comment, no need to emit a newline. - (unless (= column indent) - (newline port) - (display (make-string indent #\space) port)) - (display (comment->string (format-comment comment)) - port))) - (display (make-string indent #\space) port) - indent) - (('quote lst) - (unless delimited? (display " " port)) - (display "'" port) - (loop indent (+ column (if delimited? 1 2)) #t context lst)) - (('quasiquote lst) - (unless delimited? (display " " port)) - (display "`" port) - (loop indent (+ column (if delimited? 1 2)) #t context lst)) - (('unquote lst) - (unless delimited? (display " " port)) - (display "," port) - (loop indent (+ column (if delimited? 1 2)) #t context lst)) - (('unquote-splicing lst) - (unless delimited? (display " " port)) - (display ",@" port) - (loop indent (+ column (if delimited? 2 3)) #t context lst)) - (('gexp lst) - (unless delimited? (display " " port)) - (display "#~" port) - (loop indent (+ column (if delimited? 2 3)) #t context lst)) - (('ungexp obj) - (unless delimited? (display " " port)) - (display "#$" port) - (loop indent (+ column (if delimited? 2 3)) #t context obj)) - (('ungexp-native obj) - (unless delimited? (display " " port)) - (display "#+" port) - (loop indent (+ column (if delimited? 2 3)) #t context obj)) - (('ungexp-splicing lst) - (unless delimited? (display " " port)) - (display "#$@" port) - (loop indent (+ column (if delimited? 3 4)) #t context lst)) - (('ungexp-native-splicing lst) - (unless delimited? (display " " port)) - (display "#+@" port) - (loop indent (+ column (if delimited? 3 4)) #t context lst)) - (((? special-form? head) arguments ...) - ;; Special-case 'let', 'lambda', 'modify-inputs', etc. so the second - ;; and following arguments are less indented. - (let* ((lead (special-form-lead head context)) - (context (cons head context)) - (head (symbol->string head)) - (total (length arguments))) - (unless delimited? (display " " port)) - (display "(" port) - (display head port) - (unless (zero? lead) - (display " " port)) - - ;; Print the first LEAD arguments. - (let* ((indent (+ column 2 - (if delimited? 0 1))) - (column (+ column 1 - (if (zero? lead) 0 1) - (if delimited? 0 1) - (string-length head))) - (initial-indent column)) - (define new-column - (let inner ((n lead) - (arguments (take arguments (min lead total))) - (column column)) - (if (zero? n) - (begin - (newline port) - (display (make-string indent #\space) port) - indent) - (match arguments - (() column) - ((head . tail) - (inner (- n 1) tail - (loop initial-indent column - (= n lead) - context - head))))))) - - ;; Print the remaining arguments. - (let ((column (print-sequence - context indent new-column - (drop arguments (min lead total)) - #t))) - (display ")" port) - (+ column 1))))) - ((head tail ...) - (let* ((overflow? (>= column max-width)) - (column (if overflow? - (+ indent 1) - (+ column (if delimited? 1 2)))) - (newline? (or (newline-form? head context) - (list-of-lists? head tail))) ;'let' bindings - (context (cons head context))) - (if overflow? - (begin - (newline port) - (display (make-string indent #\space) port)) - (unless delimited? (display " " port))) - (display "(" port) - - (let* ((new-column (loop column column #t context head)) - (indent (if (or (>= new-column max-width) - (not (symbol? head)) - (sequence-would-protrude? - (+ new-column 1) tail) - newline?) - column - (+ new-column 1)))) - (when newline? - ;; Insert a newline right after HEAD. - (newline port) - (display (make-string indent #\space) port)) - - (let ((column - (print-sequence context indent - (if newline? indent new-column) - tail newline?))) - (display ")" port) - (+ column 1))))) - (_ - (let* ((str (if (string? obj) - (escaped-string obj) - (object->string obj))) - (len (string-width str))) - (if (and (> (+ column 1 len) max-width) - (not delimited?)) - (begin - (newline port) - (display (make-string indent #\space) port) - (display str port) - (+ indent len)) - (begin - (unless delimited? (display " " port)) - (display str port) - (+ column (if delimited? 0 1) len)))))))) - -(define (object->string* obj indent . args) - (call-with-output-string - (lambda (port) - (apply pretty-print-with-comments port obj - #:indent indent - args)))) + #:export (guix-style)) ;;; diff --git a/tests/read-print.scm b/tests/read-print.scm new file mode 100644 index 0000000000..e9ba1127d4 --- /dev/null +++ b/tests/read-print.scm @@ -0,0 +1,209 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2021-2022 Ludovic Courtès +;;; +;;; 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 . + +(define-module (tests-style) + #:use-module (guix read-print) + #:use-module (guix gexp) ;for the reader extensions + #:use-module (srfi srfi-64)) + +(define-syntax-rule (test-pretty-print str args ...) + "Test equality after a round-trip where STR is passed to +'read-with-comments' and the resulting sexp is then passed to +'pretty-print-with-comments'." + (test-equal str + (call-with-output-string + (lambda (port) + (let ((exp (call-with-input-string str + read-with-comments))) + (pretty-print-with-comments port exp args ...)))))) + + +(test-begin "read-print") + +(test-equal "read-with-comments: dot notation" + (cons 'a 'b) + (call-with-input-string "(a . b)" + read-with-comments)) + +(test-pretty-print "(list 1 2 3 4)") +(test-pretty-print "((a . 1) (b . 2))") +(test-pretty-print "(a b c . boom)") +(test-pretty-print "(list 1 + 2 + 3 + 4)" + #:long-list 3 + #:indent 20) +(test-pretty-print "\ +(list abc + def)" + #:max-width 11) +(test-pretty-print "\ +(#:foo + #:bar)" + #:max-width 10) + +(test-pretty-print "\ +(#:first 1 + #:second 2 + #:third 3)") + +(test-pretty-print "\ +((x + 1) + (y + 2) + (z + 3))" + #:max-width 3) + +(test-pretty-print "\ +(let ((x 1) + (y 2) + (z 3) + (p 4)) + (+ x y))" + #:max-width 11) + +(test-pretty-print "\ +(lambda (x y) + ;; This is a procedure. + (let ((z (+ x y))) + (* z z)))") + +(test-pretty-print "\ +#~(string-append #$coreutils \"/bin/uname\")") + +(test-pretty-print "\ +(package + (inherit coreutils) + (version \"42\"))") + +(test-pretty-print "\ +(modify-phases %standard-phases + (add-after 'unpack 'post-unpack + (lambda _ + #t)) + (add-before 'check 'pre-check + (lambda* (#:key inputs #:allow-other-keys) + do things ...)))") + +(test-pretty-print "\ +(#:phases (modify-phases sdfsdf + (add-before 'x 'y + (lambda _ + xyz))))") + +(test-pretty-print "\ +(description \"abcdefghijkl +mnopqrstuvwxyz.\")" + #:max-width 30) + +(test-pretty-print "\ +(description + \"abcdefghijkl +mnopqrstuvwxyz.\")" + #:max-width 12) + +(test-pretty-print "\ +(description + \"abcdefghijklmnopqrstuvwxyz\")" + #:max-width 33) + +(test-pretty-print "\ +(modify-phases %standard-phases + (replace 'build + ;; Nicely indented in 'modify-phases' context. + (lambda _ + #t)))") + +(test-pretty-print "\ +(modify-inputs inputs + ;; Regular indentation for 'replace' here. + (replace \"gmp\" gmp))") + +(test-pretty-print "\ +(package + ;; Here 'sha256', 'base32', and 'arguments' must be + ;; immediately followed by a newline. + (source (origin + (method url-fetch) + (sha256 + (base32 + \"not a real base32 string\")))) + (arguments + '(#:phases %standard-phases + #:tests? #f)))") + +;; '#:key value' is kept on the same line. +(test-pretty-print "\ +(package + (name \"keyword-value-same-line\") + (arguments + (list #:phases #~(modify-phases %standard-phases + (add-before 'x 'y + (lambda* (#:key inputs #:allow-other-keys) + (foo bar baz)))) + #:make-flags #~'(\"ANSWER=42\") + #:tests? #f)))") + +(test-pretty-print "\ +(let ((x 1) + (y 2) + (z (let* ((a 3) + (b 4)) + (+ a b)))) + (list x y z))") + +(test-pretty-print "\ +(substitute-keyword-arguments (package-arguments x) + ((#:phases phases) + `(modify-phases ,phases + (add-before 'build 'do-things + (lambda _ + #t)))) + ((#:configure-flags flags) + `(cons \"--without-any-problem\" + ,flags)))") + +(test-equal "pretty-print-with-comments, canonicalize-comment" + "\ +(list abc + ;; Not a margin comment. + ;; Ditto. + ;; + ;; There's a blank line above. + def ;margin comment + ghi)" + (let ((sexp (call-with-input-string + "\ +(list abc + ;Not a margin comment. + ;;; Ditto. + ;;;;; + ; There's a blank line above. + def ;; margin comment + ghi)" + read-with-comments))) + (call-with-output-string + (lambda (port) + (pretty-print-with-comments port sexp + #:format-comment + canonicalize-comment))))) + +(test-end) diff --git a/tests/style.scm b/tests/style.scm index 55bad2b3ba..4ac5ae7c09 100644 --- a/tests/style.scm +++ b/tests/style.scm @@ -113,17 +113,6 @@ (lambda (port) (read-lines port line count))))) -(define-syntax-rule (test-pretty-print str args ...) - "Test equality after a round-trip where STR is passed to -'read-with-comments' and the resulting sexp is then passed to -'pretty-print-with-comments'." - (test-equal str - (call-with-output-string - (lambda (port) - (let ((exp (call-with-input-string str - read-with-comments))) - (pretty-print-with-comments port exp args ...)))))) - (test-begin "style") @@ -377,176 +366,6 @@ (list (package-inputs (@ (my-packages) my-coreutils)) (read-package-field (@ (my-packages) my-coreutils) 'inputs 4))))) -(test-equal "read-with-comments: dot notation" - (cons 'a 'b) - (call-with-input-string "(a . b)" - read-with-comments)) - -(test-pretty-print "(list 1 2 3 4)") -(test-pretty-print "((a . 1) (b . 2))") -(test-pretty-print "(a b c . boom)") -(test-pretty-print "(list 1 - 2 - 3 - 4)" - #:long-list 3 - #:indent 20) -(test-pretty-print "\ -(list abc - def)" - #:max-width 11) -(test-pretty-print "\ -(#:foo - #:bar)" - #:max-width 10) - -(test-pretty-print "\ -(#:first 1 - #:second 2 - #:third 3)") - -(test-pretty-print "\ -((x - 1) - (y - 2) - (z - 3))" - #:max-width 3) - -(test-pretty-print "\ -(let ((x 1) - (y 2) - (z 3) - (p 4)) - (+ x y))" - #:max-width 11) - -(test-pretty-print "\ -(lambda (x y) - ;; This is a procedure. - (let ((z (+ x y))) - (* z z)))") - -(test-pretty-print "\ -#~(string-append #$coreutils \"/bin/uname\")") - -(test-pretty-print "\ -(package - (inherit coreutils) - (version \"42\"))") - -(test-pretty-print "\ -(modify-phases %standard-phases - (add-after 'unpack 'post-unpack - (lambda _ - #t)) - (add-before 'check 'pre-check - (lambda* (#:key inputs #:allow-other-keys) - do things ...)))") - -(test-pretty-print "\ -(#:phases (modify-phases sdfsdf - (add-before 'x 'y - (lambda _ - xyz))))") - -(test-pretty-print "\ -(description \"abcdefghijkl -mnopqrstuvwxyz.\")" - #:max-width 30) - -(test-pretty-print "\ -(description - \"abcdefghijkl -mnopqrstuvwxyz.\")" - #:max-width 12) - -(test-pretty-print "\ -(description - \"abcdefghijklmnopqrstuvwxyz\")" - #:max-width 33) - -(test-pretty-print "\ -(modify-phases %standard-phases - (replace 'build - ;; Nicely indented in 'modify-phases' context. - (lambda _ - #t)))") - -(test-pretty-print "\ -(modify-inputs inputs - ;; Regular indentation for 'replace' here. - (replace \"gmp\" gmp))") - -(test-pretty-print "\ -(package - ;; Here 'sha256', 'base32', and 'arguments' must be - ;; immediately followed by a newline. - (source (origin - (method url-fetch) - (sha256 - (base32 - \"not a real base32 string\")))) - (arguments - '(#:phases %standard-phases - #:tests? #f)))") - -;; '#:key value' is kept on the same line. -(test-pretty-print "\ -(package - (name \"keyword-value-same-line\") - (arguments - (list #:phases #~(modify-phases %standard-phases - (add-before 'x 'y - (lambda* (#:key inputs #:allow-other-keys) - (foo bar baz)))) - #:make-flags #~'(\"ANSWER=42\") - #:tests? #f)))") - -(test-pretty-print "\ -(let ((x 1) - (y 2) - (z (let* ((a 3) - (b 4)) - (+ a b)))) - (list x y z))") - -(test-pretty-print "\ -(substitute-keyword-arguments (package-arguments x) - ((#:phases phases) - `(modify-phases ,phases - (add-before 'build 'do-things - (lambda _ - #t)))) - ((#:configure-flags flags) - `(cons \"--without-any-problem\" - ,flags)))") - -(test-equal "pretty-print-with-comments, canonicalize-comment" - "\ -(list abc - ;; Not a margin comment. - ;; Ditto. - ;; - ;; There's a blank line above. - def ;margin comment - ghi)" - (let ((sexp (call-with-input-string - "\ -(list abc - ;Not a margin comment. - ;;; Ditto. - ;;;;; - ; There's a blank line above. - def ;; margin comment - ghi)" - read-with-comments))) - (call-with-output-string - (lambda (port) - (pretty-print-with-comments port sexp - #:format-comment - canonicalize-comment))))) (test-end) -- cgit v1.2.3 From 632d4ccc0bcb9d73226edeb32264c74fc50867ab Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 21 Jul 2022 18:19:10 +0200 Subject: read-print: Add System and Home special forms. * guix/read-print.scm (%special-forms): Add System and Home forms. (%newline-forms): Add 'services'. --- guix/read-print.scm | 24 +++++++++++++++++++++--- 1 file changed, 21 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 69ab8ac8b3..949a713ca2 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -156,7 +156,6 @@ ('unless 2) ('package 1) ('origin 1) - ('operating-system 1) ('modify-inputs 2) ('modify-phases 2) ('add-after '(((modify-phases) . 3))) @@ -167,7 +166,22 @@ ('call-with-input-file 2) ('call-with-output-file 2) ('with-output-to-file 2) - ('with-input-from-file 2))) + ('with-input-from-file 2) + ('with-directory-excursion 2) + + ;; (gnu system) and (gnu services). + ('operating-system 1) + ('bootloader-configuration 1) + ('mapped-device 1) + ('file-system 1) + ('swap-space 1) + ('user-account 1) + ('user-group 1) + ('setuid-program 1) + ('modify-services 2) + + ;; (gnu home). + ('home-environment 1))) (define %newline-forms ;; List heads that must be followed by a newline. The second argument is @@ -180,7 +194,11 @@ ('git-reference '(uri origin source)) ('search-paths '(package)) ('native-search-paths '(package)) - ('search-path-specification '()))) + ('search-path-specification '()) + + ('services '(operating-system)) + ('set-xorg-configuration '()) + ('services '(home-environment)))) (define (prefix? candidate lst) "Return true if CANDIDATE is a prefix of LST." -- cgit v1.2.3 From 38f1fb843cb3b538bf042a3baed99618953a005f Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 Aug 2022 17:42:11 +0200 Subject: read-print: Expose comment constructor. * guix/read-print.scm (): Rename constructor to 'string->comment'. (comment): New procedure. (read-with-comments, canonicalize-comment): Use 'string->comment' instead of 'comment'. --- guix/read-print.scm | 36 +++++++++++++++++++++++++----------- 1 file changed, 25 insertions(+), 11 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 949a713ca2..5281878504 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -23,10 +23,13 @@ #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) #:use-module (srfi srfi-9) + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:export (pretty-print-with-comments read-with-comments object->string* + comment comment? comment->string comment-margin? @@ -46,11 +49,22 @@ ;; A comment. (define-record-type - (comment str margin?) + (string->comment str margin?) comment? (str comment->string) (margin? comment-margin?)) +(define* (comment str #:optional margin?) + "Return a new comment made from STR. When MARGIN? is true, return a margin +comment; otherwise return a line comment. STR must start with a semicolon and +end with newline, otherwise an error is raised." + (when (or (string-null? str) + (not (eqv? #\; (string-ref str 0))) + (not (string-suffix? "\n" str))) + (raise (condition + (&message (message "invalid comment string"))))) + (string->comment str margin?)) + (define (read-with-comments port) "Like 'read', but include objects when they're encountered." ;; Note: Instead of implementing this functionality in 'read' proper, which @@ -106,8 +120,8 @@ (loop #f return))) ((eqv? chr #\;) (unread-char chr port) - (comment (read-line port 'concat) - (not blank-line?))) + (string->comment (read-line port 'concat) + (not blank-line?))) (else (unread-char chr port) (match (read port) @@ -256,14 +270,14 @@ particular newlines, is left as is." semicolons." (let ((line (string-trim-both (string-trim (comment->string c) (char-set #\;))))) - (comment (string-append - (if (comment-margin? c) - ";" - (if (string-null? line) - ";;" ;no trailing space - ";; ")) - line "\n") - (comment-margin? c)))) + (string->comment (string-append + (if (comment-margin? c) + ";" + (if (string-null? line) + ";;" ;no trailing space + ";; ")) + line "\n") + (comment-margin? c)))) (define* (pretty-print-with-comments port obj #:key -- cgit v1.2.3 From 5b273e7c777cc975d398df9f9a6847b935cb5e86 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 1 Aug 2022 22:35:10 +0200 Subject: read-print: Introduce parent class of . * guix/read-print.scm (, blank?): New record type. (): Redefine using the record interface. (read-with-comments, pretty-print-with-comments): Change some uses of 'comment?' to 'blank?'. * guix/scripts/style.scm (simplify-inputs)[simplify-expressions]: Use 'blank?' instead of 'comment?'. --- guix/read-print.scm | 37 ++++++++++++++++++++++++++----------- guix/scripts/style.scm | 2 +- 2 files changed, 27 insertions(+), 12 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 5281878504..732d0dc1f8 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -22,13 +22,14 @@ #:use-module (ice-9 rdelim) #:use-module (ice-9 vlist) #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (pretty-print-with-comments read-with-comments object->string* + blank? + comment comment? comment->string @@ -47,12 +48,26 @@ ;;; Comment-preserving reader. ;;; -;; A comment. -(define-record-type - (string->comment str margin?) - comment? - (str comment->string) - (margin? comment-margin?)) +(define + ;; The parent class for "blanks". + (make-record-type ' '() + (lambda (obj port) + (format port "#" + (number->string (object-address obj) 16))) + #:extensible? #t)) + +(define blank? (record-predicate )) + +(define + ;; Comments. + (make-record-type ' '(str margin?) + #:parent + #:extensible? #f)) + +(define comment? (record-predicate )) +(define string->comment (record-type-constructor )) +(define comment->string (record-accessor 'str)) +(define comment-margin? (record-accessor 'margin?)) (define* (comment str #:optional margin?) "Return a new comment made from STR. When MARGIN? is true, return a margin @@ -66,7 +81,7 @@ end with newline, otherwise an error is raised." (string->comment str margin?)) (define (read-with-comments port) - "Like 'read', but include objects when they're encountered." + "Like 'read', but include objects when they're encountered." ;; Note: Instead of implementing this functionality in 'read' proper, which ;; is the best approach long-term, this code is a layer on top of 'read', ;; such that we don't have to rely on a specific Guile version. @@ -99,7 +114,7 @@ end with newline, otherwise an error is raised." (let/ec return (let liip ((lst '())) (liip (cons (loop (match lst - (((? comment?) . _) #t) + (((? blank?) . _) #t) (_ #f)) (lambda () (return (reverse/dot lst)))) @@ -327,7 +342,7 @@ FORMAT-COMMENT is 'canonicalize-comment'." (and (keyword? item) (not (eq? item #:allow-other-keys)))) (not first?) (not delimited?) - (not (comment? item)))) + (not (blank? item)))) (when newline? (newline port) @@ -335,7 +350,7 @@ FORMAT-COMMENT is 'canonicalize-comment'." (let ((column (if newline? indent column))) (print tail (keyword? item) ;keep #:key value next to one another - (comment? item) + (blank? item) (loop indent column (or newline? delimited?) context diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index e2530e80c0..5c0ecc0896 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -108,7 +108,7 @@ bailing out~%") (exp exp) (inputs inputs)) (match exp - (((? comment? head) . rest) + (((? blank? head) . rest) (loop (cons head result) rest inputs)) ((head . rest) (match inputs -- cgit v1.2.3 From f687e27e0385c7f9bab8d967293061158fc3f504 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Aug 2022 11:57:39 +0200 Subject: read-print: Read and render vertical space. * guix/read-print.scm (, vertical-space?) (vertical-space, vertical-space-height): New variables. (combine-vertical-space, canonicalize-vertical-space) (read-vertical-space): New procedures. (read-with-comments): Use it in the #\newline case. (pretty-print-with-comments): Add #:format-vertical-space and honor it. Add case for 'vertical-space?'. * guix/scripts/style.scm (format-package-definition): Pass #:format-vertical-space to 'object->string*'. * tests/read-print.scm ("read-with-comments: list with blank line") ("read-with-comments: list with multiple blank lines") ("read-with-comments: top-level blank lines") ("pretty-print-with-comments, canonicalize-vertical-space"): New tests. Add a couple of additional round-trip tests. --- guix/read-print.scm | 54 +++++++++++++++++++++++++++++++++-- guix/scripts/style.scm | 3 +- tests/read-print.scm | 76 +++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 129 insertions(+), 4 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 732d0dc1f8..2b626ba281 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -30,6 +30,11 @@ blank? + vertical-space + vertical-space? + vertical-space-height + canonicalize-vertical-space + comment comment? comment->string @@ -58,6 +63,26 @@ (define blank? (record-predicate )) +(define + (make-record-type ' '(height) + #:parent + #:extensible? #f)) + +(define vertical-space? (record-predicate )) +(define vertical-space (record-type-constructor )) +(define vertical-space-height (record-accessor 'height)) + +(define (combine-vertical-space x y) + "Return vertical space as high as the combination of X and Y." + (vertical-space (+ (vertical-space-height x) + (vertical-space-height y)))) + +(define canonicalize-vertical-space + (let ((unit (vertical-space 1))) + (lambda (space) + "Return a vertical space corresponding to a single blank line." + unit))) + (define ;; Comments. (make-record-type ' '(str margin?) @@ -80,6 +105,19 @@ end with newline, otherwise an error is raised." (&message (message "invalid comment string"))))) (string->comment str margin?)) +(define (read-vertical-space port) + "Read from PORT until a non-vertical-space character is met, and return a +single record." + (define (space? chr) + (char-set-contains? char-set:whitespace chr)) + + (let loop ((height 1)) + (match (read-char port) + (#\newline (loop (+ 1 height))) + ((? eof-object?) (vertical-space height)) + ((? space?) (loop height)) + (chr (unread-char chr port) (vertical-space height))))) + (define (read-with-comments port) "Like 'read', but include objects when they're encountered." ;; Note: Instead of implementing this functionality in 'read' proper, which @@ -107,7 +145,9 @@ end with newline, otherwise an error is raised." eof) ;oops! (chr (cond ((eqv? chr #\newline) - (loop #t return)) + (if blank-line? + (read-vertical-space port) + (loop #t return))) ((char-set-contains? char-set:whitespace chr) (loop blank-line? return)) ((memv chr '(#\( #\[)) @@ -297,6 +337,7 @@ semicolons." (define* (pretty-print-with-comments port obj #:key (format-comment identity) + (format-vertical-space identity) (indent 0) (max-width 78) (long-list 5)) @@ -306,7 +347,8 @@ included in the output. Lists longer than LONG-LIST are written as one element per line. Comments are passed through FORMAT-COMMENT before being emitted; a useful value for -FORMAT-COMMENT is 'canonicalize-comment'." +FORMAT-COMMENT is 'canonicalize-comment'. Vertical space is passed through +FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (define (list-of-lists? head tail) ;; Return true if HEAD and TAIL denote a list of lists--e.g., a list of ;; 'let' bindings. @@ -394,6 +436,14 @@ FORMAT-COMMENT is 'canonicalize-comment'." port))) (display (make-string indent #\space) port) indent) + ((? vertical-space? space) + (unless delimited? (newline port)) + (let loop ((i (vertical-space-height (format-vertical-space space)))) + (unless (zero? i) + (newline port) + (loop (- i 1)))) + (display (make-string indent #\space) port) + indent) (('quote lst) (unless delimited? (display " " port)) (display "'" port) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 5c0ecc0896..2e14bc68fd 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -316,7 +316,8 @@ PACKAGE." (object->string* exp (location-column (package-definition-location package)) - #:format-comment canonicalize-comment))))) + #:format-comment canonicalize-comment + #:format-vertical-space canonicalize-vertical-space))))) (define (package-location Date: Tue, 2 Aug 2022 15:29:55 +0200 Subject: read-print: Recognize page breaks. * guix/read-print.scm (, page-break?, page-break) (char-set:whitespace-sans-page-break): New variables. (space?): New procedure. (read-vertical-space): Use it. (read-until-end-of-line): New procedure. (read-with-comments): Add #\page case. (pretty-print-with-comments): Add 'page-break?' case. * tests/read-print.scm ("read-with-comments: top-level page break"): New test. Add round-trip test with page break within an sexp. --- guix/read-print.scm | 46 +++++++++++++++++++++++++++++++++++++++++++--- tests/read-print.scm | 22 ++++++++++++++++++++++ 2 files changed, 65 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 2b626ba281..33ed6e3dbe 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -35,6 +35,9 @@ vertical-space-height canonicalize-vertical-space + page-break + page-break? + comment comment? comment->string @@ -83,6 +86,18 @@ "Return a vertical space corresponding to a single blank line." unit))) +(define + (make-record-type ' '() + #:parent + #:extensible? #f)) + +(define page-break? (record-predicate )) +(define page-break + (let ((break ((record-type-constructor )))) + (lambda () + break))) + + (define ;; Comments. (make-record-type ' '(str margin?) @@ -105,12 +120,17 @@ end with newline, otherwise an error is raised." (&message (message "invalid comment string"))))) (string->comment str margin?)) +(define char-set:whitespace-sans-page-break + ;; White space, excluding #\page. + (char-set-difference char-set:whitespace (char-set #\page))) + +(define (space? chr) + "Return true if CHR is white space, except for page breaks." + (char-set-contains? char-set:whitespace-sans-page-break chr)) + (define (read-vertical-space port) "Read from PORT until a non-vertical-space character is met, and return a single record." - (define (space? chr) - (char-set-contains? char-set:whitespace chr)) - (let loop ((height 1)) (match (read-char port) (#\newline (loop (+ 1 height))) @@ -118,6 +138,15 @@ single record." ((? space?) (loop height)) (chr (unread-char chr port) (vertical-space height))))) +(define (read-until-end-of-line port) + "Read white space from PORT until the end of line, included." + (let loop () + (match (read-char port) + (#\newline #t) + ((? eof-object?) #t) + ((? space?) (loop)) + (chr (unread-char chr port))))) + (define (read-with-comments port) "Like 'read', but include objects when they're encountered." ;; Note: Instead of implementing this functionality in 'read' proper, which @@ -148,6 +177,11 @@ single record." (if blank-line? (read-vertical-space port) (loop #t return))) + ((eqv? chr #\page) + ;; Assume that a page break is on a line of its own and read + ;; subsequent white space and newline. + (read-until-end-of-line port) + (page-break)) ((char-set-contains? char-set:whitespace chr) (loop blank-line? return)) ((memv chr '(#\( #\[)) @@ -444,6 +478,12 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (loop (- i 1)))) (display (make-string indent #\space) port) indent) + ((? page-break?) + (unless delimited? (newline port)) + (display #\page port) + (newline port) + (display (make-string indent #\space) port) + indent) (('quote lst) (unless delimited? (display " " port)) (display "'" port) diff --git a/tests/read-print.scm b/tests/read-print.scm index f915b7e2d2..70be7754f8 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -70,6 +70,21 @@ (read-with-comments port) (read-with-comments port))))) +(test-equal "read-with-comments: top-level page break" + (list (comment ";; Begin.\n") (vertical-space 1) + (page-break) + (comment ";; End.\n")) + (call-with-input-string "\ +;; Begin. + + +;; End.\n" + (lambda (port) + (list (read-with-comments port) + (read-with-comments port) + (read-with-comments port) + (read-with-comments port))))) + (test-pretty-print "(list 1 2 3 4)") (test-pretty-print "((a . 1) (b . 2))") (test-pretty-print "(a b c . boom)") @@ -229,6 +244,13 @@ mnopqrstuvwxyz.\")" ;; Comment after blank line. two)") +(test-pretty-print "\ +(begin + break + + ;; page break above + end)") + (test-equal "pretty-print-with-comments, canonicalize-comment" "\ (list abc -- cgit v1.2.3 From 9b00c97de41165beefe3eff936470f8e081ca600 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Aug 2022 17:08:53 +0200 Subject: read-print: Add code to read and write sequences of expressions/blanks. * guix/read-print.scm (read-with-comments): Add #:blank-line? and honor it. (read-with-comments/sequence, pretty-print-with-comments/splice): New procedures. * tests/read-print.scm (test-pretty-print/sequence): New macro. Add tests using it. --- guix/read-print.scm | 32 +++++++++++++++++++++++++++++--- tests/read-print.scm | 37 +++++++++++++++++++++++++++++++++++++ 2 files changed, 66 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 33ed6e3dbe..4a3afdd4f9 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -25,7 +25,9 @@ #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) #:export (pretty-print-with-comments + pretty-print-with-comments/splice read-with-comments + read-with-comments/sequence object->string* blank? @@ -147,8 +149,9 @@ single record." ((? space?) (loop)) (chr (unread-char chr port))))) -(define (read-with-comments port) - "Like 'read', but include objects when they're encountered." +(define* (read-with-comments port #:key (blank-line? #t)) + "Like 'read', but include objects when they're encountered. When +BLANK-LINE? is true, assume PORT is at the beginning of a new line." ;; Note: Instead of implementing this functionality in 'read' proper, which ;; is the best approach long-term, this code is a layer on top of 'read', ;; such that we don't have to rely on a specific Guile version. @@ -167,7 +170,7 @@ single record." dotted)) ((x . rest) (loop (cons x result) rest))))) - (let loop ((blank-line? #t) + (let loop ((blank-line? blank-line?) (return (const 'unbalanced))) (match (read-char port) ((? eof-object? eof) @@ -217,6 +220,20 @@ single record." ((and token '#{.}#) (if (eq? chr #\.) dot token)) (token token)))))))) + +(define (read-with-comments/sequence port) + "Read from PORT until the end-of-file is reached and return the list of +expressions and blanks that were read." + (let loop ((lst '()) + (blank-line? #t)) + (match (read-with-comments port #:blank-line? blank-line?) + ((? eof-object?) + (reverse! lst)) + ((? blank? blank) + (loop (cons blank lst) #t)) + (exp + (loop (cons exp lst) #f))))) + ;;; ;;; Comment-preserving pretty-printer. @@ -625,3 +642,12 @@ passed as-is to 'pretty-print-with-comments'." (apply pretty-print-with-comments port obj #:indent indent args)))) + +(define* (pretty-print-with-comments/splice port lst + #:rest rest) + "Write to PORT the expressions and blanks listed in LST." + (for-each (lambda (exp) + (apply pretty-print-with-comments port exp rest) + (unless (blank? exp) + (newline port))) + lst)) diff --git a/tests/read-print.scm b/tests/read-print.scm index 70be7754f8..94f018dd44 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -33,6 +33,16 @@ read-with-comments))) (pretty-print-with-comments port exp args ...)))))) +(define-syntax-rule (test-pretty-print/sequence str args ...) + "Likewise, but read and print entire sequences rather than individual +expressions." + (test-equal str + (call-with-output-string + (lambda (port) + (let ((lst (call-with-input-string str + read-with-comments/sequence))) + (pretty-print-with-comments/splice port lst args ...)))))) + (test-begin "read-print") @@ -251,6 +261,33 @@ mnopqrstuvwxyz.\")" ;; page break above end)") +(test-pretty-print/sequence "\ +;;; This is a top-level comment. + + +;; Above is a page break. +(this is an sexp + ;; with a comment + !!) + +;; The end.\n") + +(test-pretty-print/sequence " +;;; Hello! + +(define-module (foo bar) + #:use-module (guix) + #:use-module (gnu)) + + +;; And now, the OS. +(operating-system + (host-name \"komputilo\") + (locale \"eo_EO.UTF-8\") + + (services + (cons (service mcron-service-type) %base-services)))\n") + (test-equal "pretty-print-with-comments, canonicalize-comment" "\ (list abc -- cgit v1.2.3 From 90ef692e9b48732ae2e3921ff5d101e186506a85 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Aug 2022 17:39:55 +0200 Subject: read-print: 'canonicalize-comment' leaves top-level comments unchanged. This lets users use three leading semicolons, for instance, in top-level comments. * guix/read-print.scm (canonicalize-comment): Add INDENT parameter and honor it. (pretty-print-with-comments): Change default value of #:format-comment. Call FORMAT-COMMENT with INDENT as the second argument. * tests/read-print.scm: Adjust test accordingly. --- guix/read-print.scm | 35 +++++++++++++++++++---------------- tests/read-print.scm | 4 +++- 2 files changed, 22 insertions(+), 17 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 4a3afdd4f9..2fc3d85a25 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -371,23 +371,26 @@ particular newlines, is left as is." "Return the \"width\" of STR--i.e., the width of the longest line of STR." (apply max (map string-length (string-split str #\newline)))) -(define (canonicalize-comment c) - "Canonicalize comment C, ensuring it has the \"right\" number of leading -semicolons." - (let ((line (string-trim-both - (string-trim (comment->string c) (char-set #\;))))) - (string->comment (string-append - (if (comment-margin? c) - ";" - (if (string-null? line) - ";;" ;no trailing space - ";; ")) - line "\n") - (comment-margin? c)))) +(define (canonicalize-comment comment indent) + "Canonicalize COMMENT, which is to be printed at INDENT, ensuring it has the +\"right\" number of leading semicolons." + (if (zero? indent) + comment ;leave top-level comments unchanged + (let ((line (string-trim-both + (string-trim (comment->string comment) (char-set #\;))))) + (string->comment (string-append + (if (comment-margin? comment) + ";" + (if (string-null? line) + ";;" ;no trailing space + ";; ")) + line "\n") + (comment-margin? comment))))) (define* (pretty-print-with-comments port obj #:key - (format-comment identity) + (format-comment + (lambda (comment indent) comment)) (format-vertical-space identity) (indent 0) (max-width 78) @@ -475,7 +478,7 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (if (comment-margin? comment) (begin (display " " port) - (display (comment->string (format-comment comment)) + (display (comment->string (format-comment comment indent)) port)) (begin ;; When already at the beginning of a line, for example because @@ -483,7 +486,7 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (unless (= column indent) (newline port) (display (make-string indent #\space) port)) - (display (comment->string (format-comment comment)) + (display (comment->string (format-comment comment indent)) port))) (display (make-string indent #\space) port) indent) diff --git a/tests/read-print.scm b/tests/read-print.scm index 94f018dd44..e3f23194af 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -274,6 +274,7 @@ mnopqrstuvwxyz.\")" (test-pretty-print/sequence " ;;; Hello! +;;; Notice that there are three semicolons here. (define-module (foo bar) #:use-module (guix) @@ -286,7 +287,8 @@ mnopqrstuvwxyz.\")" (locale \"eo_EO.UTF-8\") (services - (cons (service mcron-service-type) %base-services)))\n") + (cons (service mcron-service-type) %base-services)))\n" + #:format-comment canonicalize-comment) (test-equal "pretty-print-with-comments, canonicalize-comment" "\ -- cgit v1.2.3 From a15542d26df42dabdb5e2f76d150ae200230c3b0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 2 Aug 2022 18:01:35 +0200 Subject: style: Add '--whole-file' option. * guix/scripts/style.scm (format-whole-file): New procedure. (%options, show-help): Add '--whole-file'. (guix-style): Honor it. * tests/guix-style.sh: New file. * Makefile.am (SH_TESTS): Add it. * doc/guix.texi (Invoking guix style): Document it. --- Makefile.am | 1 + doc/guix.texi | 28 ++++++++++++++++-- guix/scripts/style.scm | 65 ++++++++++++++++++++++++++++------------ tests/guix-style.sh | 80 ++++++++++++++++++++++++++++++++++++++++++++++++++ 4 files changed, 153 insertions(+), 21 deletions(-) create mode 100644 tests/guix-style.sh (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index 2cda20e61c..f7c42e8153 100644 --- a/Makefile.am +++ b/Makefile.am @@ -580,6 +580,7 @@ SH_TESTS = \ tests/guix-package.sh \ tests/guix-package-aliases.sh \ tests/guix-package-net.sh \ + tests/guix-style.sh \ tests/guix-system.sh \ tests/guix-home.sh \ tests/guix-archive.sh \ diff --git a/doc/guix.texi b/doc/guix.texi index d6460a785f..9a6a5c307d 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -14058,9 +14058,12 @@ otherwise. @node Invoking guix style @section Invoking @command{guix style} -The @command{guix style} command helps packagers style their package -definitions according to the latest fashionable trends. The command -currently provides the following styling rules: +The @command{guix style} command helps users and packagers alike style +their package definitions and configuration files according to the +latest fashionable trends. It can either reformat whole files, with the +@option{--whole-file} option, or apply specific @dfn{styling rules} to +individual package definitions. The command currently provides the +following styling rules: @itemize @item @@ -14115,6 +14118,12 @@ the packages. The @option{--styling} or @option{-S} option allows you to select the style rule, the default rule being @code{format}---see below. +To reformat entire source files, the syntax is: + +@example +guix style --whole-file @var{file}@dots{} +@end example + The available options are listed below. @table @code @@ -14122,6 +14131,19 @@ The available options are listed below. @itemx -n Show source file locations that would be edited but do not modify them. +@item --whole-file +@itemx -f +Reformat the given files in their entirety. In that case, subsequent +arguments are interpreted as file names (rather than package names), and +the @option{--styling} option has no effect. + +As an example, here is how you might reformat your operating system +configuration (you need write permissions for the file): + +@example +guix style -f /etc/config.scm +@end example + @item --styling=@var{rule} @itemx -S @var{rule} Apply @var{rule}, one of the following styling rules: diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 2e14bc68fd..c0b9ea1a28 100644 --- a/guix/scripts/style.scm +++ b/guix/scripts/style.scm @@ -328,6 +328,21 @@ PACKAGE." (< (location-line loc1) (location-line loc2)) (stringpackage spec)) - (('expression . str) - (read/eval str)) - (_ #f)) - opts)) (edit (if (assoc-ref opts 'dry-run?) edit-expression/dry-run edit-expression)) (style (assoc-ref opts 'styling-procedure)) (policy (assoc-ref opts 'input-simplification-policy))) (with-error-handling - (for-each (lambda (package) - (style package #:policy policy - #:edit-expression edit)) - ;; Sort package by source code location so that we start editing - ;; files from the bottom and going upward. That way, the - ;; 'location' field of records is not invalidated as - ;; we modify files. - (sort (if (null? packages) - (fold-packages cons '() #:select? (const #t)) - packages) - (negate package-locationpackage spec)) + (('expression . str) + (read/eval str)) + (_ #f)) + opts))) + (for-each (lambda (package) + (style package #:policy policy + #:edit-expression edit)) + ;; Sort package by source code location so that we start + ;; editing files from the bottom and going upward. That + ;; way, the 'location' field of records is not + ;; invalidated as we modify files. + (sort (if (null? packages) + (fold-packages cons '() #:select? (const #t)) + packages) + (negate package-location +# +# 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 . + +# +# Test 'guix style'. +# + +set -e + +guix style --version + +tmpdir="guix-style-$$" +trap 'rm -r "$tmpdir"' EXIT + +tmpfile="$tmpdir/os.scm" +mkdir "$tmpdir" +cat > "$tmpfile" < Date: Tue, 2 Aug 2022 22:52:10 +0200 Subject: read-print: Support printing multi-line comments. * guix/read-print.scm (%not-newline): New variable. (print-multi-line-comment): New procedure. (pretty-print-with-comments): Use it. * tests/read-print.scm ("pretty-print-with-comments, multi-line comment"): New test. --- guix/read-print.scm | 26 ++++++++++++++++++++++++-- tests/read-print.scm | 14 ++++++++++++++ 2 files changed, 38 insertions(+), 2 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 2fc3d85a25..df25eb0f50 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -387,6 +387,27 @@ particular newlines, is left as is." line "\n") (comment-margin? comment))))) +(define %not-newline + (char-set-complement (char-set #\newline))) + +(define (print-multi-line-comment str indent port) + "Print to PORT STR as a multi-line comment, with INDENT spaces preceding +each line except the first one (they're assumed to be already there)." + + ;; While 'read-with-comments' only returns one-line comments, user-provided + ;; comments might span multiple lines, which is why this is necessary. + (let loop ((lst (string-tokenize str %not-newline))) + (match lst + (() #t) + ((last) + (display last port) + (newline port)) + ((head tail ...) + (display head port) + (newline port) + (display (make-string indent #\space) port) + (loop tail))))) + (define* (pretty-print-with-comments port obj #:key (format-comment @@ -486,8 +507,9 @@ FORMAT-VERTICAL-SPACE; a useful value of 'canonicalize-vertical-space'." (unless (= column indent) (newline port) (display (make-string indent #\space) port)) - (display (comment->string (format-comment comment indent)) - port))) + (print-multi-line-comment (comment->string + (format-comment comment indent)) + indent port))) (display (make-string indent #\space) port) indent) ((? vertical-space? space) diff --git a/tests/read-print.scm b/tests/read-print.scm index e3f23194af..004fcff19f 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -341,4 +341,18 @@ mnopqrstuvwxyz.\")" #:format-vertical-space canonicalize-vertical-space))))) +(test-equal "pretty-print-with-comments, multi-line comment" + "\ +(list abc + ;; This comment spans + ;; two lines. + def)" + (call-with-output-string + (lambda (port) + (pretty-print-with-comments port + `(list abc ,(comment "\ +;; This comment spans\n +;; two lines.\n") + def))))) + (test-end) -- cgit v1.2.3 From 6db3b34d7203639ef4286c237a6e536259f92352 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Aug 2022 11:49:44 +0200 Subject: read-print: Add 'case' and 'cond' special forms. * guix/read-print.scm (%special-forms): Add 'case' and 'cond'. * tests/read-print.scm: Add tests. --- guix/read-print.scm | 2 ++ tests/read-print.scm | 15 +++++++++++++++ 2 files changed, 17 insertions(+) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index df25eb0f50..9d666d7f70 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -255,6 +255,8 @@ expressions and blanks that were read." ;; symbol must appear within a (modify-phases ...) expression. (vhashq ('begin 1) + ('case 2) + ('cond 1) ('lambda 2) ('lambda* 2) ('match-lambda 1) diff --git a/tests/read-print.scm b/tests/read-print.scm index 004fcff19f..b484e28022 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -141,6 +141,21 @@ expressions." (let ((z (+ x y))) (* z z)))") +(test-pretty-print "\ +(case x + ((1) + 'one) + ((2) + 'two))") + +(test-pretty-print "\ +(cond + ((zero? x) + 'zero) + ((odd? x) + 'odd) + (else #f))") + (test-pretty-print "\ #~(string-append #$coreutils \"/bin/uname\")") -- cgit v1.2.3 From 5bce4c82422de6beb3ce6120ba1592be898c2b72 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Fri, 5 Aug 2022 17:09:10 +0200 Subject: build-system: Add 'channel-build-system'. * gnu/ci.scm (channel-build-system, channel-source->package): Remove. * gnu/packages/package-management.scm (channel-source->package): New procedure, moved from (gnu ci). * guix/build-system/channel.scm: New file, with code moved from (gnu ci). * doc/guix.texi (Build Systems): Document it. --- Makefile.am | 1 + doc/guix.texi | 9 ++++++ etc/system-tests.scm | 3 +- gnu/ci.scm | 42 ++------------------------- gnu/packages/package-management.scm | 16 ++++++++++ guix/build-system/channel.scm | 58 +++++++++++++++++++++++++++++++++++++ 6 files changed, 87 insertions(+), 42 deletions(-) create mode 100644 guix/build-system/channel.scm (limited to 'guix') diff --git a/Makefile.am b/Makefile.am index f7c42e8153..f707b930b2 100644 --- a/Makefile.am +++ b/Makefile.am @@ -142,6 +142,7 @@ MODULES = \ guix/build-system/android-ndk.scm \ guix/build-system/ant.scm \ guix/build-system/cargo.scm \ + guix/build-system/channel.scm \ guix/build-system/chicken.scm \ guix/build-system/clojure.scm \ guix/build-system/cmake.scm \ diff --git a/doc/guix.texi b/doc/guix.texi index 9a6a5c307d..5dab9cf169 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9568,6 +9568,15 @@ with @code{build-expression->derivation} (@pxref{Derivations, @code{build-expression->derivation}}). @end defvr +@defvr {Scheme Variable} channel-build-system +This variable is exported by @code{(guix build-system channel)}. + +This build system is meant primarily for internal use. It requires two +arguments, @code{#:commit} and @code{#:source}, and builds a Guix +instance from that channel, in the same way @command{guix time-machine} +would do it (@pxref{Channels}). +@end defvr + @node Build Phases @section Build Phases diff --git a/etc/system-tests.scm b/etc/system-tests.scm index cd22b7e6d3..221a63bb7f 100644 --- a/etc/system-tests.scm +++ b/etc/system-tests.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2016, 2018, 2019, 2020 Ludovic Courtès +;;; Copyright © 2016, 2018-2020, 2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -20,7 +20,6 @@ (gnu packages package-management) (guix monads) (guix store) - ((gnu ci) #:select (channel-source->package)) ((guix git-download) #:select (git-predicate)) ((guix utils) #:select (current-source-directory)) (git) diff --git a/gnu/ci.scm b/gnu/ci.scm index 9389b43824..9cc3a1a81f 100644 --- a/gnu/ci.scm +++ b/gnu/ci.scm @@ -21,9 +21,9 @@ ;;; along with GNU Guix. If not, see . (define-module (gnu ci) - #:use-module (guix channels) + #:use-module (guix build-system channel) #:use-module (guix config) - #:use-module (guix describe) + #:autoload (guix describe) (package-channels) #:use-module (guix store) #:use-module (guix grafts) #:use-module (guix profiles) @@ -32,7 +32,6 @@ #:use-module (guix channels) #:use-module (guix config) #:use-module (guix derivations) - #:use-module (guix build-system) #:use-module (guix monads) #:use-module (guix gexp) #:use-module (guix ui) @@ -71,7 +70,6 @@ image->job %core-packages - channel-source->package arguments->systems cuirass-jobs)) @@ -288,42 +286,6 @@ otherwise use the IMAGE name." '())) '())) -(define channel-build-system - ;; Build system used to "convert" a channel instance to a package. - (let* ((build (lambda* (name inputs - #:key source commit system - #:allow-other-keys) - (mlet* %store-monad ((source (if (string? source) - (return source) - (lower-object source))) - (instance - -> (checkout->channel-instance - source #:commit commit))) - (channel-instances->derivation (list instance))))) - (lower (lambda* (name #:key system source commit - #:allow-other-keys) - (bag - (name name) - (system system) - (build build) - (arguments `(#:source ,source - #:commit ,commit)))))) - (build-system (name 'channel) - (description "Turn a channel instance into a package.") - (lower lower)))) - -(define* (channel-source->package source #:key commit) - "Return a package for the given channel SOURCE, a lowerable object." - (package - (inherit guix) - (version (string-append (package-version guix) "+")) - (build-system channel-build-system) - (arguments `(#:source ,source - #:commit ,commit)) - (inputs '()) - (native-inputs '()) - (propagated-inputs '()))) - (define* (system-test-jobs store system #:key source commit) "Return a list of jobs for the system tests." diff --git a/gnu/packages/package-management.scm b/gnu/packages/package-management.scm index c22c9f7a43..b9cd74eb27 100644 --- a/gnu/packages/package-management.scm +++ b/gnu/packages/package-management.scm @@ -110,6 +110,7 @@ #:use-module (gnu packages xml) #:use-module (gnu packages xorg) #:use-module (gnu packages version-control) + #:autoload (guix build-system channel) (channel-build-system) #:use-module (guix build-system glib-or-gtk) #:use-module (guix build-system gnu) #:use-module (guix build-system guile) @@ -489,6 +490,21 @@ the Nix package manager.") (license license:gpl3+) (properties '((ftp-server . "alpha.gnu.org")))))) +(define* (channel-source->package source #:key commit) + "Return a package for the given channel SOURCE, a lowerable object." + (package + (inherit guix) + (version (string-append (package-version guix) "." + (if commit (string-take commit 7) ""))) + (build-system channel-build-system) + (arguments `(#:source ,source + #:commit ,commit)) + (inputs '()) + (native-inputs '()) + (propagated-inputs '()))) + +(export channel-source->package) + (define-public guix-for-cuirass ;; Known-good revision before commit ;; bd86bbd300474204878e927f6cd3f0defa1662a5, which introduced diff --git a/guix/build-system/channel.scm b/guix/build-system/channel.scm new file mode 100644 index 0000000000..227eb08373 --- /dev/null +++ b/guix/build-system/channel.scm @@ -0,0 +1,58 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2019-2021 Ludovic Courtès +;;; +;;; 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 . + +(define-module (guix build-system channel) + #:use-module ((guix store) #:select (%store-monad)) + #:use-module ((guix gexp) #:select (lower-object)) + #:use-module (guix monads) + #:use-module (guix channels) + #:use-module (guix build-system) + #:export (channel-build-system)) + +;;; Commentary: +;;; +;;; The "channel" build system lets you build Guix instances from channel +;;; specifications, similar to how 'guix time-machine' would do it, as regular +;;; packages. +;;; +;;; Code: + +(define channel-build-system + ;; Build system used to "convert" a channel instance to a package. + (let* ((build (lambda* (name inputs + #:key source commit system + #:allow-other-keys) + (mlet* %store-monad ((source (if (string? source) + (return source) + (lower-object source))) + (instance + -> (checkout->channel-instance + source #:commit commit))) + (channel-instances->derivation (list instance))))) + (lower (lambda* (name #:key system source commit + #:allow-other-keys) + (bag + (name name) + (system system) + (build build) + (arguments `(#:source ,source + #:commit ,commit)))))) + (build-system (name 'channel) + (description "Turn a channel instance into a package.") + (lower lower)))) + -- cgit v1.2.3 From cf60a0a906440ccb007bae1243c3e0397c3a0aba Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Aug 2022 23:06:11 +0200 Subject: build-system/channel: Accept a channel or instance as the source. * guix/build-system/channel.scm (latest-channel-instances*): New variable. (build-channels): New procedure, with code formerly in 'channel-build-system', augmented with clauses for when SOURCE is a channel instance or a channel. * doc/guix.texi (Build Systems): Adjust accordingly. --- doc/guix.texi | 12 ++++++---- guix/build-system/channel.scm | 53 +++++++++++++++++++++++++++---------------- 2 files changed, 41 insertions(+), 24 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index 5dab9cf169..306c7b635b 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -9571,10 +9571,14 @@ with @code{build-expression->derivation} (@pxref{Derivations, @defvr {Scheme Variable} channel-build-system This variable is exported by @code{(guix build-system channel)}. -This build system is meant primarily for internal use. It requires two -arguments, @code{#:commit} and @code{#:source}, and builds a Guix -instance from that channel, in the same way @command{guix time-machine} -would do it (@pxref{Channels}). +This build system is meant primarily for internal use. A package using +this build system must have a channel specification as its @code{source} +field (@pxref{Channels}); alternatively, its source can be a directory +name, in which case an additional @code{#:commit} argument must be +supplied to specify the commit being built (a hexadecimal string). + +The resulting package is a Guix instance of the given channel, similar +to how @command{guix time-machine} would build it. @end defvr @node Build Phases diff --git a/guix/build-system/channel.scm b/guix/build-system/channel.scm index 227eb08373..b6ef3bfacf 100644 --- a/guix/build-system/channel.scm +++ b/guix/build-system/channel.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2019-2021 Ludovic Courtès +;;; Copyright © 2019-2022 Ludovic Courtès ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,7 +17,7 @@ ;;; along with GNU Guix. If not, see . (define-module (guix build-system channel) - #:use-module ((guix store) #:select (%store-monad)) + #:use-module ((guix store) #:select (%store-monad store-lift)) #:use-module ((guix gexp) #:select (lower-object)) #:use-module (guix monads) #:use-module (guix channels) @@ -32,26 +32,39 @@ ;;; ;;; Code: +(define latest-channel-instances* + (store-lift latest-channel-instances)) + +(define* (build-channels name inputs + #:key source system commit + (authenticate? #t) + #:allow-other-keys) + (mlet* %store-monad ((instances + (cond ((channel-instance? source) + (return (list source))) + ((channel? source) + (latest-channel-instances* + (list source) + #:authenticate? authenticate?)) + (else + (mlet %store-monad ((source + (lower-object source))) + (return + (list (checkout->channel-instance + source #:commit commit)))))))) + (channel-instances->derivation instances))) + (define channel-build-system ;; Build system used to "convert" a channel instance to a package. - (let* ((build (lambda* (name inputs - #:key source commit system - #:allow-other-keys) - (mlet* %store-monad ((source (if (string? source) - (return source) - (lower-object source))) - (instance - -> (checkout->channel-instance - source #:commit commit))) - (channel-instances->derivation (list instance))))) - (lower (lambda* (name #:key system source commit - #:allow-other-keys) - (bag - (name name) - (system system) - (build build) - (arguments `(#:source ,source - #:commit ,commit)))))) + (let ((lower (lambda* (name #:key system source commit (authenticate? #t) + #:allow-other-keys) + (bag + (name name) + (system system) + (build build-channels) + (arguments `(#:source ,source + #:authenticate? ,authenticate? + #:commit ,commit)))))) (build-system (name 'channel) (description "Turn a channel instance into a package.") (lower lower)))) -- cgit v1.2.3 From 64a070717c3de32332201df5d6d2d52a7f99dce9 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Mon, 8 Aug 2022 17:37:12 +0200 Subject: channels: Add 'repository->guix-channel'. * guix/channels.scm (repository->guix-channel): New procedure. * guix/scripts/describe.scm (display-checkout-info): Use it instead of the (git) interface, and adjust accordingly. --- guix/channels.scm | 21 +++++++++++++++++++++ guix/scripts/describe.scm | 40 ++++++++++++++-------------------------- 2 files changed, 35 insertions(+), 26 deletions(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index 689b30e0eb..a5e9d7774d 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -77,6 +77,7 @@ %default-guix-channel %default-channels guix-channel? + repository->guix-channel channel-instance? channel-instance-channel @@ -202,6 +203,26 @@ introduction, add it." (introduction %guix-channel-introduction)) chan)) +(define* (repository->guix-channel directory + #:key + (introduction %guix-channel-introduction)) + "Look for a Git repository in DIRECTORY or its ancestors and return a +channel that uses that repository and the commit HEAD currently points to; use +INTRODUCTION as the channel's introduction. Return #f if no Git repository +could be found at DIRECTORY or one of its ancestors." + (catch 'git-error + (lambda () + (with-repository (repository-discover directory) repository + (let* ((head (repository-head repository)) + (commit (oid->string (reference-target head)))) + (channel + (inherit %default-guix-channel) + (url (repository-working-directory repository)) + (commit commit) + (branch (reference-shorthand head)) + (introduction introduction))))) + (const #f))) + (define-record-type (channel-instance channel commit checkout) channel-instance? diff --git a/guix/scripts/describe.scm b/guix/scripts/describe.scm index 7e4f682053..0c310e3da8 100644 --- a/guix/scripts/describe.scm +++ b/guix/scripts/describe.scm @@ -29,7 +29,6 @@ #:use-module (guix profiles) #:autoload (guix colors) (supports-hyperlinks? hyperlink) #:autoload (guix openpgp) (openpgp-format-fingerprint) - #:use-module (git) #:autoload (json builder) (scm->json-string) #:use-module (srfi srfi-1) #:use-module (srfi srfi-26) @@ -148,40 +147,29 @@ Display information about the channels currently in use.\n")) "Display information about the current checkout according to FMT, a symbol denoting the requested format. Exit if the current directory does not lie within a Git checkout." - (let* ((program (car (command-line))) - (directory (catch 'git-error - (lambda () - (repository-discover (dirname program))) - (lambda (key err) - (report-error (G_ "failed to determine origin~%")) - (display-hint (format #f (G_ "Perhaps this + (let* ((program (car (command-line))) + (channel (repository->guix-channel (dirname program)))) + (unless channel + (report-error (G_ "failed to determine origin~%")) + (display-hint (format #f (G_ "Perhaps this @command{guix} command was not obtained with @command{guix pull}? Its version string is ~a.~%") - %guix-version)) - (exit 1)))) - (repository (repository-open directory)) - (head (repository-head repository)) - (commit (oid->string (reference-target head)))) + %guix-version)) + (exit 1)) + (match fmt ('human (format #t (G_ "Git checkout:~%")) - (format #t (G_ " repository: ~a~%") (dirname directory)) - (format #t (G_ " branch: ~a~%") (reference-shorthand head)) - (format #t (G_ " commit: ~a~%") commit)) + (format #t (G_ " repository: ~a~%") (channel-url channel)) + (format #t (G_ " branch: ~a~%") (channel-branch channel)) + (format #t (G_ " commit: ~a~%") (channel-commit channel))) ('channels - (pretty-print `(list ,(channel->code (channel (name 'guix) - (url (dirname directory)) - (commit commit)))))) + (pretty-print `(list ,(channel->code channel)))) ('json - (display (channel->json (channel (name 'guix) - (url (dirname directory)) - (commit commit)))) + (display (channel->json channel)) (newline)) ('recutils - (channel->recutils (channel (name 'guix) - (url (dirname directory)) - (commit commit)) - (current-output-port)))) + (channel->recutils channel (current-output-port)))) (display-package-search-path fmt))) (define* (display-profile-info profile fmt -- cgit v1.2.3 From e1b8bace8cf26fb7aa32614241917832b4225b44 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Aug 2022 15:58:14 +0200 Subject: tests: git: Write files as UTF-8. * guix/tests/git.scm (populate-git-repository): Add call to 'set-port-encoding!' in 'add' case. --- guix/tests/git.scm | 1 + 1 file changed, 1 insertion(+) (limited to 'guix') diff --git a/guix/tests/git.scm b/guix/tests/git.scm index 94f1021c79..d51e49e514 100644 --- a/guix/tests/git.scm +++ b/guix/tests/git.scm @@ -73,6 +73,7 @@ Return DIRECTORY on success." (mkdir-p (dirname file)) (call-with-output-file file (lambda (port) + (set-port-encoding! port "UTF-8") (display (if (string? contents) contents (with-repository directory repository -- cgit v1.2.3 From 60e0aae89cbf29f88f110376f911777aac70e8a7 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Aug 2022 15:59:09 +0200 Subject: channels: Consider news files as UTF-8-encoded by default. MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Partly fixes . Reported by Pierre-Henry Fröhring . Previously, news file would be read using the current locale encoding. This could lead to a test failure in 'tests/channels.scm' (in a test that expects some Unicode-capable encoding) in case tests were run in a non-Unicode locale. * guix/channels.scm (channel-news-for-commit): Make port for NEWS-FILE UTF-8 by default. --- guix/channels.scm | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) (limited to 'guix') diff --git a/guix/channels.scm b/guix/channels.scm index a5e9d7774d..ad6d3fb8ac 100644 --- a/guix/channels.scm +++ b/guix/channels.scm @@ -1153,7 +1153,11 @@ NEW. When OLD is omitted or is #f, return all the news entries of CHANNEL." (if (and news-file (file-exists? news-file)) (with-repository checkout repository (let* ((news (call-with-input-file news-file - read-channel-news)) + (lambda (port) + (set-port-encoding! port + (or (file-encoding port) + "UTF-8")) + (read-channel-news port)))) (entries (map (lambda (entry) (resolve-channel-news-entry-tag repository entry)) -- cgit v1.2.3 From 4b494878380920c8c7eecccd1f299164dd4a2c3f Mon Sep 17 00:00:00 2001 From: Oleg Pykhalov Date: Tue, 19 Jul 2022 19:40:28 +0300 Subject: gnu: system: file-systems: Add shared flag. * gnu/build/file-systems.scm (mount-flags->bit-mask, mount-file-system): Handle shared flag. * gnu/system/file-systems.scm (invalid-file-system-flags): Add shared to known flags. * guix/build/syscalls.scm (MS_SHARED): New variable. * doc/guix.texi (File Systems): Document shared flag. --- doc/guix.texi | 5 +++-- gnu/build/file-systems.scm | 6 ++++++ gnu/system/file-systems.scm | 4 +++- guix/build/syscalls.scm | 3 +++ 4 files changed, 15 insertions(+), 3 deletions(-) (limited to 'guix') diff --git a/doc/guix.texi b/doc/guix.texi index eb3a1a4eb5..99321929cc 100644 --- a/doc/guix.texi +++ b/doc/guix.texi @@ -16421,8 +16421,9 @@ include @code{read-only}, @code{bind-mount}, @code{no-dev} (disallow access to special files), @code{no-suid} (ignore setuid and setgid bits), @code{no-atime} (do not update file access times), @code{strict-atime} (update file access time), @code{lazy-time} (only -update time on the in-memory version of the file inode), and -@code{no-exec} (disallow program execution). +update time on the in-memory version of the file inode), +@code{no-exec} (disallow program execution), and @code{shared} (make the +mount shared). @xref{Mount-Unmount-Remount,,, libc, The GNU C Library Reference Manual}, for more information on these flags. diff --git a/gnu/build/file-systems.scm b/gnu/build/file-systems.scm index 1d3b33e7bd..b9d46c9350 100644 --- a/gnu/build/file-systems.scm +++ b/gnu/build/file-systems.scm @@ -6,6 +6,7 @@ ;;; Copyright © 2019–2021 Tobias Geerinckx-Rice ;;; Copyright © 2019 David C. Trudgian ;;; Copyright © 2020 Maxim Cournoyer +;;; Copyright © 2022 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -1123,6 +1124,8 @@ corresponds to the symbols listed in FLAGS." (logior MS_STRICTATIME (loop rest))) (('lazy-time rest ...) (logior MS_LAZYTIME (loop rest))) + (('shared rest ...) + (loop rest)) (() 0)))) @@ -1186,6 +1189,9 @@ corresponds to the symbols listed in FLAGS." (cond ((string-prefix? "nfs" type) (mount-nfs source target type flags options)) + ((memq 'shared (file-system-flags fs)) + (mount source target type flags options) + (mount "none" target #f MS_SHARED)) (else (mount source target type flags options))) diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm index f8f4276283..464b76a2ca 100644 --- a/gnu/system/file-systems.scm +++ b/gnu/system/file-systems.scm @@ -4,6 +4,7 @@ ;;; Copyright © 2020 Jakub Kądziołka ;;; Copyright © 2020, 2021 Maxim Cournoyer ;;; Copyright © 2021 Tobias Geerinckx-Rice +;;; Copyright © 2022 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -121,7 +122,8 @@ ;; Note: Keep in sync with 'mount-flags->bit-mask'. (let ((known-flags '(read-only bind-mount no-suid no-dev no-exec - no-atime strict-atime lazy-time))) + no-atime strict-atime lazy-time + shared))) (lambda (flags) "Return the subset of FLAGS that is invalid." (remove (cut memq <> known-flags) flags)))) diff --git a/guix/build/syscalls.scm b/guix/build/syscalls.scm index a7401fd73f..eda487f52e 100644 --- a/guix/build/syscalls.scm +++ b/guix/build/syscalls.scm @@ -8,6 +8,7 @@ ;;; Copyright © 2020 Jan (janneke) Nieuwenhuizen ;;; Copyright © 2021 Chris Marusich ;;; Copyright © 2021 Tobias Geerinckx-Rice +;;; Copyright © 2022 Oleg Pykhalov ;;; ;;; This file is part of GNU Guix. ;;; @@ -49,6 +50,7 @@ MS_RELATIME MS_BIND MS_MOVE + MS_SHARED MS_LAZYTIME MNT_FORCE MNT_DETACH @@ -537,6 +539,7 @@ the last argument of `mknod'." (define MS_NOATIME 1024) (define MS_BIND 4096) (define MS_MOVE 8192) +(define MS_SHARED 1048576) (define MS_RELATIME 2097152) (define MS_STRICTATIME 16777216) (define MS_LAZYTIME 33554432) -- cgit v1.2.3 From 06ce4e3c06145423e66bb5694d800256e762057c Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Tue, 9 Aug 2022 19:35:53 +0200 Subject: ssh: 'open-ssh-session' gracefully handles connection timeouts. * guix/ssh.scm (open-ssh-session): Add case for 'again. --- guix/ssh.scm | 4 ++++ 1 file changed, 4 insertions(+) (limited to 'guix') diff --git a/guix/ssh.scm b/guix/ssh.scm index a6f0f2eb96..1b825a2573 100644 --- a/guix/ssh.scm +++ b/guix/ssh.scm @@ -162,6 +162,10 @@ server at '~a': ~a") ('success (session-set! session 'timeout timeout) session) + ('again + (raise (formatted-message (G_ "timeout while connecting \ +to SSH server at '~a'") + (session-get session 'host)))) (x (match (userauth-gssapi! session) ('success -- cgit v1.2.3 From ebda12e1d2c64480bb7d5977e580d8b2eabeb503 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Aug 2022 16:37:34 +0200 Subject: read-print: Report missing closing parens instead of looping. Fixes . Reported by Mohammed AMAR-BENSABER . Previously 'read-with-comments' would enter an infinite loop. * guix/read-print.scm (read-with-comments)[missing-closing-paren-error]: New procedure. Call it when 'loop' as called from 'liip' returns EOF. * tests/read-print.scm ("read-with-comments: missing closing paren"): New test. --- guix/read-print.scm | 33 +++++++++++++++++++++++++++------ tests/read-print.scm | 7 +++++++ 2 files changed, 34 insertions(+), 6 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 9d666d7f70..08e219e204 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -24,6 +24,11 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-34) #:use-module (srfi srfi-35) + #:use-module (guix i18n) + #:use-module ((guix diagnostics) + #:select (formatted-message + &fix-hint &error-location + location)) #:export (pretty-print-with-comments pretty-print-with-comments/splice read-with-comments @@ -158,6 +163,19 @@ BLANK-LINE? is true, assume PORT is at the beginning of a new line." (define dot (list 'dot)) (define (dot? x) (eq? x dot)) + (define (missing-closing-paren-error) + (raise (make-compound-condition + (formatted-message (G_ "unexpected end of file")) + (condition + (&error-location + (location (match (port-filename port) + (#f #f) + (file (location file + (port-line port) + (port-column port)))))) + (&fix-hint + (hint (G_ "Did you forget a closing parenthesis?"))))))) + (define (reverse/dot lst) ;; Reverse LST and make it an improper list if it contains DOT. (let loop ((result '()) @@ -190,12 +208,15 @@ BLANK-LINE? is true, assume PORT is at the beginning of a new line." ((memv chr '(#\( #\[)) (let/ec return (let liip ((lst '())) - (liip (cons (loop (match lst - (((? blank?) . _) #t) - (_ #f)) - (lambda () - (return (reverse/dot lst)))) - lst))))) + (define item + (loop (match lst + (((? blank?) . _) #t) + (_ #f)) + (lambda () + (return (reverse/dot lst))))) + (if (eof-object? item) + (missing-closing-paren-error) + (liip (cons item lst)))))) ((memv chr '(#\) #\])) (return)) ((eq? chr #\') diff --git a/tests/read-print.scm b/tests/read-print.scm index b484e28022..4dabcc1e64 100644 --- a/tests/read-print.scm +++ b/tests/read-print.scm @@ -19,6 +19,8 @@ (define-module (tests-style) #:use-module (guix read-print) #:use-module (guix gexp) ;for the reader extensions + #:use-module (srfi srfi-34) + #:use-module (srfi srfi-35) #:use-module (srfi srfi-64) #:use-module (ice-9 match)) @@ -46,6 +48,11 @@ expressions." (test-begin "read-print") +(test-assert "read-with-comments: missing closing paren" + (guard (c ((error? c) #t)) + (call-with-input-string "(what is going on?" + read-with-comments))) + (test-equal "read-with-comments: dot notation" (cons 'a 'b) (call-with-input-string "(a . b)" -- cgit v1.2.3 From b21d05d232ec0aba5abec20e83cc52c1d5163cc3 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Wed, 10 Aug 2022 16:40:06 +0200 Subject: read-print: Remove unused procedure. * guix/read-print.scm (combine-vertical-space): Remove. --- guix/read-print.scm | 5 ----- 1 file changed, 5 deletions(-) (limited to 'guix') diff --git a/guix/read-print.scm b/guix/read-print.scm index 08e219e204..63ff9ca5bd 100644 --- a/guix/read-print.scm +++ b/guix/read-print.scm @@ -82,11 +82,6 @@ (define vertical-space (record-type-constructor )) (define vertical-space-height (record-accessor 'height)) -(define (combine-vertical-space x y) - "Return vertical space as high as the combination of X and Y." - (vertical-space (+ (vertical-space-height x) - (vertical-space-height y)))) - (define canonicalize-vertical-space (let ((unit (vertical-space 1))) (lambda (space) -- cgit v1.2.3 From a81706494753ad84754cbb7583ccc783452decc0 Mon Sep 17 00:00:00 2001 From: Ludovic Courtès Date: Thu, 11 Aug 2022 15:55:38 +0200 Subject: build-system/channel: Correctly handle store file name from (gnu ci). This is a followup to cf60a0a906440ccb007bae1243c3e0397c3a0aba. Reported by Mathieu Othacehe . * guix/build-system/channel.scm (build-channels): Add 'string?' case. --- guix/build-system/channel.scm | 7 +++++++ 1 file changed, 7 insertions(+) (limited to 'guix') diff --git a/guix/build-system/channel.scm b/guix/build-system/channel.scm index b6ef3bfacf..6ad377f930 100644 --- a/guix/build-system/channel.scm +++ b/guix/build-system/channel.scm @@ -46,6 +46,13 @@ (latest-channel-instances* (list source) #:authenticate? authenticate?)) + ((string? source) + ;; If SOURCE is a store file name, as is the + ;; case when called from (gnu ci), return it as + ;; is. + (return + (list (checkout->channel-instance + source #:commit commit)))) (else (mlet %store-monad ((source (lower-object source))) -- cgit v1.2.3