build: kconfig: Add new module to modify defconfig files.

* guix/build/kconfig.scm: New file.
* Makefile.am: Register it.
* gnu/packages/bootloaders.scm (make-u-boot-package)
(make-u-boot-sunxi64-package): Add DEFCONFIGS and CONFIGS arguments.  Remove
dead code.
(u-boot-am335x-boneblack, u-boot-pinebook)
(u-boot-novena,u-boot-rockpro64-rk3399): Simplify packages by using the new
keyword arguments.

Signed-off-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>
Modified-by: Maxim Cournoyer <maxim.cournoyer@gmail.com>

3 files changed, 248 insertions, 78 deletions

diff --git a/Makefile.am b/Makefile.am
index c3af23b68e..75c9df573c 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -237,6 +237,7 @@ MODULES =					\
   guix/build/waf-build-system.scm		\
   guix/build/haskell-build-system.scm		\
   guix/build/julia-build-system.scm		\
+  guix/build/kconfig.scm			\
   guix/build/linux-module-build-system.scm	\
   guix/build/store-copy.scm			\
   guix/build/json.scm				\
diff --git a/gnu/packages/bootloaders.scm b/gnu/packages/bootloaders.scm
index 210bc30536..d8fe481abc 100644
--- a/gnu/packages/bootloaders.scm
+++ b/gnu/packages/bootloaders.scm
@@ -74,6 +74,7 @@
   #:use-module (guix utils)
   #:use-module (srfi srfi-1)
   #:use-module (srfi srfi-26)
