file-systems: Remove 'title' field and add <file-system-label>.

The 'title' field was easily overlooked and was an endless source of
confusion.  Now, the value of the 'device' field is self-contained.

* gnu/system/file-systems.scm (<file-system>): Change constructor name
to '%file-system'.
[title]: Remove.
(<file-system-label>): New record type with printer.
(report-deprecation, device-expression)
(process-file-system-declaration, file-system): New macros.
(file-system-title): New procedure.
(file-system->spec, spec->file-system): Adjust to handle
<file-system-label>.
* gnu/system.scm (bootable-kernel-arguments): Add case for
'file-system-label?'.
(read-boot-parameters): Likewise.
(mapped-device-user): Avoid 'file-system-title'.
(fs->boot-device): Remove.
(operating-system-boot-parameters): Use 'file-system-device' instead of
'fs->boot-device'.
(device->sexp): Add case for 'file-system-label?'.
* gnu/bootloader/grub.scm (grub-root-search): Add case for
'file-system-label?'.
* gnu/system/examples/bare-bones.tmpl,
gnu/system/examples/beaglebone-black.tmpl,
gnu/system/examples/lightweight-desktop.tmpl,
gnu/system/examples/vm-image.tmpl: Remove uses of 'title'.
* gnu/system/vm.scm (virtualized-operating-system): Remove uses of
'file-system-title'.
* guix/scripts/system.scm (check-file-system-availability): Likewise,
and adjust fix-it hint.
(check-initrd-modules)[file-system-/dev]: Likewise.
* gnu/build/file-systems.scm (canonicalize-device-spec): Remove 'title'
parameter.
[canonical-title]: Remove.
Match on SPEC's type rather than on CANONICAL-TITLE.
(mount-file-system): Adjust caller.
* gnu/build/linux-boot.scm (boot-system): Interpret ROOT here.
* gnu/services/base.scm (file-system->fstab-entry): Remove use of
'file-system-title'.
* doc/guix.texi (File Systems): Remove documentation of the 'title'
field.  Rewrite documentation of 'device' and document
'file-system-label'.

6 files changed, 102 insertions, 24 deletions

