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

From: Stefan <stefan-guix@vodafonemail.de>

* guix/build/kconfig.scm (config-string->pair, (pair->config-string,
defconfig->alist, modify-defconfig, verify-config): New file with
functions for handling of defconfig and .config files.
* gnu/packages/bootloaders.scm (make-u-boot-package,
make-u-boot-sunxi64-package): Adding new keyword arguments to pass and/
or modify a defconfig file.
(u-boot-{am335x-boneblack,pinebook,u-boot-novena,rockpro64-rk3399}):
Simplify packages by using the new keyword arguments of the former
functions.
* Makefile.am: Adding guix/build/kconfig.scm to MODULES.
---
 Makefile.am                  |    1 
 gnu/packages/bootloaders.scm |  111 +++++++++++--------------
 guix/build/kconfig.scm       |  185 ++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 234 insertions(+), 63 deletions(-)
 create mode 100644 guix/build/kconfig.scm

diff --git a/Makefile.am b/Makefile.am
index 22dcc43f99..92ba939ab4 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -235,6 +235,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 658de5a808..1f00c9a041 100644
--- a/gnu/packages/bootloaders.scm
+++ b/gnu/packages/bootloaders.scm
@@ -778,8 +778,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)))))
@@ -797,8 +798,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"
@@ -809,9 +813,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))
@@ -865,7 +879,11 @@ 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 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")
@@ -874,25 +892,13 @@ 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
@@ -922,20 +928,10 @@ 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"))
@@ -986,25 +982,17 @@ 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"))
@@ -1092,7 +1080,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
@@ -1103,19 +1099,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..0cfaffe056
--- /dev/null
+++ b/guix/build/kconfig.scm
@@ -0,0 +1,185 @@
+;;; 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.
+     "^ *(#[\\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 mayby a comment.
+        (if (regexp-exec config-comment-regexp config-string)
+            ;; We keep valid comments.
+            (cons #f config-string)
+            (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.
+            (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) equal?)
+                            (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 convinience this abbrevation can be used for not set configurations.
+  \"CONFIG_F\")
+
+Instead of a list, CONFGIS can be a string with one configuration per line."
+  (let* (;; Split the configs into a list of single configuations.
+         ;; To minimize mistakes, we support a string and a list of strings,
+         ;; 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 defconifg 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 and return #t in this case. Otherwise throw 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))))
+    (if (null? mismatching-pairs)
+        #t
+        (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)))))