+  #:use-module (ice-9 optargs)
   #:use-module (ice-9 regex))
 
 (define unifont
@@ -688,8 +689,9 @@ def test_ctrl_c"))
 also initializes the boards (RAM etc).  This package provides its
 board-independent tools.")))
 
-(define-public (make-u-boot-package board triplet)
-  "Returns a u-boot package for BOARD cross-compiled for TRIPLET."
+(define*-public (make-u-boot-package board triplet #:key defconfig configs)
+  "Returns a u-boot package for BOARD cross-compiled for TRIPLET with the
+optional DEFCONFIG file and optional configuration changes from CONFIGS."
   (let ((same-arch? (lambda ()
                       (string=? (%current-system)
                                 (gnu-triplet->nix-system triplet)))))
@@ -707,8 +709,11 @@ board-independent tools.")))
       (arguments
        `(#:modules ((ice-9 ftw)
                     (srfi srfi-1)
-                    (guix build utils)
-                    (guix build gnu-build-system))
+                    (guix build gnu-build-system)
+                    (guix build kconfig)
+                    (guix build utils))
+         #:imported-modules (,@%gnu-build-system-modules
+                             (guix build kconfig))
          #:test-target "test"
          #:make-flags
          (list "HOSTCC=gcc"
@@ -719,9 +724,19 @@ board-independent tools.")))
          (modify-phases %standard-phases
            (replace 'configure
              (lambda* (#:key outputs make-flags #:allow-other-keys)
-               (let ((config-name (string-append ,board "_defconfig")))
-                 (if (file-exists? (string-append "configs/" config-name))
-                     (apply invoke "make" `(,@make-flags ,config-name))
+               (let* ((config-name (string-append ,board "_defconfig"))
+                      (config-file (string-append "configs/" config-name))
+                      (defconfig ,defconfig)
+                      (configs ',configs))
+                 (when defconfig
+                   ;; Replace the board-specific defconfig with the given one.
+                   (copy-file defconfig config-file))
+                 (if (file-exists? config-file)
+                     (begin
+                       (when configs
+                         (modify-defconfig config-file configs))
+                       (apply invoke "make" `(,@make-flags ,config-name))
+                       (verify-config ".config" config-file))
                      (begin
                        (display "Invalid board name. Valid board names are:"
                                 (current-error-port))
@@ -775,7 +790,12 @@ board-independent tools.")))
   (make-u-boot-package "malta" "mips64el-linux-gnuabi64"))
 
 (define-public u-boot-am335x-boneblack
-  (let ((base (make-u-boot-package "am335x_evm" "arm-linux-gnueabihf")))
+  (let ((base (make-u-boot-package
+               "am335x_evm" "arm-linux-gnueabihf"
+               ;; Patch out other device trees to build an image small enough
+               ;; to fit within typical partitioning schemes where the first
+               ;; partition begins at sector 2048.
+               #:configs '("CONFIG_OF_LIST=\"am335x-evm am335x-boneblack\""))))
     (package
       (inherit base)
       (name "u-boot-am335x-boneblack")
@@ -784,43 +804,28 @@ also initializes the boards (RAM etc).
 
 This U-Boot is built for the BeagleBone Black, which was removed upstream,
 adjusted from the am335x_evm build with several device trees removed so that
-it fits within common partitioning schemes.")
-      (arguments
-       (substitute-keyword-arguments (package-arguments base)
-         ((#:phases phases)
-          `(modify-phases ,phases
-             (add-after 'unpack 'patch-defconfig
-               ;; Patch out other devicetrees to build image small enough to
-               ;; fit within typical partitioning schemes where the first
-               ;; partition begins at sector 2048.
-               (lambda _
-                 (substitute* "configs/am335x_evm_defconfig"
-                   (("CONFIG_OF_LIST=.*$") "CONFIG_OF_LIST=\"am335x-evm am335x-boneblack\"\n"))
-                 #t)))))))))
+it fits within common partitioning schemes."))))
 
 (define-public u-boot-am335x-evm
   (make-u-boot-package "am335x_evm" "arm-linux-gnueabihf"))
 
-(define-public (make-u-boot-sunxi64-package board triplet)
-  (let ((base (make-u-boot-package board triplet)))
+(define*-public (make-u-boot-sunxi64-package board triplet
+                                             #:key defconfig configs)
+  (let ((base (make-u-boot-package
+               board triplet #:defconfig defconfig #:configs configs)))
     (package
       (inherit base)
       (arguments
-        (substitute-keyword-arguments (package-arguments base)
-          ((#:phases phases)
-           `(modify-phases ,phases
-              (add-after 'unpack 'set-environment
-                (lambda* (#:key native-inputs inputs #:allow-other-keys)
-                  (let ((bl31
-                         (string-append
-                          (assoc-ref (or native-inputs inputs) "firmware")
-                          "/bl31.bin")))
-                    (setenv "BL31" bl31)
-                    ;; This is necessary when we're using the bundled dtc.
-                    ;(setenv "PATH" (string-append (getenv "PATH") ":"
-                    ;                              "scripts/dtc"))
-                    )
-                  #t))))))
+       (substitute-keyword-arguments (package-arguments base)
+         ((#:phases phases)
+          `(modify-phases ,phases
+             (add-after 'unpack 'set-environment
+               (lambda* (#:key native-inputs inputs #:allow-other-keys)
+                 (let ((bl31
+                        (string-append
+                         (assoc-ref (or native-inputs inputs) "firmware")
+                         "/bl31.bin")))
+                   (setenv "BL31" bl31))))))))
       (native-inputs
        `(("firmware" ,arm-trusted-firmware-sun50i-a64)
          ,@(package-native-inputs base))))))
@@ -832,20 +837,11 @@ it fits within common partitioning schemes.")
   (make-u-boot-sunxi64-package "pine64-lts" "aarch64-linux-gnu"))
 
 (define-public u-boot-pinebook
-  (let ((base (make-u-boot-sunxi64-package "pinebook" "aarch64-linux-gnu")))
-    (package
-      (inherit base)
-      (arguments
-       (substitute-keyword-arguments (package-arguments base)
-         ((#:phases phases)
-          `(modify-phases ,phases
-             (add-after 'unpack 'patch-pinebook-config
-               ;; Fix regression with LCD video output introduced in 2020.01
-               ;; https://patchwork.ozlabs.org/patch/1225130/
-               (lambda _
-                 (substitute* "configs/pinebook_defconfig"
-                   (("CONFIG_VIDEO_BRIDGE_ANALOGIX_ANX6345=y") "CONFIG_VIDEO_BRIDGE_ANALOGIX_ANX6345=y\nCONFIG_VIDEO_BPP32=y"))
-                 #t)))))))))
+  (make-u-boot-sunxi64-package
+   "pinebook" "aarch64-linux-gnu"
+   ;; Fix regression with LCD video output introduced in 2020.01
+   ;; https://patchwork.ozlabs.org/patch/1225130/
+   #:configs '("CONFIG_VIDEO_BPP32=y")))
 
 (define-public u-boot-bananapi-m2-ultra
   (make-u-boot-package "Bananapi_M2_Ultra" "arm-linux-gnueabihf"))
@@ -896,25 +892,18 @@ device while it's being turned on (and a while longer).")
   (make-u-boot-package "mx6cuboxi" "arm-linux-gnueabihf"))
 
 (define-public u-boot-novena
-  (let ((base (make-u-boot-package "novena" "arm-linux-gnueabihf")))
+  (let ((base (make-u-boot-package
+               "novena" "arm-linux-gnueabihf"
+               ;; Patch configuration to disable loading u-boot.img from FAT
+               ;; partition, allowing it to be installed at a device offset.
+               #:configs '("# CONFIG_SPL_FS_FAT is not set"))))
     (package
       (inherit base)
       (description "U-Boot is a bootloader used mostly for ARM boards.  It
 also initializes the boards (RAM etc).
 
 This U-Boot is built for Novena.  Be advised that this version, contrary
-to Novena upstream, does not load u-boot.img from the first partition.")
-      (arguments
-       (substitute-keyword-arguments (package-arguments base)
-         ((#:phases phases)
-          `(modify-phases ,phases
-             (add-after 'unpack 'patch-novena-defconfig
-               ;; Patch configuration to disable loading u-boot.img from FAT partition,
-               ;; allowing it to be installed at a device offset.
-               (lambda _
-                 (substitute* "configs/novena_defconfig"
-                   (("CONFIG_SPL_FS_FAT=y") "# CONFIG_SPL_FS_FAT is not set"))
-                 #t)))))))))
+to Novena upstream, does not load u-boot.img from the first partition."))))
 
 (define-public u-boot-cubieboard
   (make-u-boot-package "Cubieboard" "arm-linux-gnueabihf"))
@@ -1002,7 +991,15 @@ to Novena upstream, does not load u-boot.img from the first partition.")
          ,@(package-native-inputs base))))))
 
 (define-public u-boot-rockpro64-rk3399
-  (let ((base (make-u-boot-package "rockpro64-rk3399" "aarch64-linux-gnu")))
+  (let ((base (make-u-boot-package "rockpro64-rk3399" "aarch64-linux-gnu"
+                                   #:configs '("CONFIG_USB=y"
+                                               "CONFIG_AHCI=y"
+                                               "CONFIG_AHCI_PCI=y"
+                                               "CONFIG_SATA=y"
+                                               "CONFIG_SATA_SIL=y"
+                                               "CONFIG_SCSI=y"
+                                               "CONFIG_SCSI_AHCI=y"
+                                               "CONFIG_DM_SCSI=y"))))
     (package
       (inherit base)
       (arguments
@@ -1013,19 +1010,8 @@ to Novena upstream, does not load u-boot.img from the first partition.")
                 (lambda* (#:key inputs #:allow-other-keys)
                   (setenv "BL31"
                           (search-input-file inputs "/bl31.elf"))))
-              (add-after 'unpack 'patch-config
+              (add-after 'unpack 'patch-header
                 (lambda _
-                  (substitute* "configs/rockpro64-rk3399_defconfig"
-                    (("CONFIG_USB=y") "\
-CONFIG_USB=y
-CONFIG_AHCI=y
-CONFIG_AHCI_PCI=y
-CONFIG_SATA=y
-CONFIG_SATA_SIL=y
-CONFIG_SCSI=y
-CONFIG_SCSI_AHCI=y
-CONFIG_DM_SCSI=y
-"))
                   (substitute* "include/config_distro_bootcmd.h"
                     (("\"scsi_need_init=false")
                      "\"setenv scsi_need_init false")
diff --git a/guix/build/kconfig.scm b/guix/build/kconfig.scm
new file mode 100644
index 0000000000..d0189f558f
--- /dev/null
+++ b/guix/build/kconfig.scm
@@ -0,0 +1,183 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Stefan <stefan-guix@vodafonemail.de>
+;;;
+;;; 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 build kconfig)
+  #:use-module  (ice-9 rdelim)
+  #:use-module  (ice-9 regex)
+  #:use-module  (srfi srfi-1)
+  #:use-module  (srfi srfi-26)
+  #:export (modify-defconfig
+            verify-config))
+
+;; Commentary:
+;;
+;; Builder-side code to modify configurations for the Kconfig build system as
+;; used by Linux and U-Boot.
+;;
+;; Code:
+
+(define (config-string->pair config-string)
+  "Parse a configuration string like \"CONFIG_EXAMPLE=m\" into a key-value pair.
+An error is thrown for invalid configurations.
+
+\"CONFIG_A=y\"            -> '(\"CONFIG_A\" . \"y\")
+\"CONFIG_B=\\\"\\\"\"         -> '(\"CONFIG_B\" . \"\\\"\\\"\")
+\"CONFIG_C=\"             -> '(\"CONFIG_C\" . \"\")
+\"# CONFIG_E is not set\" -> '(\"CONFIG_E\" . #f)
+\"CONFIG_D\"              -> '(\"CONFIG_D\" . #f)
+\"# Any comment\"         -> '(#f . \"# Any comment\")
+\"\"                      -> '(#f . \"\")
+\"# CONFIG_E=y\"          -> (error \"Invalid configuration\")
+\"CONFIG_E is not set\"   -> (error \"Invalid configuration\")
+\"Anything else\"         -> (error \"Invalid configuration\")"
+  (define config-regexp
+    (make-regexp
+     ;; (match:substring (string-match "=(.*)" "=") 1) returns "", but the
+     ;; pattern "=(.+)?" makes it return #f instead.  From a "CONFIG_A=" we like
+     ;; to get "", which later emits "CONFIG_A=" again.
+     (string-append "^ *(#[\\t ]*)?(CONFIG_[a-zA-Z0-9_]+)([\\t ]*="
+                    "[\\t ]*(.*)|([\\t ]+is[\\t ]+not[\\t ]+set))?$")))
+
+  (define config-comment-regexp
+    (make-regexp "^([\\t ]*(#.*)?)$"))
+
+  (let ((match (regexp-exec config-regexp (string-trim-right config-string))))
+    (if match
+        (let* ((comment (match:substring match 1))
+               (key (match:substring match 2))
+               (unset (match:substring match 5))
+               (value (and (not comment)
+                           (not unset)
+                           (match:substring match 4))))
+          (if (eq? (not comment) (not unset))
+              ;; The key is uncommented and set or commented and unset.
+              (cons key value)
+              ;; The key is set or unset ambigiously.
+              (error (format #f "invalid configuration, did you mean \"~a\"?"
+                             (pair->config-string (cons key #f)))
+                     config-string)))
+        ;; This is not a valid or ambigious config-string, but maybe a
+        ;; comment.
+        (if (regexp-exec config-comment-regexp config-string)
+            (cons #f config-string)     ;keep valid comments
+            (error "Invalid configuration" config-string)))))
+
+(define (pair->config-string pair)
+  "Convert a PAIR back to a config-string."
+  (let* ((key (first pair))
+         (value (cdr pair)))
+    (if (string? key)
+        (if (string? value)
+            (string-append key "=" value)
+            (string-append "# " key " is not set"))
+        value)))
+
+(define (defconfig->alist defconfig)
+  "Convert the content of a DEFCONFIG (or .config) file into an alist."
+  (with-input-from-file defconfig
+    (lambda ()
+      (let loop ((alist '())
+                 (line (read-line)))
+        (if (eof-object? line)
+            ;; Building the alist is done, now check for duplicates.
+            ;; Note: the filter invocation is used to remove comments.
+            (let loop ((keys (map first (filter first alist)))
+                       (duplicates '()))
+              (if (null? keys)
+                  ;; The search for duplicates is done.
+                  ;; Return the alist or throw an error on duplicates.
+                  (if (null? duplicates)
+                      alist
+                      (error
+                       (format #f "duplicate configurations in ~a" defconfig)
+                       duplicates))
+                  ;; Continue the search for duplicates.
+                  (loop (cdr keys)
+                        (if (member (first keys) (cdr keys))
+                            (cons (first keys) duplicates)
+                            duplicates))))
+            ;; Build the alist.
+            (loop (cons (config-string->pair line) alist)
+                  (read-line)))))))
+
+(define (modify-defconfig defconfig configs)
+  "This function can modify a given DEFCONFIG (or .config) file by adding,
+changing or removing the list of strings in CONFIGS.  This allows customization
+of Kconfig based projects like the kernel Linux or the bootloader 'Das U-Boot'.
+
+These are examples for CONFIGS to add, change or remove configurations to/from
+DEFCONFIG:
+
+'(\"CONFIG_A=\\\"a\\\"\"
+  \"CONFIG_B=0\"
+  \"CONFIG_C=y\"
+  \"CONFIG_D=m\"
+  \"CONFIG_E=\"
+  \"# CONFIG_G is not set\"
+  ;; For convenience this abbrevation can be used for not set configurations.
+  \"CONFIG_F\")
+
+Instead of a list, CONFIGS can be a string with one configuration per line."
+  (let* (;; Split the configs into a list of single configurations.  Both a
+         ;; string and or a list of strings is supported, each with newlines
+         ;; to separate configurations.
+         (config-pairs (map config-string->pair
+                            (append-map (cut string-split <>  #\newline)
+                                        (if (string? configs)
+                                            (list configs)
+                                            configs))))
+         ;; Generate a blocklist from all valid keys in config-pairs.
+         (blocklist (delete #f (map first config-pairs)))
+         ;; Generate an alist from the defconfig without the keys in blocklist.
+         (filtered-defconfig-pairs (remove (lambda (pair)
+                                             (member (first pair) blocklist))
+                                           (defconfig->alist defconfig))))
+    (with-output-to-file defconfig
+      (lambda ()
+        (for-each (lambda (pair)
+                    (display (pair->config-string pair))
+                    (newline))
+                  (append filtered-defconfig-pairs config-pairs))))))
+
+(define (verify-config config defconfig)
+  "Verify that the CONFIG file contains all configurations from the DEFCONFIG
+file.  When the verification fails, raise an error with the mismatching keys
+and their values."
+  (let* ((config-pairs (defconfig->alist config))
+         (defconfig-pairs (defconfig->alist defconfig))
+         (mismatching-pairs
+          (remove (lambda (pair)
+                    ;; Remove all configurations, whose values are #f and
+                    ;; whose keys are not in config-pairs, as not in
+                    ;; config-pairs means unset, ...
+                    (and (not (cdr pair))
+                         (not (assoc-ref config-pairs (first pair)))))
+                  ;; ... from the defconfig-pairs different to config-pairs.
+                  (lset-difference equal?
+                                   ;; Remove comments by filtering with first.
+                                   (filter first defconfig-pairs)
+                                   config-pairs))))
+    (unless (null? mismatching-pairs)
+      (error (format #f "Mismatching configurations in ~a and ~a"
+                     config defconfig)
+             (map (lambda (mismatching-pair)
+                    (let* ((key (first mismatching-pair))
+                           (defconfig-value (cdr mismatching-pair))
+                           (config-value (assoc-ref config-pairs key)))
+                      (cons key (list (list config-value defconfig-value)))))
+                  mismatching-pairs)))))