patched-guix/parameterization.patch

diff --git a/Makefile.am b/Makefile.am
index 8924974e8a..a9cb615b3e 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -17,6 +17,7 @@
 # Copyright © 2020, 2021, 2023 Maxim Cournoyer <maxim.cournoyer@gmail.com>
 # Copyright © 2021 Chris Marusich <cmmarusich@gmail.com>
 # Copyright © 2021 Andrew Tropin <andrew@trop.in>
+# Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com>
 #
 # This file is part of GNU Guix.
 #
@@ -114,6 +115,7 @@ MODULES =					\
   guix/repl.scm					\
   guix/rpm.scm					\
   guix/transformations.scm			\
+  guix/parameters.scm				\
   guix/inferior.scm				\
   guix/describe.scm				\
   guix/quirks.scm				\
diff --git a/guix/parameters.scm b/guix/parameters.scm
new file mode 100644
index 0000000000..24fe1cbac9
--- /dev/null
+++ b/guix/parameters.scm
@@ -0,0 +1,1180 @@
+;;; GNU Guix --- Functional package management for GNU
+;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
+;;; Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com>
+;;;
+;;; 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 parameters)
+  #:use-module (guix diagnostics)
+  #:use-module (guix i18n)
+  #:use-module (guix packages)
+  #:use-module (guix profiles)
+  #:use-module (guix records)
+  #:use-module (srfi srfi-1)
+  #:use-module (srfi srfi-13)
+  #:use-module (srfi srfi-26)
+  #:use-module (srfi srfi-34)
+  #:use-module (srfi srfi-35)
+  #:use-module (ice-9 hash-table)
+  #:use-module (ice-9 match)
+  #:use-module (ice-9 receive)
+  #:autoload (guix transformations) (options->transformation)
+  #:export (parameter-type
+            package-parameter
+            parameter-spec
+            boolean-parameter-type
+
+            parameter-variant
+            parameter-variant-match
+            parameter-spec-property
+            package-parameter-spec
+            package-parameter-alist
+            all-spec-parameters
+            all-spec-parameters-with-types
+            base-parameter-alist
+            parameter-process-list
+            package-override-plist
+            parameter-spec-validate
+            package-resolve-parameter-list
+            %global-parameters
+            define-global-parameter
+
+            package-with-parameters
+            parameterize-package
+            apply-variants
+            parameter-spec-parameter-alist
+            parameter-if
+            parameter-match
+            parameter-match-case
+            parameter-modify-inputs
+            parameter-substitute-keyword-arguments
+            ))
+
+;;; Commentary:
+;;;
+;;; This module provides a way to express high-level "package parameters",
+;;; which allow users to customize how packages are built.  Parameters are an
+;;; interface that package developers define, where each parameter has a name
+;;; and type.  The user interface then converts parameter values from string
+;;; to Scheme values and records them in the package properties.
+;;;
+;;; Package parameters are discoverable; their description is
+;;; internationalized.  The possible values of a parameter can be enumerated,
+;;; and thus the Cartesian product of all possible parameter values for a
+;;; package can be enumerated as well.
+;;;
+;;; Code:
+
+(define (give-me-a-symbol ex)
+  "Take a string or symbol EX and return a symbol."
+  (cond ((symbol? ex) ex)
+        ((string? ex) (string->symbol ex))
+        (else (raise (formatted-message
+                      (G_ "Not a symbol or a string: ~s")
+                      ex)))))
+
+(define-record-type* <parameter-type> parameter-type
+  make-parameter-type
+  parameter-type?
+  this-parameter-type
+  (name          parameter-type-name
+                 (sanitize give-me-a-symbol))
+  (accepted-values      parameter-type-accepted-values)
+  (negation      parameter-type-negation
+                 (default (first (parameter-type-accepted-values this-parameter-type)))
+                 (thunked))
+  (default       parameter-type-default
+                 (default (match (parameter-type-accepted-values this-parameter-type)
+                            [(first second . rest)
+                             (if (not (parameter-type-negation this-parameter-type))
+                                 first
+                                 second)]
+                            [oth (raise (formatted-message
+                                         (G_ "Bad accepted-values form: ~s")
+                                         oth))]))
+                 (thunked))
+    (description   parameter-type-description
+                   (default "")))
+
+(define boolean-parameter-type
+  (parameter-type
+   (name 'boolean)
+   (accepted-values '(off on))
+   (description "Boolean Parameter Type")))
+
+;; Package parameter interface.
+(define-record-type* <package-parameter> package-parameter
+  make-package-parameter
+  package-parameter?
+  (name         package-parameter-name
+                (sanitize give-me-a-symbol))
+  (type         package-parameter-type
+                (default boolean-parameter-type))
+  (variants     package-parameter-variants
+                (default '())
+                (sanitize sanitize-parametric-variants))
+  (dependencies package-parameter-dependencies
+                (default '())
+                (sanitize dependency-sanitizer)
+                (thunked))
+  (predicate    package-parameter-predicate
+                (sanitize predicate-sanitizer)
+                (default (const #f)))
+  (description  package-parameter-description (default "")))
+
+(define %global-parameters
+  (alist->hash-table '()))
+
+;; SANITIZERS
+
+(define (sanitize-parametric-variants ls)
+  "Raise an error if LS is not a list."
+  (cond ((list? ls) ls)
+        (else (raise (formatted-message
+                      (G_ "Not a list: ~s")
+                      ls)))))
+
+(define (predicate-sanitizer p)
+  (match p
+    [(? procedure? p) p]
+    [#t (and (warning
+              (G_ "Please use (const #t) instead of #t!~%"))
+             (const #t))]
+    [#f (and (warning
+              (G_ "Please use (const #f) instead of #f!~%"))
+             (const #f))]
+    [_ (raise (formatted-message
+               (G_ "Not a predicate: ~s")
+               p))]))
+
+
+;; % USEFUL HELPER FUNCTIONS %
+
+(define (return-list lst)
+  "Take a value LST, return LST if it a list and (list LST) otherwise."
+  (if (list? lst)
+      lst
+      (list lst)))
+
+(define (append-everything . things)
+  "Take a number of THINGS, and append them all."
+  (apply append
+         (map return-list things)))
+
+(define (get-parameter-sym psym)
+  "If the argument is a cons cell, return the CAR otherwise return the argument."
+  (match psym
+    [(a . b) a]
+    [a a]))
+
+(define* (merge-same-key lst #:optional (carry '()))
+  "Merge the cells of LST with the same value in their CAR."
+  (match lst
+    [((a . b) . rest)
+     (if (null? (filter (lambda (y) (equal? a (first y)))
+                        carry))
+         (merge-same-key rest (cons (cons a b) carry))
+         (merge-same-key rest (assq-set! carry
+                                         a
+                                         (append (assq-ref carry a) b))))]
+    [() carry]))
+
+(define-syntax lambdize-lambdas
+  (syntax-rules (:cruise)
+    [(% :cruise x . rest)
+     (if (keyword? x)
+         (lambdize-lambdas x . rest)
+         (cons x (lambdize-lambdas :cruise . rest)))]
+    [(% :cruise) '()]
+    [(% #:lambda fn . rest)
+     (cons #:lambda
+           (cons fn
+                 (lambdize-lambdas :cruise . rest)))]
+    [(% x . rest)
+     (cons 'x (lambdize-lambdas . rest))]
+    [(%) '()]))
+
+(define-syntax parameter-variant
+  (syntax-rules ()
+    [(%) '()]
+    [(% psym variants ...)
+     (let ((parsed-variants
+            (parse-keyword-list (lambdize-lambdas variants ...))))
+       (map (cut cons <>
+                 parsed-variants)
+       (return-list 'psym)))]))
+
+(define* (parse-keyword-list kw-lst)
+  "Parses a list of keywords, KW-LST and returns an alist."
+  (define (list-till-keyword lst)
+    (receive (a b)
+        (break keyword? lst)
+      (cons a b)))
+  (define* (break-keywords lst)
+    (match lst
+      [((? keyword? key) vals ..1)
+       (match (list-till-keyword vals)
+         [(first . rest)
+         (cons (cons (keyword->symbol key)
+                     first)
+               (break-keywords rest))])]
+      [((? keyword? just-a-key)) ; (... #:key)
+       (cons (cons (keyword->symbol just-a-key) '())
+             '())]
+      [(singleton) '()]
+      [()          '()]
+      [_           (raise (formatted-message
+                           (G_ "Error trying to break keywords at ~a")
+                           lst))]))
+  (merge-same-key (break-keywords kw-lst)))
+
+;; The lock here is used to signal when merge-same-key is to be used
+;; having a :lock means merge-same-key has been used further up the tree
+;; note that :lock is not a keyword but a symbol, as we are using keywords elsewhere
+(define-syntax parameter-variant-match
+  (syntax-rules (:lock)
+    ((% :lock (x ...))
+     (return-list
+      (parameter-variant x ...)))
+    ((% :lock (x ...) rest ...)
+     (append
+      (return-list (parameter-variant x ...))
+      (parameter-variant-match :lock rest ...)))
+    ((% rest ...)
+     (map
+      (match-lambda
+        [(v . lst)
+         (cons v
+               (merge-same-key lst))])
+      (merge-same-key
+       (parameter-variant-match :lock rest ...))))))
+
+(define (local-sanitizer ls)
+  "Sanitize a list of local parameters, LS."
+  (if (list? ls)
+      (map (lambda (val)
+             (cond ((package-parameter? val) val)
+                   ((symbol? val) (package-parameter (name val)))
+                   ((string? val) (package-parameter (name (string->symbol val))))
+                   (else (raise (formatted-message
+                                 (G_ "Not a parameter, symbol or string: ~s")
+                                 val)))))
+           ls)
+      (raise (formatted-message
+                      (G_ "Spec's local field is not a list: ~s")
+                      ls))))
+
+(define* (variant-sanitizer lv)
+  "Sanitize a list of variants."
+  ;; #:yes -> use default variant
+  ;; #:no -> don't use variant
+  ;; #:special -> use variant in rest
+  (define (sym->parameter psym)
+    "Take a symbol PSYM and return the corresponding parameter."
+    (or (find (lambda (g) (eqv? psym
+                           (package-parameter-name g)))
+              lv)
+        (hash-ref %global-parameters psym)
+        (raise (formatted-message
+                                 (G_ "sym->parameter: not a symbol: ~s")
+                                 psym))))
+  (define-macro (assq-override! asslst key val)
+    `(set! ,asslst
+       (assq-set! ,asslst ,key ,val)))
+  (lambda (ls)
+    (let ((triad (parse-keyword-list ls)))
+      (if (find (lambda (g) (not (or (eqv? (first g) 'yes)
+                                (eqv? (first g) 'no)
+                                (eqv? (first g) 'special))))
+                triad)
+          (raise (formatted-message
+                      (G_ "Invalid keyword in use-variants: ~s")
+                      (first g))))
+      (let ((vars-lst '()))
+        (map
+         (match-lambda
+           [('yes rest ...)
+            (map
+             (lambda (p)
+               (if (not (symbol? p))
+                   (raise (formatted-message
+                      (G_ "Not a symbol: ~s")
+                      p))
+                   (assq-override! vars-lst p #:yes)))
+             rest)]
+           [('no rest ...)
+            (map
+             (lambda (p)
+               (if (not (symbol? p))
+                   (raise (formatted-message
+                      (G_ "Not a symbol: ~s")
+                      p))
+                   (assq-override! vars-lst p #:no)))
+             rest)]
+           [('special rest ...)
+            (map
+             (match-lambda
+               [(a . b)
+                (assq-override! vars-lst
+                                a
+                                b)])
+             rest)]
+           [_ (error "wrongly formatted use-variant!")])
+         triad)
+        (map
+         (lambda (x)
+           (match (assq-ref vars-lst (package-parameter-name x))
+             [#f (assq-override! vars-lst
+                            (package-parameter-name x)
+                            (package-parameter-variants x))]
+             [#:yes (assq-override! vars-lst
+                            (package-parameter-name x)
+                            (package-parameter-variants x))]
+             [#:no #f] ; do nothing
+             [varn (assq-override! vars-lst
+                            (package-parameter-name x)
+                            varn)]))
+         lv)
+        vars-lst))))
+
+(define (dependency-sanitizer deps)
+  "Sanitize the dependency-list of a package-parameter."
+  (unless (eqv? deps '())
+    (if (not (list? deps))
+        (raise (formatted-message
+                (G_ "Dependencies not a list: ~s")
+                deps)))
+    (if (keyword? (first deps))
+      (if (match (first deps)
+                 [#:package (and (warning
+                                  (G_ "Package Dependencies are not supported!~%"))
+                                 #t)]
+                 [#:parameter #t]
+                 [_ #f])
+             (parse-keyword-list deps)
+        (raise (formatted-message
+                (G_ "Bad dependency keyword: ~s")
+                (first deps))))
+      (dependency-sanitizer (cons #:parameter deps)))))
+
+(define-record-type* <parameter-spec> parameter-spec
+  make-parameter-spec
+  parameter-spec?
+  this-parameter-spec
+  (local    parameter-spec-local
+    (default '())
+    (sanitize local-sanitizer)
+    (thunked))
+  (defaults parameter-spec-defaults
+    (default '())
+    (thunked))
+  (required parameter-spec-required
+            (default '())
+            (thunked))
+  (optional parameter-spec-optional
+            (default '())
+            (thunked))
+  (one-of parameter-spec-one-of
+          (default '())
+          (thunked))
+  (combinations-with-substitutes
+   parameter-spec-combinations-with-substitutes
+             (default parameter-spec-defaults)
+             (thunked))
+  (use-variants parameter-spec-use-variants
+                  (default '())
+                  (sanitize (variant-sanitizer
+                              (parameter-spec-local this-parameter-spec)))
+                  (thunked))
+  (parameter-alist parameter-spec-parameter-alist
+                   (default (base-parameter-alist this-parameter-spec))
+                   (thunked)))
+
+(define-syntax parameter-spec-property
+  (syntax-rules ()
+    [(parameter-spec-property body ...)
+     (cons 'parameter-spec
+           (parameter-spec body ...))]))
+
+(define (apply-variants pkg vars)
+  "Apply a list of variants, VARS to the given package PKG."
+  (define (exact-sub v)
+    (match v
+      [(lst ...) ; to traverse the tree
+       (map exact-sub v)]
+      [#:package-name
+       (package-name pkg)]
+      [#:package
+       pkg]
+      [#:parameter-value
+       (match vars
+         [((_ . rest) . others)
+          rest])]
+      [x x]))
+  ;; substitute keywords - transforms
+  (define* (substitute-keywords-for-transforms in #:optional (ret '()))
+    (match in
+      [(a . rest)
+       (substitute-keywords-for-transforms
+        rest
+        (cons (exact-sub a) ret))]
+      [() (match (reverse ret)
+               [(a . rest)
+                (cons a (string-join rest "="))])]))
+  ;; substitute keywords
+  (define* (substitute-keywords in #:optional (ret '()))
+    (match in
+      [(a . rest)
+       (substitute-keywords
+        a
+        (cons (exact-sub a) ret))]
+      [() (reverse ret)]))
+
+  (match vars
+    [(pcell (option optargs ...) . rest)
+     (match option
+       ['build-system
+         ;; halt execution if it does not match
+         (if (member (package-build-system the-package)
+                     optargs) ; will be a list of build systems
+             (apply-variants pkg (cons pcell
+                                       rest))
+             pkg)]
+       ['transform
+        (apply-variants
+         ((options->transformation
+           (map substitute-keywords-for-transforms optargs))
+          pkg)
+         (cons pcell
+               rest))]
+       ['lambda
+           (apply-variants
+            (fold
+             (lambda (fn pack)
+               (case (first (procedure-minimum-arity fn))
+                 [(0) (fn)]
+                 [(1) (fn pack)]
+                 [(2) (fn pack (match pcell [(_ . rest) rest]))]
+                 [else (raise (formatted-message
+                               (G_ "Procedure ~s has invalid arity.")
+                               fn))]))
+             pkg
+             optargs)
+            (cons pcell
+                  rest))]
+       [oth
+        (raise (formatted-message
+                (G_ "Invalid Option: ")
+                oth))])]
+    [(pcell (option) . rest)
+     (apply-variants pkg (cons pcell rest))]
+    [(pcell) pkg]
+    [_ (raise (formatted-message
+                (G_ "Poorly formatted variant spec: ~s")
+                vars))]))
+
+(define-syntax package-with-parameters
+  (syntax-rules ()
+    [(% spec body ...)
+     (let* [(the-package-0 (package body ...))
+            (the-package (package
+                           (inherit the-package-0)
+                           (replacement (package-replacement the-package-0))
+                           (location    (package-location    the-package-0))
+                           (properties
+                            (cons (cons 'parameter-spec
+                                        spec)
+                                  (package-properties the-package-0)))))]
+       (parameterize-package the-package
+                             (parameter-spec-parameter-alist spec)
+                             #:force-parameterization? #t))]))
+
+(define* (parameterize-package the-initial-package
+                               the-initial-list
+                               #:key (force-parameterization? #f))
+  "Evaluates THE-INITIAL-PACKAGE with the parameter-list THE-INITIAL-LIST."
+  (define-macro (assq-override! asslst key val)
+    `(set! ,asslst
+       (assq-set! ,asslst ,key ,val)))
+
+  (define smoothen
+    (match-lambda
+      [(a . #:off)
+       (cons a
+             (parameter-type-negation
+              (package-parameter-type (parameter-spec-get-parameter spec a))))]
+      [(a . #:default)
+       (cons a
+             (parameter-type-default
+              (package-parameter-type (parameter-spec-get-parameter spec a))))]
+      [cell cell]))
+
+  (let* [(the-initial-spec
+          (package-parameter-spec the-initial-package))
+         (the-original-parameter-list
+          (package-parameter-alist the-initial-package))
+         (the-parameter-list
+          (package-resolve-parameter-list the-initial-package
+                                          the-initial-list))]
+    ;; exit and return the same package if no impactful changes
+    (if (and (not force-parameterization?)
+             (null? (filter (match-lambda
+                              [(parameter-sym . parameter-value)
+                               (not (eqv? (assq-ref
+                                           the-original-parameter-list
+                                           parameter-sym)
+                                          parameter-value))])
+                            the-parameter-list)))
+             the-initial-package
+        (let* [(the-spec ; this value gets called very often
+                (parameter-spec
+                 (inherit the-initial-spec)
+                 (parameter-alist
+                  the-parameter-list)))
+               (the-package
+                (package
+                  (inherit the-initial-package)
+                  (replacement         (package-replacement the-initial-package))
+                  (location            (package-location    the-initial-package))
+                  (properties (assq-set! (package-properties the-initial-package)
+                                         'parameter-spec
+                                         the-spec))))
+               (the-variants
+                ;; first get list of normal variants (local, etc)
+                ;; then match over use-variants
+                ;; if rest #:yes, check the-parameter-list for val
+                ;; if rest #:no, purge from prev list
+                ;; if rest #:special, /replace/ value
+                (let ((var-lst (parameter-spec-use-variants the-spec)))
+                  (map (match-lambda
+                         [(key . rest)
+                          (set! var-lst
+                            (assq-set! var-lst
+                                       key
+                                       (package-parameter-variants
+                                        (parameter-spec-get-parameter the-spec key))))])
+                       (filter (lambda (x)
+                                 ((package-parameter-predicate
+                                   (parameter-spec-get-parameter
+                                    the-spec
+                                    (first x)))
+                                  the-package))
+                               (filter
+                                (lambda (x)
+                                  (not (assq-ref var-lst (first x)))) ; not in the variant-lst?
+                                the-parameter-list)))
+                  (map
+                   (match-lambda
+                     [(key . rest)
+                      (match rest
+                        [#:yes (assq-override! var-lst
+                                               key
+                                               (package-parameter-variants
+                                                (parameter-spec-get-parameter the-spec key)))]
+                        [#:no (set! var-lst
+                                (assq-remove! var-lst
+                                              key))]
+                        [_ #f])])
+                   var-lst)
+
+                  var-lst))
+               (applicable-variants
+                (map (match-lambda
+                       [(key . rest)
+                        (cons (cons key
+                                    (assq-ref the-parameter-list key))
+                              (apply append
+                                     (map (match-lambda
+                                            [(_ . remaining)
+                                             (return-list remaining)])
+                                          rest)))])
+                     ;; does it have values?
+                     (filter (match-lambda
+                               [(_ . rest)
+                                (not (null? rest))])
+                             (map ;; get list of applicable values
+                              (match-lambda
+                                [(p . lst)
+                                (let ((absv (assq-ref the-parameter-list p))
+                                      ;; if absv is -ve, only -ve values allowed
+                                      ;; if absv is +ve, only +ve and _ allowed
+                                      (negv (parameter-type-negation
+                                             (package-parameter-type
+                                              (parameter-spec-get-parameter the-spec p))))
+                                      (defv (parameter-type-default
+                                             (package-parameter-type
+                                              (parameter-spec-get-parameter the-spec p)))))
+                                  (cons p
+                                        (filter
+                                         (lambda (ls)
+                                           (match (first ls)
+                                             ['_ (not (eqv? absv negv))]
+                                             [#:off (eqv? absv negv)]
+                                             [#:default (eqv? absv defv)]
+                                             [oth (eqv? absv oth)]))
+                                         lst)))])
+                              (filter (lambda (x) (assq-ref the-parameter-list (first x)))
+                                      the-variants)))))]
+          (fold (lambda (vlst pack)
+                  (apply-variants pack vlst))
+                the-package
+                applicable-variants)))))
+
+(define (package-parameter-spec package)
+  "Takes a package PACKAGE and returns its parameter-spec."
+  (or (assq-ref (package-properties package) 'parameter-spec)
+      (parameter-spec))) ; returns empty spec
+
+(define (package-parameter-alist package)
+  "Takes a package PACKAGE and returns its parameter-list."
+  (parameter-spec-parameter-alist
+   (package-parameter-spec package)))
+
+;;; PROCESSING PIPELINE
+
+;; Convention:
+;;   Works on Parameters? -> parameter-spec/fun
+;;   Works on Parameter-Spec? -> parameter-spec/fun
+(define (parameter-spec-get-parameter pspec pcons)
+  "Takes a parameter cell PCONS and returns the corresponding package-parameter."
+  (let ((psym (get-parameter-sym pcons)))
+  (or (find (lambda (x)
+               (eqv? psym
+                     (package-parameter-name x)))
+             (parameter-spec-local pspec))
+      (hash-ref %global-parameters psym)
+      (raise (formatted-message
+                (G_ "Parameter not found: ~s")
+                psym)))))
+
+(define (parameter-spec-negation-supported? pspec x)
+  "Is negation supported for the given parameter X?"
+  (let ((negv
+         (parameter-type-negation (package-parameter-type (parameter-spec-get-parameter pspec x)))))
+    (if negv
+        negv
+        '_)))
+
+(define (get-parameter-spec-dependencies pspec psym)
+  "Get the dependencies of the corresponding parameter to a given parameter symbol, PSYM."
+  (let ([p (parameter-spec-get-parameter pspec psym)])
+    (return-list
+     (assq-ref (package-parameter-dependencies p)
+               'parameter))))
+
+;; 1. Fetching
+
+(define (base-parameter-alist pspec) ; returns base case
+  "Returns the BASE-PARAMETER-ALIST for a given parameter-spec PSPEC."
+  ;; '((a . psym) (b . #f) ...)
+  (let* ((v1 (parameter-process-list ; returns funneled list
+              (append-everything
+               (parameter-spec-defaults pspec)
+               (parameter-spec-required pspec))))
+         (v2 (parameter-process-list
+              (append-everything
+               (apply append
+                      ;; XXX: change to a filter-map
+                      (filter (cut first <>)
+                              (map (cut get-parameter-spec-dependencies pspec <>)
+                                   (return-list v1))))
+               v1))))
+    ;; funnel will signal duplication err
+    ;; check if base case is valid
+    (parameter-spec-validate pspec v2)
+    v2))
+
+;; 2. Processing
+
+;; IMPORTANT CHANGE: Symbolic Negation no longer supported (psym!)
+(define (parameter-process-list lst)
+  "Processes and formats a list of parameters, LST."
+  (define (return-cell p)
+    (match p
+      [(a b) (cons a b)]
+      [(a . b) p]
+      [a (cons a '_)]))
+  (define (funnel plst)
+    (define* (group-values lst #:optional (carry '()))
+      (match lst
+        [((a . b) . rest)
+         (let ((v (assq-ref carry a)))
+           (group-values rest
+                      (assq-set! carry
+                                 a
+                                 (cons b
+                                       (if v v '())))))]
+        [() carry]
+        [_ (raise (formatted-message
+                   (G_ "Poorly formatted assoc-list in group-values! ~s")
+                   lst))]))
+    (define (figure-out psym p)
+      (or (and (< (length p) 3)
+               (or (and (eq? (length p) 1) (first p))
+                   (and (member '_ p)
+                        (first (delq '_ p)))))
+          (raise (formatted-message
+                  (G_ "Too many values for a single parameter: ~s with ~s")
+                  psym p))))
+    (map (match-lambda [(parameter . values)
+                        (cons parameter
+                              (figure-out parameter ; for the error message
+                                          (delete-duplicates values)))])
+         (group-values plst)))
+  (funnel (map
+               return-cell
+               lst)))
+
+;; 3. Overriding
+
+(define (all-spec-parameters pspec) ; for the UI
+  "Returns all the parameters in a parameter-spec, PSPEC."
+  ;; '(sym-a sym-b ...)
+  (delete-duplicates
+   (map get-parameter-sym ; we do not care about the values
+        (append-everything ; works same as before
+         (map package-parameter-name
+              (parameter-spec-local pspec))
+         (parameter-spec-defaults pspec)
+         (parameter-spec-required pspec)
+         ;; We are NOT pulling dependencies at this phase
+         ;; They will not be influenced by the user parameter alist
+         (filter (lambda (x) (not (eqv? x '_)))
+                 (apply append (parameter-spec-one-of pspec)))
+         (parameter-spec-optional pspec)))))
+
+(define* (all-spec-parameters-with-types pspec #:key (show-booleans? #t))
+  (if show-booleans?
+      (map (lambda (x)
+             (string-append
+              (symbol->string x)
+              ":"
+              (symbol->string
+               (parameter-type-name
+                (package-parameter-type (parameter-spec-get-parameter pspec (cons x #f)))))))
+           (all-spec-parameters pspec))
+      (map (lambda (x)
+             (string-append
+              (symbol->string x)
+              ((lambda (x)
+                 (if (eqv? x 'boolean)
+                     ""
+                     (string-append ":" (symbol->string x))))
+               (parameter-type-name
+                (package-parameter-type (parameter-spec-get-parameter pspec (cons x #f)))))))
+           (all-spec-parameters pspec))))
+
+
+;; Now we compare it against the PLIST
+;; NOTE: This is the only instance where GLOBAL PARAMETERS may be used
+;;       Since referring to the package is not possible, we pass it instead of pspec
+(define (package-override-plist pkg plist)
+  "Takes a package PKG and parameter-list PLIST and overrides PLIST according to the package."
+  (let* ((pspec (package-parameter-spec pkg))
+         (all-p (all-spec-parameters pspec))
+         (filtered-plist (filter (match-lambda
+                                   [(sym . rest)
+                                    (or (member sym all-p)
+                                            (and (hash-ref %global-parameters sym)
+                                                 ((package-parameter-predicate
+                                                   (hash-ref %global-parameters sym))
+                                                  pkg)))])
+                                 (parameter-process-list plist)))
+         (filtered-first (map first filtered-plist))
+         (remaining-p (filter (lambda (x) (not (member x filtered-first)))
+                              all-p)))
+    (append-everything filtered-plist
+                       (map (lambda (x) (if (parameter-spec-negation-supported? pspec x)
+                                       (cons x #:off)
+                                       (cons x '_)))
+                            remaining-p))))
+
+;; 4. Funneling
+
+(define (override-spec-multi-match pspec plst)
+  "Overrides various keyword values in the parameter-list PLST."
+  (map
+    (match-lambda
+      [(a . '_)
+       (cons a
+             (match
+                 (parameter-type-accepted-values
+                  (package-parameter-type (parameter-spec-get-parameter pspec a)))
+               [(_ . (val . rest)) val]))]
+      [(a . #:off)
+       (cons a
+             (parameter-type-negation (package-parameter-type (parameter-spec-get-parameter pspec a))))]
+      [(a . #:default)
+       (cons a
+             (parameter-type-default (package-parameter-type (parameter-spec-get-parameter pspec a))))]
+      [cell cell])
+    plst))
+
+;; 5. Validation
+
+(define (parameter-spec-validate pspec plst)
+  "Validates a parameter-list PLST against the parameter-spec PSPEC."
+  (define (process-multi-list lst)
+    (apply append
+           (map (lambda (x)
+                  (parameter-process-list (list x)))
+                (filter (lambda (x) (not (eqv? x '_)))
+                        lst))))
+
+  ;; We want all tests to run
+  (let ((works? #t))
+
+    (define (m+eqv? new-val orig-val)
+      (or (and (eqv? orig-val '_)
+               (not (eqv? new-val #:off)))
+          (eqv? orig-val new-val)))
+
+    (define (throw+f sym vals)
+      (raise (formatted-message
+              (G_ "Parameter Validation Error: ~a with values ~s~%")
+              sym vals))
+      (set! works? #f))
+
+    ;; first we check duplication
+    ;; a bit unnecessary
+    (define (validate/duplication)
+      (let ((symlst (map first plst)))
+        (unless (eqv? symlst (delete-duplicates symlst))
+          (throw+f "Duplicates" plst))))
+
+    ;; logic checking checks for:
+    ;;   - presence of required parameters
+    ;;   - 'one-of' conflicts
+    ;;   - dependency satisfaction
+    (define (validate/logic)
+      (map ; required
+       (match-lambda
+         [(psym . value)
+         (unless
+             (let ((new-val (assq-ref plst psym)))
+               (m+eqv? (if (eqv?
+                             new-val
+                             (parameter-spec-negation-supported?
+                               pspec
+                               psym))
+                         #:off new-val)
+                       value))
+           (throw+f "Unsatisfied Requirements" (cons psym value)))])
+       (parameter-process-list ; cannot have duplicates here!
+        (parameter-spec-required pspec)))
+      (map ; one-of
+       (lambda (ls)
+         (unless
+             (let ((satisfied (count
+                               (match-lambda
+                                 [(psym . value)
+                                  (let ((new-val (assq-ref plst psym)))
+                                    (m+eqv?
+                                      (if
+                                        (eqv? new-val
+                                              (parameter-spec-negation-supported?
+                                                pspec
+                                                psym))
+                                        #:off new-val)
+                                      value))])
+                                (process-multi-list ls)))) ; duplicates could happen!
+               (or (= satisfied 1)
+                   (and (= satisfied 0)
+                        (eqv? (first ls) '_))))
+           (throw+f "Unsatisfied One-Of" ls)))
+       (parameter-spec-one-of pspec))
+
+      (unless (not (member #f
+                      (return-list
+                       (map (lambda (x)
+                              (let ((deps (package-parameter-dependencies
+                                           (parameter-spec-get-parameter pspec x))))
+                                (if deps
+                                    (not
+                                      (member
+                                        #f
+                                        (map
+                                         (lambda (dep)
+                                           ;; 0. restructure dep to a proper cell
+                                           (match (first
+                                                   (parameter-process-list
+                                                    (return-list dep)))
+                                             ;; 1. assq-ref
+                                             [(psym . value)
+                                              (m+eqv?
+                                               (assq-ref plst psym)
+                                               value)]))
+                                          (return-list
+                                            ;;; XXX: check for packages
+                                            ;; not doable in the current state as the validator
+                                            ;; does not take the entire package as an argument
+                                            ;; the validator will have to be heavily modified
+                                            (assq-ref deps 'parameter)))))
+                                    #t)))
+                            ;; filter to check if parameter is not its negation
+                            (filter (match-lambda
+                                      [(psym . value)
+                                       (not (eqv? value
+                                                  (parameter-spec-negation-supported?
+                                                   pspec
+                                                   psym)))])
+                                    plst)))))
+                      (throw+f "Bad dependencies!" plst)))
+
+    (validate/duplication)
+
+    (validate/logic)
+
+    works?))
+
+;; need pkg instead of pspec for override-spec
+(define (package-resolve-parameter-list pkg plst)
+  "Resolves a parameter-list PLST against the package PKG."
+  (let* ([pspec (package-parameter-spec pkg)]
+         [proper-plst (override-spec-multi-match
+                      pspec
+                      (package-override-plist
+                       pkg
+                       (parameter-process-list plst)))])
+    (if (parameter-spec-validate pspec proper-plst)
+        proper-plst
+        (base-parameter-alist pspec))))
+
+;; %global-parameters: hash table containing global parameters ref'd by syms
+
+(define-syntax define-global-parameter
+  (syntax-rules ()
+    [(define-global-parameter parameter-definition)
+     (let ((gp-val parameter-definition))
+       (hash-set! %global-parameters
+                  (package-parameter-name gp-val)
+                  gp-val))]))
+
+(define-syntax parameter-inside?
+  (syntax-rules ()
+    [(% p pkg)
+     (let ((plst
+            (parameter-spec-parameter-alist
+             (package-parameter-spec pkg))))
+       (not
+        (eqv? (or (assq-ref plst (first p))
+                  (error "Parameter not found!"))
+              (parameter-type-negation
+               (package-parameter-type
+                (parameter-spec-get-parameter
+                 (package-parameter-spec pkg)
+                 p))))))]))
+
+(define-syntax parameter-if
+  (syntax-rules ()
+    [(parameter-if #:package pkg rest ...)
+     (parameter-if-branches pkg rest ...)]
+    [(parameter-if rest ...)
+     (parameter-if-branches this-pkg rest ...)]))
+
+(define-syntax parameter-if-branches
+  (syntax-rules ()
+    [(parameter-if-branches pkg parameters exp)
+     (parameter-if-driven pkg parameters exp '())]
+    [(parameter-if-branches pkg parameters exp exp-else)
+     (parameter-if-driven pkg parameters exp exp-else)]
+    [(% anything ...)
+     (raise (formatted-message
+              (G_ "Poorly formatted parameter-if: ~s"
+                  '(parameter-if anything ...))))]))
+
+(define-syntax parameter-if-driven
+  (syntax-rules ()
+    [(parameter-if-driven pkg (#:all parameters ...) exp exp-else)
+     (if (not (member
+               #f
+               (map (cut parameter-inside? <> pkg)
+                    (parameter-process-list '(parameters ...)))))
+       exp
+       exp-else)]
+    [(parameter-if-driven pkg (parameters ...) exp exp-else)
+     (if (member
+           #t
+           (map (cut parameter-inside? <> pkg)
+                (parameter-process-list '(parameters ...))))
+       exp
+       exp-else)]))
+
+(define-syntax parameter-match
+  (syntax-rules (_)
+    [(% #:package pkg rest ...)
+     (parameter-match-driven pkg rest ...)]
+    [(% rest ...)
+     (parameter-match-driven this-package rest ...)]))
+
+(define-syntax parameter-match-driven
+  (syntax-rules (_)
+    [(% pkg) '()]
+    [(% pkg (_ clauses ...) rest ...) (begin (begin clauses ...) (parameter-match-driven pkg rest ...))]
+    [(% pkg (parameters) rest ...) (parameter-match-driven pkg rest ...)]
+    [(% pkg ((#:all parameters ...) clauses ...) rest ...)
+     (begin
+       (and (not (member #f (map (cut parameter-inside? <> pkg)
+                                 (parameter-process-list '(parameters ...)))))
+            (begin clauses ...))
+       (parameter-match-driven pkg rest ...))]
+    [(% pkg ((parameters ...) clauses ...) rest ...)
+     (begin
+       (and (member #t (map (cut parameter-inside? <> pkg)
+                            (parameter-process-list '(parameters ...))))
+            (begin clauses ...))
+       (parameter-match-driven pkg rest ...))]
+    [(% pkg (parameter clauses ...) rest ...)
+     (begin
+       (and (parameter-inside? parameter pkg)
+            (begin clauses ...))
+       (parameter-match-driven pkg rest ...))]
+    [(% pkg anything ...)
+     (raise (formatted-message
+              (G_ "Poorly formatted parameter-match: ~s"
+                  '(parameter-match anything ...))))]))
+
+(define-syntax parameter-match-case
+  (syntax-rules (_)
+    [(% #:package pkg rest ...)
+     (parameter-match-case-driven pkg rest ...)]
+    [(% rest ...)
+     (parameter-match-case-driven this-package rest ...)]))
+
+(define-syntax parameter-match-case-driven
+  (syntax-rules (_)
+    [(% pkg) '()]
+    [(% pkg (_ clauses ...) rest ...) (begin clauses ...)]
+    [(% pkg (parameters) rest ...) (parameter-match-case-driven pkg rest ...)]
+    [(% pkg ((#:all parameters ...) clauses ...) rest ...)
+     (if (not (member #f (map (cut parameter-inside? <> pkg)
+                              (parameter-process-list '(parameters ...)))))
+         (begin clauses ...)
+         (parameter-match-case-driven pkg rest ...))]
+    [(% pkg ((parameters ...) clauses ...) rest ...)
+     (if (member #t (map (cut parameter-inside? <> pkg)
+                         (parameter-process-list '(parameters ...))))
+         (begin clauses ...)
+         (parameter-match-case-driven pkg rest ...))]
+    [(% pkg (parameter clauses ...) rest ...)
+     (if (parameter-inside? parameter pkg)
+         (begin clauses ...)
+         (parameter-match-case-driven pkg rest ...))]
+    [(% pkg anything ...)
+     (raise (formatted-message
+              (G_ "Poorly formatted parameter-match-case: ~s"
+                  '(parameter-match-case anything ...))))]))
+
+;; modified to take the original package, similar to modify-inputs
+(define-syntax parameter-modify-inputs
+  (syntax-rules (_ :lock prepend append delete replace)
+    [(% inputs) inputs]
+    [(% inputs :lock ())
+     inputs]
+    [(% inputs :lock (stuff ...))
+     (modify-inputs inputs stuff ...)]
+    [(% inputs :lock (stuff ...) (_ clauses ...) rest ...)
+     (parameter-modify-inputs inputs :lock (stuff ... clauses ...) rest ...)]
+    [(% inputs :lock stuff (parameters) rest ...)
+     (parameter-modify-inputs inputs :lock stuff rest ...)]
+    [(% inputs :lock (stuff ...) ((#:all parameters ...) clauses ...) rest ...)
+     (if (not (member #f (map (cut parameter-inside?
+                                <> this-package)
+                              (parameter-process-list '(parameters ...)))))
+         (parameter-modify-inputs inputs :lock
+                                  (stuff ... clauses ...)
+                                  rest ...)
+         (parameter-modify-inputs inputs :lock (stuff ...) rest ...))]
+    [(% inputs :lock (stuff ...) ((parameters ...) clauses ...) rest ...)
+     (if (member #t (map (cut parameter-inside?
+                           <> this-package)
+                         (parameter-process-list '(parameters ...))))
+         (parameter-modify-inputs inputs :lock
+                                  (stuff ... clauses ...)
+                                  rest ...)
+         (parameter-modify-inputs inputs :lock (stuff ...) rest ...))]
+    [(% inputs :lock (stuff ...) (parameter clauses ...) rest ...)
+     (if (parameter-inside? parameter
+                            this-package)
+         (parameter-modify-inputs inputs :lock
+                                  (stuff ... clauses ...)
+                                  rest ...)
+         (parameter-modify-inputs inputs :lock (stuff ...) rest ...))]
+    [(% inputs rest ...)
+     (parameter-modify-inputs inputs :lock () rest ...)]
+    [(% . anything)
+     (raise (formatted-message (G_ "Poorly formatted parameter-modify-inputs: ~s" anything)))]))
+
+(define-syntax parameter-substitute-keyword-arguments
+  (syntax-rules (_ :lock prepend append delete replace)
+    [(% arguments) arguments]
+    [(% arguments :lock ())
+     arguments]
+    [(% arguments :lock (stuff ...))
+     (substitute-keyword-arguments arguments stuff ...)]
+    [(% arguments :lock (stuff ...) (_ clauses ...) rest ...)
+     (parameter-substitute-keyword-arguments arguments :lock (stuff ... clauses ...) rest ...)]
+    [(% arguments :lock stuff (parameters) rest ...)
+     (parameter-substitute-keyword-arguments arguments :lock stuff rest ...)]
+    [(% arguments :lock (stuff ...) ((#:all parameters ...) clauses ...) rest ...)
+     (if (not (member #f (map (cut parameter-inside?
+                                <> this-package)
+                              (parameter-process-list '(parameters ...)))))
+         (parameter-substitute-keyword-arguments arguments :lock
+                                  (stuff ... clauses ...)
+                                  rest ...)
+         (parameter-substitute-keyword-arguments arguments :lock (stuff ...) rest ...))]
+    [(% arguments :lock (stuff ...) ((parameters ...) clauses ...) rest ...)
+     (if (member #t (map (cut parameter-inside?
+                           <> this-package)
+                         (parameter-process-list '(parameters ...))))
+         (parameter-substitute-keyword-arguments arguments :lock
+                                  (stuff ... clauses ...)
+                                  rest ...)
+         (parameter-substitute-keyword-arguments arguments :lock (stuff ...) rest ...))]
+    [(% arguments :lock (stuff ...) (parameter clauses ...) rest ...)
+     (if (parameter-inside? parameter
+                            this-package)
+         (parameter-substitute-keyword-arguments arguments :lock
+                                  (stuff ... clauses ...)
+                                  rest ...)
+         (parameter-substitute-keyword-arguments arguments :lock (stuff ...) rest ...))]
+    [(% arguments rest ...)
+     (parameter-substitute-keyword-arguments arguments :lock () rest ...)]
+    [(% . anything)
+     (raise (formatted-message (G_ "Poorly formatted parameter-substitute-keyword-arguments: ~s" anything)))]))
+
+
+;; Some global parameters
+
+(define-global-parameter
+  (package-parameter
+   (name 'static-lib)
+   (variants
+    (parameter-variant-match
+     (_ #:transform
+        (with-configure-flag #:package-name "=--disable-shared")
+        (with-configure-flag #:package-name "=--enable-static"))))
+   (predicate #t)))
+
+(define-global-parameter
+  (package-parameter
+   (name 'tests)
+   (variants
+    (parameter-variant-match
+     (#:off #:transform (without-tests #:package-name))))
+   (description "Toggle for tests")
+   (predicate #t)))
diff --git a/guix/transformations.scm b/guix/transformations.scm
index 9cba6bedab..f451d646f9 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -36,6 +36,7 @@ (define-module (guix transformations)
   #:autoload   (guix cpu) (current-cpu
                            cpu->gcc-architecture
                            gcc-architecture->micro-architecture-level)
+  #:autoload (guix parameters) (package-parameter-alist parameterize-package)
   #:use-module (guix utils)
   #:use-module (guix memoization)
   #:use-module (guix gexp)
@@ -354,6 +355,59 @@ (define rewrite
         (rewrite obj)
         obj)))
 
+(define (evaluate-parameter-specs specs)
+  "Parse SPECS, a list of strings like \"bitlbee=purple=true\", and return a
+list of spec/procedure pairs, where (PROC PACKAGE PARAMETER VALUE) is called
+to return the replacement package.  Raise an error if an element of SPECS uses
+invalid syntax, or if a package it refers to could not be found."
+  (let [(package-assq '())]
+    (map (lambda (spec)
+           (match (string-tokenize spec %not-equal)
+             ((pkg name value)
+              (set! package-assq
+                (assq-set! package-assq pkg
+                           (cons (cons (string->symbol name)
+                                       (string->symbol value))
+                                 (or (assq-ref package-assq pkg)
+                                     '())))))
+             (_
+              (raise
+               (formatted-message
+                (G_ "invalid package parameter specification: ~s")
+                spec)))))
+         specs)
+    (map (lambda (x) ; (<pkg> <plist>)
+           (let ((package-name (car x))
+                 (parameter-lst (cdr x)))
+             (cons package-name
+                   (lambda (x)
+                     (let* [(original-lst (map (lambda (x)
+                                                 (cons (car x) (cdr x)))
+                                               (package-parameter-alist x)))
+                            (final-lst
+                             (fold (lambda (z y)
+                                     (assq-set! y
+                                                (car z)
+                                                (cdr z)))
+                                   original-lst
+                                   parameter-lst))]
+                       (parameterize-package x final-lst))))))
+         package-assq)))
+
+(define (transform-package-parameters replacement-specs)
+  "Return a procedure that, when passed a package, replaces its direct
+dependencies according to REPLACEMENT-SPECS.  REPLACEMENT-SPECS is a list of
+strings like \"guile-next=stable-3.0\" meaning that packages are built using
+'guile-next' from the latest commit on its 'stable-3.0' branch."
+
+  ;; we'll apply per-package parameterization and then return
+  (let* ((replacements (evaluate-parameter-specs replacement-specs))
+         (rewrite      (package-input-rewriting/spec replacements)))
+    (lambda (obj)
+      (if (package? obj)
+          (rewrite obj)
+          obj))))
+
 (define (package-dependents/spec top bottom)
   "Return the list of dependents of BOTTOM, a spec string, that are also
 dependencies of TOP, a package."
@@ -910,6 +964,7 @@ (define %transformations
     (with-branch . ,transform-package-source-branch)
     (with-commit . ,transform-package-source-commit)
     (with-git-url . ,transform-package-source-git-url)
+    (with-parameter . ,transform-package-parameters)
     (with-c-toolchain . ,transform-package-toolchain)
     (tune . ,transform-package-tuning)
     (with-debug-info . ,transform-package-with-debug-info)
@@ -957,6 +1012,8 @@ (define %transformation-options
                   (parser 'with-commit))
           (option '("with-git-url") #t #f
                   (parser 'with-git-url))
+          (option '("with-parameter") #t #f
+                  (parser 'with-parameter))
           (option '("with-c-toolchain") #t #f
                   (parser 'with-c-toolchain))
           (option '("tune") #f #t
diff --git a/guix/ui.scm b/guix/ui.scm
index 6f2d4fe245..013091d458 100644
--- a/guix/ui.scm
+++ b/guix/ui.scm
@@ -19,6 +19,7 @@
 ;;; Copyright © 2018 Steve Sprang <scs@stevesprang.com>
 ;;; Copyright © 2022 Taiju HIGASHI <higashi@taiju.info>
 ;;; Copyright © 2022 Liliana Marie Prikler <liliana.prikler@gmail.com>
+;;; Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com>
 ;;;
 ;;; This file is part of GNU Guix.
 ;;;
@@ -76,6 +77,7 @@ (define-module (guix ui)
   #:use-module (ice-9 format)
   #:use-module (ice-9 regex)
   #:autoload   (ice-9 popen) (open-pipe* close-pipe)
+  #:autoload   (guix parameters) (all-spec-parameters-with-types package-parameter-spec)
   #:autoload   (system repl repl)  (start-repl)
   #:autoload   (system repl debug) (make-debug stack->vector)
   #:use-module (texinfo)
@@ -1607,7 +1609,11 @@ (define highlighting*
     (outputs                            ; multiple outputs
      (format port "outputs:~%~{~a~%~}"
              (map (cut output->recutils p <>) (package-outputs/out-last p)))))
-
+  (match (all-spec-parameters-with-types
+          (package-parameter-spec p))
+    (() #t)
+    (lst (format port "parameters:~{ ~a~}~%"
+                 lst)))
   (format port "systems: ~a~%"
           (split-lines (string-join (package-transitive-supported-systems p))
                        (string-length "systems: ")))