diff --git a/gnu/system/examples/bare-bones.tmpl b/gnu/system/examples/bare-bones.tmpl
index 7e0c8fbee0..cb6d2623db 100644
--- a/gnu/system/examples/bare-bones.tmpl
+++ b/gnu/system/examples/bare-bones.tmpl
@@ -16,8 +16,7 @@
                 (bootloader grub-bootloader)
                 (target "/dev/sdX")))
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/examples/beaglebone-black.tmpl b/gnu/system/examples/beaglebone-black.tmpl
index 97201330c7..d1130c76b6 100644
--- a/gnu/system/examples/beaglebone-black.tmpl
+++ b/gnu/system/examples/beaglebone-black.tmpl
@@ -20,8 +20,7 @@
   (initrd-modules (cons "omap_hsmmc" %base-initrd-modules))
 
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/examples/lightweight-desktop.tmpl b/gnu/system/examples/lightweight-desktop.tmpl
index 65a8ee1809..360ee62ffe 100644
--- a/gnu/system/examples/lightweight-desktop.tmpl
+++ b/gnu/system/examples/lightweight-desktop.tmpl
@@ -20,13 +20,11 @@
   ;; Assume the target root file system is labelled "my-root",
   ;; and the EFI System Partition has UUID 1234-ABCD.
   (file-systems (cons* (file-system
-                         (device "my-root")
-                         (title 'label)
+                         (device (file-system-label "my-root"))
                          (mount-point "/")
                          (type "ext4"))
                        (file-system
                          (device (uuid "1234-ABCD" 'fat))
-                         (title 'uuid)
                          (mount-point "/boot/efi")
                          (type "vfat"))
                        %base-file-systems))
diff --git a/gnu/system/examples/vm-image.tmpl b/gnu/system/examples/vm-image.tmpl
index ce3653c8b4..36e272722d 100644
--- a/gnu/system/examples/vm-image.tmpl
+++ b/gnu/system/examples/vm-image.tmpl
@@ -31,8 +31,7 @@ partprobe, and then 2) resizing the filesystem with resize2fs.\n"))
                (target "/dev/sda")
                (terminal-outputs '(console))))
   (file-systems (cons (file-system
-                        (device "my-root")
-                        (title 'label)
+                        (device (file-system-label "my-root"))
                         (mount-point "/")
                         (type "ext4"))
                       %base-file-systems))
diff --git a/gnu/system/file-systems.scm b/gnu/system/file-systems.scm
index 93289dbd5d..2b5948256a 100644
--- a/gnu/system/file-systems.scm
+++ b/gnu/system/file-systems.scm
@@ -20,6 +20,8 @@
   #:use-module (ice-9 match)
   #:use-module (rnrs bytevectors)
   #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-9)
+  #:use-module (srfi srfi-9 gnu)
   #:use-module (guix records)
   #:use-module (gnu system uuid)
   #:re-export (uuid                               ;backward compatibility
@@ -28,7 +30,7 @@
   #:export (file-system
             file-system?
             file-system-device
-            file-system-title
+            file-system-title                     ;deprecated
             file-system-mount-point
             file-system-type
             file-system-needed-for-boot?
@@ -42,6 +44,10 @@
 
             file-system-type-predicate
 
+            file-system-label
+            file-system-label?
+            file-system-label->string
+
             file-system->spec
             spec->file-system
             specification->file-system-mapping
@@ -82,12 +88,10 @@
 ;;; Code:
 
 ;; File system declaration.
-(define-record-type* <file-system> file-system
+(define-record-type* <file-system> %file-system
   make-file-system
   file-system?
-  (device           file-system-device)           ; string
-  (title            file-system-title             ; 'device | 'label | 'uuid
-                    (default 'device))
+  (device           file-system-device) ; string | <uuid> | <file-system-label>
   (mount-point      file-system-mount-point)      ; string
   (type             file-system-type)             ; string
   (flags            file-system-flags             ; list of symbols
@@ -108,6 +112,83 @@
                     (default (current-source-location))
                     (innate)))
 
+;; A file system label for use in the 'device' field.
+(define-record-type <file-system-label>
+  (file-system-label label)
+  file-system-label?
+  (label file-system-label->string))
+
+(set-record-type-printer! <file-system-label>
+                          (lambda (obj port)
+                            (format port "#<file-system-label ~s>"
+                                    (file-system-label->string obj))))
+
+(define-syntax report-deprecation
+  (lambda (s)
+    "Report the use of the now-deprecated 'title' field."
+    (syntax-case s ()
+      ((_ field)
+       (let* ((source (syntax-source #'field))
+              (file   (and source (assq-ref source 'filename)))
+              (line   (and source
+                           (and=> (assq-ref source 'line) 1+)))
+              (column (and source (assq-ref source 'column))))
+         (format (current-error-port)
+                 "~a:~a:~a: warning: 'title' field is deprecated~%"
+                 file line column)
+         #t)))))
+
+;; Helper for 'process-file-system-declaration'.
+(define-syntax device-expression
+  (syntax-rules (quote label uuid device)
+    ((_ (quote label) dev)
+     (file-system-label dev))
+    ((_ (quote uuid) dev)
+     (if (uuid? dev) dev (uuid dev)))
+    ((_ (quote device) dev)
+     dev)
+    ((_ title dev)
+     (case title
+       ((label) (file-system-label dev))
+       ((uuid)  (uuid dev))
+       (else    dev)))))
+
+;; Helper to interpret the now-deprecated 'title' field.  Detect forms like
+;; (title 'label), remove them, and adjust the 'device' field accordingly.
+;; TODO: Remove this once 'title' has been deprecated long enough.
+(define-syntax process-file-system-declaration
+  (syntax-rules (device title)
+    ((_ () (rest ...) #f #f)                 ;no 'title' and no 'device' field
+     (%file-system rest ...))
+    ((_ () (rest ...) dev #f)                     ;no 'title' field
+     (%file-system rest ... (device dev)))
+    ((_ () (rest ...) dev titl)                   ;got a 'title' field
+     (%file-system rest ...
+                   (device (device-expression titl dev))))
+    ((_ ((title titl) rest ...) (previous ...) dev _)
+     (begin
+       (report-deprecation (title titl))
+       (process-file-system-declaration (rest ...)
+                                        (previous ...)
+                                        dev titl)))
+    ((_ ((device dev) rest ...) (previous ...) _ titl)
+     (process-file-system-declaration (rest ...)
+                                      (previous ...)
+                                      dev titl))
+    ((_ (field rest ...) (previous ...) dev titl)
+     (process-file-system-declaration (rest ...)
+                                      (previous ... field)
+                                      dev titl))))
+
+(define-syntax-rule (file-system fields ...)
+  (process-file-system-declaration (fields ...) () #f #f))
+
+(define (file-system-title fs)                    ;deprecated
+  (match (file-system-device fs)
+    ((? file-system-label?) 'label)
+    ((? uuid?)              'uuid)
+    ((? string?)            'device)))
+
 ;; Note: This module is used both on the build side and on the host side.
 ;; Arrange not to pull (guix store) and (guix config) because the latter
 ;; differs from user to user.
@@ -160,23 +241,26 @@ store--e.g., if FS is the root file system."
   "Return a list corresponding to file-system FS that can be passed to the
 initrd code."
   (match fs
-    (($ <file-system> device title mount-point type flags options _ _ check?)
-     (list (if (uuid? device)
-               `(uuid ,(uuid-type device) ,(uuid-bytevector device))
-               device)
-           title mount-point type flags options check?))))
+    (($ <file-system> device mount-point type flags options _ _ check?)
+     (list (cond ((uuid? device)
+                  `(uuid ,(uuid-type device) ,(uuid-bytevector device)))
+                 ((file-system-label? device)
+                  `(file-system-label ,(file-system-label->string device)))
+                 (else device))
+           mount-point type flags options check?))))
 
 (define (spec->file-system sexp)
   "Deserialize SEXP, a list, to the corresponding <file-system> object."
   (match sexp
-    ((device title mount-point type flags options check?)
+    ((device mount-point type flags options check?)
      (file-system
        (device (match device
                  (('uuid (? symbol? type) (? bytevector? bv))
                   (bytevector->uuid bv type))
+                 (('file-system-label (? string? label))
+                  (file-system-label label))
                  (_
                   device)))
-       (title title)
        (mount-point mount-point) (type type)
        (flags flags) (options options)
        (check? check?)))))
diff --git a/gnu/system/vm.scm b/gnu/system/vm.scm
index eb73b5ca7a..7f80147150 100644
--- a/gnu/system/vm.scm
+++ b/gnu/system/vm.scm
@@ -693,13 +693,12 @@ environment with the store shared with the host.  MAPPINGS is a list of
                     (source (file-system-device fs)))
                 (or (string=? target (%store-prefix))
                     (string=? target "/")
-                    (and (eq? 'device (file-system-title fs))
+                    (and (string? source)
                          (string-prefix? "/dev/" source))
 
                     ;; Labels and UUIDs are necessarily invalid in the VM.
                     (and (file-system-mount? fs)
-                         (or (eq? 'label (file-system-title fs))
-                             (eq? 'uuid (file-system-title fs))
+                         (or (file-system-label? source)
                              (uuid? source))))))
             (operating-system-file-systems os)))