diff options
Diffstat (limited to 'guix/scripts')
| -rw-r--r-- | guix/scripts/build.scm | 29 | ||||
| -rw-r--r-- | guix/scripts/describe.scm | 40 | ||||
| -rw-r--r-- | guix/scripts/environment.scm | 27 | ||||
| -rw-r--r-- | guix/scripts/gc.scm | 6 | ||||
| -rw-r--r-- | guix/scripts/import.scm | 4 | ||||
| -rw-r--r-- | guix/scripts/lint.scm | 22 | ||||
| -rw-r--r-- | guix/scripts/style.scm | 527 | ||||
| -rw-r--r-- | guix/scripts/system.scm | 5 |
8 files changed, 121 insertions, 539 deletions
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)))))))) ;;; 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 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. 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 <ludo@gnu.org> +;;; Copyright © 2012-2013, 2015-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; ;;; 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/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 <ludo@gnu.org> +;;; Copyright © 2012-2014, 2020-2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2014 David Thompson <davet@gnu.org> ;;; Copyright © 2018 Kyle Meyer <kyle@kyleam.com> ;;; Copyright © 2019, 2022 Ricardo Wurmus <rekado@elephly.net> @@ -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/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 <tipecaml@gmail.com> ;;; Copyright © 2014, 2015 Eric Bavier <bavier@member.fsf.org> -;;; Copyright © 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020 Ludovic Courtès <ludo@gnu.org> +;;; Copyright © 2013-2020, 2022 Ludovic Courtès <ludo@gnu.org> ;;; Copyright © 2015, 2016 Mathieu Lirzin <mthl@gnu.org> ;;; Copyright © 2016 Danny Milosavljevic <dannym+a@scratchpost.org> ;;; Copyright © 2016 Hartmut Goebel <h.goebel@crazy-compilers.com> @@ -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))))))))) diff --git a/guix/scripts/style.scm b/guix/scripts/style.scm index 9fd652beb1..c0b9ea1a28 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> - (comment str margin?) - comment? - (str comment->string) - (margin? comment-margin?)) - -(define (read-with-comments port) - "Like 'read', but include <comment> 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)) ;;; @@ -561,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 @@ -769,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<? p1 p2) "Return true if P1's location is \"before\" P2's." @@ -782,6 +330,21 @@ PACKAGE." ;;; +;;; Whole-file formatting. +;;; + +(define* (format-whole-file file #:rest rest) + "Reformat all of FILE." + (let ((lst (call-with-input-file file read-with-comments/sequence))) + (with-atomic-file-output file + (lambda (port) + (apply pretty-print-with-comments/splice port lst + #:format-comment canonicalize-comment + #:format-vertical-space canonicalize-vertical-space + rest))))) + + +;;; ;;; Options. ;;; @@ -797,6 +360,9 @@ PACKAGE." (option '(#\e "expression") #t #f (lambda (opt name arg result) (alist-cons 'expression arg result))) + (option '(#\f "whole-file") #f #f + (lambda (opt name arg result) + (alist-cons 'whole-file? #t result))) (option '(#\S "styling") #t #f (lambda (opt name arg result) (alist-cons 'styling-procedure @@ -852,6 +418,9 @@ Update package definitions to the latest style.\n")) of 'silent', 'safe', or 'always'")) (newline) (display (G_ " + -f, --whole-file format the entire contents of the given file(s)")) + (newline) + (display (G_ " -h, --help display this help and exit")) (display (G_ " -V, --version display version information and exit")) @@ -878,27 +447,35 @@ Update package definitions to the latest style.\n")) #:build-options? #f)) (let* ((opts (parse-options)) - (packages (filter-map (match-lambda - (('argument . spec) - (specification->package 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 <package> records is not invalidated as - ;; we modify files. - (sort (if (null? packages) - (fold-packages cons '() #:select? (const #t)) - packages) - (negate package-location<?)))))) + (if (assoc-ref opts 'whole-file?) + (let ((files (filter-map (match-lambda + (('argument . file) file) + (_ #f)) + opts))) + (unless (eq? format-package-definition style) + (warning (G_ "'--styling' option has no effect in whole-file mode~%"))) + (for-each format-whole-file files)) + (let ((packages (filter-map (match-lambda + (('argument . spec) + (specification->package 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 <package> records is not + ;; invalidated as we modify files. + (sort (if (null? packages) + (fold-packages cons '() #:select? (const #t)) + packages) + (negate package-location<?)))))))) 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. |