diff options
Diffstat (limited to 'guix')
| -rw-r--r-- | guix/cache.scm | 9 | ||||
| -rw-r--r-- | guix/import/cabal.scm | 107 | ||||
| -rw-r--r-- | guix/import/hackage.scm | 23 | ||||
| -rw-r--r-- | guix/scripts/edit.scm | 30 | ||||
| -rw-r--r-- | guix/scripts/home.scm | 7 | ||||
| -rw-r--r-- | guix/scripts/home/edit.scm | 66 | ||||
| -rw-r--r-- | guix/scripts/home/import.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/shell.scm | 2 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 10 | ||||
| -rw-r--r-- | guix/scripts/system/edit.scm | 64 |
10 files changed, 245 insertions, 77 deletions
diff --git a/guix/cache.scm b/guix/cache.scm index 51009809bd..be0de90e67 100644 --- a/guix/cache.scm +++ b/guix/cache.scm @@ -1,5 +1,6 @@ ;;; GNU Guix --- Functional package management for GNU ;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2022 Simon Tournier <zimon.toutoune@gmail.com> ;;; ;;; This file is part of GNU Guix. ;;; @@ -17,9 +18,11 @@ ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. (define-module (guix cache) + #:use-module ((guix utils) #:select (with-atomic-file-output)) #:use-module (srfi srfi-19) #:use-module (srfi srfi-26) #:use-module (ice-9 match) + #:use-module ((ice-9 textual-ports) #:select (get-string-all)) #:export (obsolete? delete-file* file-expiration-time @@ -93,7 +96,9 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups." (define last-expiry-date (catch 'system-error (lambda () - (call-with-input-file expiry-file read)) + (or (string->number + (call-with-input-file expiry-file get-string-all)) + 0)) (const 0))) (when (obsolete? last-expiry-date now cleanup-period) @@ -103,7 +108,7 @@ CLEANUP-PERIOD denotes the minimum time between two cache cleanups." #:delete-entry delete-entry) (catch 'system-error (lambda () - (call-with-output-file expiry-file + (with-atomic-file-output expiry-file (cute write (time-second now) <>))) (lambda args ;; ENOENT means CACHE does not exist. diff --git a/guix/import/cabal.scm b/guix/import/cabal.scm index 98d7234098..4410c12500 100644 --- a/guix/import/cabal.scm +++ b/guix/import/cabal.scm @@ -74,6 +74,7 @@ cabal-executable-dependencies cabal-library? + cabal-library-name cabal-library-dependencies cabal-test-suite? @@ -149,7 +150,7 @@ to the stack." (right: IF FLAG EXEC TEST-SUITE CUSTOM-SETUP SOURCE-REPO BENCHMARK LIB COMMON OCURLY) (left: OR) (left: PROPERTY AND) - (right: ELSE NOT)) + (right: ELIF ELSE NOT)) ;; --- rules (body (properties sections) : (append $1 $2)) (sections (sections flags) : (append $1 $2) @@ -189,36 +190,36 @@ to the stack." (bm-sec) : (list $1)) (bm-sec (BENCHMARK OCURLY exprs CCURLY) : `(section benchmark ,$1 ,$3) (BENCHMARK open exprs close) : `(section benchmark ,$1 ,$3)) - (lib-sec (LIB OCURLY exprs CCURLY) : `(section library ,$3) - (LIB open exprs close) : `(section library ,$3)) + (lib-sec (LIB OCURLY exprs CCURLY) : `(section library ,$1 ,$3) + (LIB open exprs close) : `(section library ,$1 ,$3)) (exprs (exprs PROPERTY) : (append $1 (list $2)) (PROPERTY) : (list $1) - (exprs if-then-else) : (append $1 (list $2)) - (if-then-else) : (list $1) - (exprs if-then) : (append $1 (list $2)) - (if-then) : (list $1)) - (if-then-else (IF tests OCURLY exprs CCURLY ELSE OCURLY exprs CCURLY) - : `(if ,$2 ,$4 ,$8) - (IF tests open exprs close ELSE OCURLY exprs CCURLY) - : `(if ,$2 ,$4 ,$8) - ;; The 'open' token after 'tests' is shifted after an 'exprs' - ;; is found. This is because, instead of 'exprs' a 'OCURLY' - ;; token is a valid alternative. For this reason, 'open' - ;; pushes a <parse-context> with a line indentation equal to - ;; the indentation of 'exprs'. - ;; - ;; Differently from this, without the rule above this - ;; comment, when an 'ELSE' token is found, the 'open' token - ;; following the 'ELSE' would be shifted immediately, before - ;; the 'exprs' is found (because there are no other valid - ;; tokens). The 'open' would therefore create a - ;; <parse-context> with the indentation of 'ELSE' and not - ;; 'exprs', creating an inconsistency. We therefore allow - ;; mixed style conditionals. - (IF tests open exprs close ELSE open exprs close) - : `(if ,$2 ,$4 ,$8)) - (if-then (IF tests OCURLY exprs CCURLY) : `(if ,$2 ,$4 ()) - (IF tests open exprs close) : `(if ,$2 ,$4 ())) + (exprs elif-else) : (append $1 (list ($2 '(())))) + (elif-else) : (list ($1 '(())))) + ;; LALR(1) parsers prefer to be left-recursive, which make if-statements slightly involved. + ;; XXX: This technically allows multiple else statements. + (elif-else (elif-else ELIF tests OCURLY exprs CCURLY) : (lambda (y) ($1 (list (append (list 'if $3 $5) y)))) + (elif-else ELIF tests open exprs close) : (lambda (y) ($1 (list (append (list 'if $3 $5) y)))) + (elif-else ELSE OCURLY exprs CCURLY) : (lambda (y) ($1 (list $4))) + ;; The 'open' token after 'tests' is shifted after an 'exprs' + ;; is found. This is because, instead of 'exprs' a 'OCURLY' + ;; token is a valid alternative. For this reason, 'open' + ;; pushes a <parse-context> with a line indentation equal to + ;; the indentation of 'exprs'. + ;; + ;; Differently from this, without the rule above this + ;; comment, when an 'ELSE' token is found, the 'open' token + ;; following the 'ELSE' would be shifted immediately, before + ;; the 'exprs' is found (because there are no other valid + ;; tokens). The 'open' would therefore create a + ;; <parse-context> with the indentation of 'ELSE' and not + ;; 'exprs', creating an inconsistency. We therefore allow + ;; mixed style conditionals. + (elif-else ELSE open exprs close) : (lambda (y) ($1 (list $4))) + ;; Terminating rule. + (if-then) : (lambda (y) (append $1 y))) + (if-then (IF tests OCURLY exprs CCURLY) : (list 'if $2 $4) + (IF tests open exprs close) : (list 'if $2 $4)) (tests (TEST OPAREN ID CPAREN) : `(,$1 ,$3) (TRUE) : 'true (FALSE) : 'false @@ -354,7 +355,7 @@ matching a string against the created regexp." (make-regexp pat)))) (cut regexp-exec rx <>))) -(define is-layout-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?[^{}]*)$" +(define is-layout-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*(\\w?[^{}]*)" regexp/icase)) (define is-braced-property (make-rx-matcher "([a-z0-9-]+)[ \t]*:[ \t]*\\{[ \t]*$" @@ -382,9 +383,12 @@ matching a string against the created regexp." (define is-benchmark (make-rx-matcher "^benchmark +([a-z0-9_-]+)" regexp/icase)) -(define is-lib (make-rx-matcher "^library *" regexp/icase)) +;; Libraries can have optional names since Cabal 2.0. +(define is-lib (make-rx-matcher "^library(\\s+([a-z0-9_-]+))?\\s*" regexp/icase)) -(define is-else (make-rx-matcher "^else" regexp/icase)) +(define (is-else s) (string-ci=? s "else")) + +(define (is-elif s) (string-ci=? s "elif")) (define (is-if s) (string-ci=? s "if")) @@ -402,8 +406,8 @@ matching a string against the created regexp." (define (is-id s port loc) (let ((cabal-reserved-words - '("if" "else" "library" "flag" "executable" "test-suite" "custom-setup" - "source-repository" "benchmark" "common")) + '("if" "else" "elif" "library" "flag" "executable" "test-suite" + "custom-setup" "source-repository" "benchmark" "common")) (spaces (read-while (cut char-set-contains? char-set:blank <>) port)) (c (peek-char port))) (unread-string spaces port) @@ -463,7 +467,10 @@ string with the read characters." (value (match:substring k-v-rx-res 2))) (make-lexical-token 'PROPERTY loc - (list key `(,(read-value port value (current-indentation))))))) + (list key `(,(if (eqv? (peek-char port) #\newline) ; The next character + ; is not necessarily a newline if a bracket follows the property. + (read-value port value (current-indentation)) + value)))))) (define (lex-braced-property k-rx-res loc port) (let ((key (string-downcase (match:substring k-rx-res 1)))) @@ -471,8 +478,9 @@ string with the read characters." 'PROPERTY loc (list key `(,(read-braced-value port)))))) -(define (lex-rx-res rx-res token loc) - (let ((name (string-downcase (match:substring rx-res 1)))) +(define* (lex-rx-res rx-res token loc #:optional (substring-id 1)) + (let* ((match (match:substring rx-res substring-id)) + (name (if match (string-downcase match) match))) (make-lexical-token token loc name))) (define (lex-flag flag-rx-res loc) (lex-rx-res flag-rx-res 'FLAG loc)) @@ -490,10 +498,12 @@ string with the read characters." (define (lex-benchmark bm-rx-res loc) (lex-rx-res bm-rx-res 'BENCHMARK loc)) -(define (lex-lib loc) (make-lexical-token 'LIB loc #f)) +(define (lex-lib lib-rx-res loc) (lex-rx-res lib-rx-res 'LIB loc 2)) (define (lex-else loc) (make-lexical-token 'ELSE loc #f)) +(define (lex-elif loc) (make-lexical-token 'ELIF loc #f)) + (define (lex-if loc) (make-lexical-token 'IF loc #f)) (define (lex-true loc) (make-lexical-token 'TRUE loc #t)) @@ -566,8 +576,10 @@ location." (define (lex-word port loc) "Process tokens which can be recognized by reading the next word form PORT. LOC is the current port location." - (let* ((w (read-delimited " <>=()\t\n" port 'peek))) + (let* ((w (read-delimited " <>=():\t\n" port 'peek))) (cond ((is-if w) (lex-if loc)) + ((is-elif w) (lex-elif loc)) + ((is-else w) (lex-else loc)) ((is-test w port) (lex-test w loc)) ((is-true w) (lex-true loc)) ((is-false w) (lex-false loc)) @@ -590,12 +602,13 @@ the current port location." ((is-common s) => (cut lex-common <> loc)) ((is-custom-setup s) => (cut lex-custom-setup <> loc)) ((is-benchmark s) => (cut lex-benchmark <> loc)) - ((is-lib s) (lex-lib loc)) - ((is-else s) (lex-else loc)) + ((is-lib s) => (cut lex-lib <> loc)) (else (unread-string s port) #f)))) (define (lex-property port loc) - (let* ((s (read-delimited "\n" port 'peek))) + ;; Stop reading on a }, so closing brackets (for example during + ;; if-clauses) work properly. + (let* ((s (read-delimited "\n}" port 'peek))) (cond ((is-braced-property s) => (cut lex-braced-property <> loc port)) ((is-layout-property s) => (cut lex-layout-property <> loc port)) @@ -719,8 +732,9 @@ If #f use the function 'port-filename' to obtain it." (dependencies cabal-executable-dependencies)) ; list of <cabal-dependency> (define-record-type <cabal-library> - (make-cabal-library dependencies) + (make-cabal-library name dependencies) cabal-library? + (name cabal-library-name) (dependencies cabal-library-dependencies)) ; list of <cabal-dependency> (define-record-type <cabal-test-suite> @@ -851,9 +865,6 @@ the ordering operation and the version." (list 'section 'flag name parameters)) (('section 'custom-setup parameters) (list 'section 'custom-setup parameters)) - ;; library does not have a name parameter - (('section 'library parameters) - (list 'section 'library (eval parameters))) (('section type name parameters) (list 'section type name (eval parameters))) (((? string? name) values) @@ -913,6 +924,8 @@ pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of: name (lookup-join parameters "type") (lookup-join parameters "location"))) + ((library) (make-cabal-library name + (dependencies parameters))) ((flag) (let* ((default (lookup-join parameters "default")) (default-true-or-false @@ -929,8 +942,6 @@ pertaining to SECTION-TYPE sections. SECTION-TYPE must be one of: default-true-or-false manual-true-or-false))) (else #f))) - (('section (? (cut equal? <> section-type) lib) parameters) - (make-cabal-library (dependencies parameters))) (_ #f)) sexp)) diff --git a/guix/import/hackage.scm b/guix/import/hackage.scm index 0d6c77e399..878a7d2f9c 100644 --- a/guix/import/hackage.scm +++ b/guix/import/hackage.scm @@ -222,13 +222,15 @@ object." '()))) (map cabal-dependency-name custom-setup-dependencies))) -(define (filter-dependencies dependencies own-name) +(define (filter-dependencies dependencies own-names) "Filter the dependencies included with the GHC compiler from DEPENDENCIES, a -list with the names of dependencies. OWN-NAME is the name of the Cabal -package being processed and is used to filter references to itself." - (filter (lambda (d) (not (member (string-downcase d) - (cons own-name ghc-standard-libraries)))) - dependencies)) +list with the names of dependencies. OWN-NAMES is the name of the Cabal +package being processed and its internal libaries and is used to filter +references to itself." + (let ((ignored-dependencies (map string-downcase + (append own-names ghc-standard-libraries)))) + (filter (lambda (d) (not (member (string-downcase d) ignored-dependencies))) + dependencies))) (define* (hackage-module->sexp cabal cabal-hash #:key (include-test-dependencies? #t)) @@ -248,9 +250,12 @@ the hash of the Cabal file." (define source-url (hackage-source-url name version)) + (define own-names (cons (cabal-package-name cabal) + (filter (lambda (x) (not (eqv? x #f))) + (map cabal-library-name (cabal-package-library cabal))))) + (define hackage-dependencies - (filter-dependencies (cabal-dependencies->names cabal) - (cabal-package-name cabal))) + (filter-dependencies (cabal-dependencies->names cabal) own-names)) (define hackage-native-dependencies (lset-difference @@ -260,7 +265,7 @@ the hash of the Cabal file." (cabal-test-dependencies->names cabal) '()) (cabal-custom-setup-dependencies->names cabal)) - (cabal-package-name cabal)) + own-names) hackage-dependencies)) (define dependencies diff --git a/guix/scripts/edit.scm b/guix/scripts/edit.scm index a2e1ffb434..8e777d1405 100644 --- a/guix/scripts/edit.scm +++ b/guix/scripts/edit.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2015, 2016, 2019, 2020, 2021 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2015-2016, 2019-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2020, 2021 Simon Tournier <zimon.toutoune@gmail.com> ;;; @@ -27,6 +27,7 @@ #:use-module (srfi srfi-1) #:use-module (srfi srfi-37) #:export (%editor + spawn-editor guix-edit)) (define %options @@ -77,6 +78,21 @@ line." (location-line location))) (search-path* %load-path (location-file location)))) +(define (spawn-editor locations) + "Spawn (%editor) to edit the code at LOCATIONS, a list of <location> +records, and exit." + (catch 'system-error + (lambda () + (let ((file-names (append-map location->location-specification + locations))) + ;; Use `system' instead of `exec' in order to sanely handle + ;; possible command line arguments in %EDITOR. + (exit (system (string-join (cons (%editor) file-names)))))) + (lambda args + (let ((errno (system-error-errno args))) + (leave (G_ "failed to launch '~a': ~a~%") + (%editor) (strerror errno)))))) + (define-command (guix-edit . args) (category packaging) @@ -94,14 +110,4 @@ line." (when (null? specs) (leave (G_ "no packages specified, nothing to edit~%"))) - (catch 'system-error - (lambda () - (let ((file-names (append-map location->location-specification - locations))) - ;; Use `system' instead of `exec' in order to sanely handle - ;; possible command line arguments in %EDITOR. - (exit (system (string-join (cons (%editor) file-names)))))) - (lambda args - (let ((errno (system-error-errno args))) - (leave (G_ "failed to launch '~a': ~a~%") - (%editor) (strerror errno)))))))) + (spawn-editor locations)))) diff --git a/guix/scripts/home.scm b/guix/scripts/home.scm index f43bf865a7..0f5c3388a1 100644 --- a/guix/scripts/home.scm +++ b/guix/scripts/home.scm @@ -60,6 +60,7 @@ #:autoload (guix scripts pull) (channel-commit-hyperlink) #:autoload (guix scripts system) (service-node-type shepherd-service-node-type) + #:autoload (guix scripts home edit) (guix-home-edit) #:autoload (guix scripts home import) (import-manifest) #:use-module ((guix status) #:select (with-status-verbosity)) #:use-module ((guix build utils) #:select (mkdir-p)) @@ -93,6 +94,8 @@ Some ACTIONS support additional ARGS.\n")) (newline) (display (G_ "\ search search for existing service types\n")) + (display (G_ "\ + edit edit the definition of an existing service type\n")) (display (G_ " container run the home environment configuration in a container\n")) (display (G_ "\ @@ -539,6 +542,8 @@ argument list and OPTS is the option alist." ;; an home environment file. ((search) (apply search args)) + ((edit) + (apply guix-home-edit args)) ((import) (let* ((profiles (delete-duplicates (match (filter-map (match-lambda @@ -611,7 +616,7 @@ deploy the home environment described by these files.\n") extension-graph shepherd-graph list-generations describe delete-generations roll-back - switch-generation search + switch-generation search edit import container) (alist-cons 'action action result)) (else (leave (G_ "~a: unknown action~%") action)))))) diff --git a/guix/scripts/home/edit.scm b/guix/scripts/home/edit.scm new file mode 100644 index 0000000000..a6c05675b3 --- /dev/null +++ b/guix/scripts/home/edit.scm @@ -0,0 +1,66 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts home edit) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module (guix ui) + #:autoload (guix utils) (string-closest) + #:use-module (gnu services) + #:use-module (gnu home services) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:autoload (guix scripts edit) (spawn-editor) + #:export (guix-home-edit)) + +(define (service-type-not-found type) + "Report an error about @var{type} not being found and exit." + (report-error (G_ "~a: no such service type~%") type) + + (let* ((type (symbol->string type)) + (available (fold-home-service-types (lambda (type lst) + (cons (symbol->string + (service-type-name type)) + lst)) + '())) + (closest (string-closest type available))) + (unless (or (not closest) (string=? closest type)) + (display-hint (format #f (G_ "Did you mean @code{~a}?~%") + closest)))) + + (exit 1)) + + +(define (guix-home-edit . args) + (when (null? args) + (leave (G_ "no service types specified, nothing to edit~%"))) + + (with-error-handling + (let* ((types (append-map (lambda (type) + (let ((type (string->symbol type))) + (match (lookup-home-service-types type) + (() (service-type-not-found type)) + ((one) (list one)) + (lst + (warning (N_ "~a: ~a matching service type~%" + "~a: ~a matching service types~%" + (length lst)) + type (length lst)) + lst)))) + args))) + (spawn-editor (filter-map service-type-location types))))) diff --git a/guix/scripts/home/import.scm b/guix/scripts/home/import.scm index 575fe8f688..825ccb1e73 100644 --- a/guix/scripts/home/import.scm +++ b/guix/scripts/home/import.scm @@ -3,6 +3,7 @@ ;;; Copyright © 2021 Andrew Tropin <andrew@trop.in> ;;; Copyright © 2021-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2022 Arjan Adriaanse <arjan@adriaan.se> +;;; Copyright © 2022 Antero Mejr <antero@mailbox.org> ;;; ;;; This file is part of GNU Guix. ;;; @@ -170,8 +171,7 @@ user's files to CONFIGURATION-DIRECTORY; the generated sexp refers to them." ,@(delete-duplicates (concatenate modules))) (home-environment - (packages (map (compose list specification->package+output) - ,packages)) + (packages (specifications->packages ,packages)) (services (list ,@services))))))))) (define* (import-manifest diff --git a/guix/scripts/shell.scm b/guix/scripts/shell.scm index d9af2517c2..1a6df98829 100644 --- a/guix/scripts/shell.scm +++ b/guix/scripts/shell.scm @@ -410,7 +410,7 @@ concatenates MANIFESTS, a list of expressions." (if (null? (manifest-entries manifest)) (match extra-manifests ((one) one) - (lst `(concatenate-manifests ,@extra-manifests))) + (lst `(concatenate-manifests (list ,@extra-manifests)))) (match (manifest->code manifest #:entry-package-version manifest-entry-version-prefix) diff --git a/guix/scripts/system.scm b/guix/scripts/system.scm index eaa245eb44..63e3b9b934 100644 --- a/guix/scripts/system.scm +++ b/guix/scripts/system.scm @@ -10,6 +10,7 @@ ;;; Copyright © 2020 Efraim Flashner <efraim@flashner.co.il> ;;; Copyright © 2021 Brice Waegeneire <brice@waegenei.re> ;;; Copyright © 2021 Simon Tournier <zimon.toutoune@gmail.com> +;;; Copyright © 2022 Tobias Geerinckx-Rice <me@tobias.gr> ;;; ;;; This file is part of GNU Guix. ;;; @@ -945,6 +946,8 @@ Some ACTIONS support additional ARGS.\n")) (display (G_ "\ search search for existing service types\n")) (display (G_ "\ + edit edit the definition of an existing service type\n")) + (display (G_ "\ reconfigure switch to a new operating system configuration\n")) (display (G_ "\ roll-back switch to the previous operating system configuration\n")) @@ -1172,7 +1175,8 @@ Some ACTIONS support additional ARGS.\n")) "extension-graph" "shepherd-graph" "list-generations" "describe" "delete-generations" "roll-back" - "switch-generation" "search" "docker-image")) + "switch-generation" "search" "edit" + "docker-image")) (define (process-action action args opts) "Process ACTION, a sub-command, with the arguments are listed in ARGS. @@ -1270,7 +1274,7 @@ resulting from command-line parsing." (export-shepherd-graph os (current-output-port) #:backend (graph-backend))) (else - (unless (memq action '(build init)) + (unless (memq action '(build init reconfigure)) (warn-about-old-distro #:suggested-command "guix system reconfigure")) @@ -1340,6 +1344,8 @@ argument list and OPTS is the option alist." (display-system-generation generation)))) ((search) (apply (resolve-subcommand "search") args)) + ((edit) + (apply (resolve-subcommand "edit") args)) ;; The following commands need to use the store, but they do not need an ;; operating system configuration file. ((delete-generations) diff --git a/guix/scripts/system/edit.scm b/guix/scripts/system/edit.scm new file mode 100644 index 0000000000..d966ee0aaa --- /dev/null +++ b/guix/scripts/system/edit.scm @@ -0,0 +1,64 @@ +;;; GNU Guix --- Functional package management for GNU +;;; Copyright © 2022 Ludovic Courtès <ludo@gnu.org> +;;; +;;; This file is part of GNU Guix. +;;; +;;; GNU Guix is free software; you can redistribute it and/or modify it +;;; under the terms of the GNU General Public License as published by +;;; the Free Software Foundation; either version 3 of the License, or (at +;;; your option) any later version. +;;; +;;; GNU Guix is distributed in the hope that it will be useful, but +;;; WITHOUT ANY WARRANTY; without even the implied warranty of +;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;;; GNU General Public License for more details. +;;; +;;; You should have received a copy of the GNU General Public License +;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. + +(define-module (guix scripts system edit) + #:use-module (guix diagnostics) + #:use-module (guix i18n) + #:use-module (guix ui) + #:autoload (guix utils) (string-closest) + #:use-module (gnu services) + #:use-module (srfi srfi-1) + #:use-module (ice-9 match) + #:autoload (guix scripts edit) (spawn-editor) + #:export (guix-system-edit)) + +(define (service-type-not-found type) + "Report an error about @var{type} not being found and exit." + (report-error (G_ "~a: no such service type~%") type) + + (let* ((type (symbol->string type)) + (available (fold-service-types (lambda (type lst) + (cons (symbol->string + (service-type-name type)) + lst)) + '())) + (closest (string-closest type available))) + (unless (or (not closest) (string=? closest type)) + (display-hint (format #f (G_ "Did you mean @code{~a}?~%") + closest)))) + + (exit 1)) + + +(define (guix-system-edit . args) + (when (null? args) + (leave (G_ "no service types specified, nothing to edit~%"))) + + (let* ((types (append-map (lambda (type) + (let ((type (string->symbol type))) + (match (lookup-service-types type) + (() (service-type-not-found type)) + ((one) (list one)) + (lst + (warning (N_ "~a: ~a matching service type~%" + "~a: ~a matching service types~%" + (length lst)) + type (length lst)) + lst)))) + args))) + (spawn-editor (filter-map service-type-location types)))) |