parameterization.patch

diff --git a/guix/parameters.scm b/guix/parameters.scm
new file mode 100644
index 0000000000..f424d33588
--- /dev/null
+++ b/guix/parameters.scm
@@ -0,0 +1,1196 @@
+;;; 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 (guix transformations)
+  #: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)
+  ;? -> remove?
+  #: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-if-all;?
+            parameter-match-any;?
+            parameter-match-all;?
+            parameter-match-case-all;?
+            parameter-match;
+            parameter-match-case;
+            parameter-modify-inputs;
+            ))
+
+;;; 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 (car (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-car 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 (car y)))
+                        carry))
+         (merge-same-car rest (cons (cons a b) carry))
+         (merge-same-car 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)
+         (cons 'x (lambdize-lambdas . 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-kw-list (lambdize-lambdas variants ...))))
+       (map (cut cons <>
+                 parsed-variants)
+       (return-list 'psym)))]))
+
+(define* (parse-kw-list kw-lst)
+  "Parses a list of keywords, KW-LST and returns an alist."
+  (define (list-till-kw lst)
+    (receive (a b)
+        (break keyword? lst)
+      (cons a b)))
+  (define* (break-keywords lst)
+    (match lst
+      [((? keyword? key) vals ..1)
+       (match (list-till-kw 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-car (break-keywords kw-lst)))
+
+;; The lock here is used to signal when merge-same-car is to be used
+;; having a :lock means merge-same-car 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
+      (lambda (ls) (cons (car ls)
+                    (merge-same-car (cdr ls))))
+      (merge-same-car
+       (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 cdr
+  (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-ov! asslst key val)
+    `(set! ,asslst
+       (assq-set! ,asslst ,key ,val)))
+  (lambda (ls)
+    (let ((triad (parse-kw-list ls)))
+      (if (find (lambda (g) (not (or (eqv? (car g) 'yes)
+                                (eqv? (car g) 'no)
+                                (eqv? (car g) 'special))))
+                triad)
+          (raise (formatted-message
+                      (G_ "Invalid keyword in use-variants: ~s")
+                      (car 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-ov! vars-lst p #:yes)))
+             rest)]
+           [('no rest ...)
+            (map
+             (lambda (p)
+               (if (not (symbol? p))
+                   (raise (formatted-message
+                      (G_ "Not a symbol: ~s")
+                      p))
+                   (assq-ov! vars-lst p #:no)))
+             rest)]
+           [('special rest ...)
+            (map
+             (lambda (x)
+               (assq-ov! vars-lst
+                         (car x)
+                         (cdr x)))
+             rest)]
+           [_ (error "wrongly formatted use-variant!")])
+         triad)
+        (map
+         (lambda (x)
+           (match (assq-ref vars-lst (package-parameter-name x))
+             [#f (assq-ov! vars-lst
+                            (package-parameter-name x)
+                            (package-parameter-variants x))]
+             [#:yes (assq-ov! vars-lst
+                            (package-parameter-name x)
+                            (package-parameter-variants x))]
+             [#:no #f] ; do nothing
+             [varn (assq-ov! 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? (car deps))
+      (if (match (car deps)
+                 [#:package (and (warning
+                                  (G_ "Package Dependencies are not supported!~%"))
+                                 #t)]
+                 [#:parameter #t]
+                 [_ #f])
+             (parse-kw-list deps)
+        (raise (formatted-message
+                (G_ "Bad dependency keyword: ~s")
+                (car 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
+       (cdar vars)]
+      [x x]))
+  ;; substitute keywords - transforms
+  (define* (sub-kw-t in #:optional (ret '()))
+    (if (null? in)
+        (match (reverse ret)
+               [(a . rest)
+                (cons a (string-join rest "="))])
+        (sub-kw-t
+         (cdr in)
+         (cons
+          (exact-sub (car in))
+          ret))))
+  ;; substitute keywords
+  (define* (sub-kw in #:optional (ret '()))
+    (if (null? in)
+        (reverse ret)
+        (sub-kw
+         (cdr in)
+         (cons
+          (exact-sub (car in))
+          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 sub-kw-t optargs))
+          pkg)
+         (cons pcell
+               rest))]
+       ['lambda
+           (apply-variants
+            ;; eval should normally be avoided
+            ;; but `lambda` as is defined evaluates
+            ;; code after substituting in keywords
+            ;; (primitive-eval (sub-kw (car optargs)))
+            (fold
+             (lambda (fn pack)
+               (case (car (procedure-minimum-arity fn))
+                 [(0) (fn)]
+                 [(1) (fn pack)]
+                 [(2) (fn pack (cdr pcell))]
+                 [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-ov! 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 (lambda (x)
+                              (not (eqv? (assq-ref the-original-parameter-list
+                                                   (car x))
+                                         (cdr x))))
+                            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 cdr #:yes, check the-parameter-list for val
+                ;; if cdr #:no, purge from prev list
+                ;; if cdr #:special, /replace/ value
+                (let ((var-lst (parameter-spec-use-variants the-spec)))
+                  (map (lambda (x)
+                         (set! var-lst
+                           (assq-set! var-lst
+                                      (car x)
+                                      (package-parameter-variants
+                                       (parameter-spec-get-parameter the-spec (car x))))))
+                       (filter (lambda (x)
+                                 ((package-parameter-predicate
+                                   (parameter-spec-get-parameter
+                                    the-spec
+                                    (car x)))
+                                  the-package))
+                               (filter
+                                (lambda (x)
+                                  (not (assq-ref var-lst (car x)))) ; not in the variant-lst?
+                                the-parameter-list)))
+                  (map
+                   (lambda (x)
+                     (match (cdr x)
+                       [#:yes (assq-ov! var-lst
+                                        (car x)
+                                        (package-parameter-variants
+                                         (parameter-spec-get-parameter the-spec (car x))))]
+                       [#:no (set! var-lst
+                               (assq-remove! var-lst
+                                             (car x)))]
+                       [_ #f]))
+                   var-lst)
+
+                  var-lst))
+               (applicable-variants
+                (map (lambda (y)
+                       (cons (cons (car y)
+                                   (assq-ref the-parameter-list (car y)))
+                             (apply append
+                                    (map (lambda (x)
+                                           (return-list (cdr x)))
+                                         (cdr y)))))
+                     ;; does it have values?
+                     (filter (lambda (x) (not (null? (cdr x))))
+                             (map ;; get list of applicable values
+                              (lambda (x)
+                                (let ((absv (assq-ref the-parameter-list (car x)))
+                                      ;; 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 (car x)))))
+                                      (defv (parameter-type-default
+                                             (package-parameter-type
+                                              (parameter-spec-get-parameter the-spec (car x))))))
+                                  (cons (car x)
+                                        (filter
+                                         (lambda (ls)
+                                           (match (car ls)
+                                             ['_ (not (eqv? absv negv))]
+                                             [#:off (eqv? absv negv)]
+                                             [#:default (eqv? absv defv)]
+                                             [oth (eqv? absv oth)]))
+                                         (cdr x)))))
+                              (filter (lambda (x) (assq-ref the-parameter-list (car 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-spec-deps 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 car <>)
+                              (map (cut get-spec-deps 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-val lst #:optional (carry '()))
+      (match lst
+        [((a . b) . rest)
+         (let ((v (assq-ref carry a)))
+           (group-val rest
+                      (assq-set! carry
+                                 a
+                                 (cons b
+                                       (if v v '())))))]
+        [() carry]
+        [_ (raise (formatted-message
+                   (G_ "Poorly formatted assoc-list in group-val! ~s")
+                   lst))]))
+    (define (figure-out psym p)
+      (or (and (< (length p) 3)
+               (or (and (eq? (length p) 1) (car p))
+                   (and (member '_ p)
+                        (car (delq '_ p)))))
+          (raise (formatted-message
+                  (G_ "Too many values for a single parameter: ~s with ~s")
+                  psym p))))
+    (map (lambda (x) (cons (car x)
+                      (figure-out (car x) ; for the error message
+                                  (delete-duplicates (cdr x)))))
+         (group-val 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 (lambda (x) (or (member (car x) all-p)
+                                            (and (hash-ref %global-parameters (car x))
+                                                 ((package-parameter-predicate
+                                                   (hash-ref %global-parameters (car x)))
+                                                  pkg))))
+                                 (parameter-process-list plist)))
+         (filtered-car (map car filtered-plist))
+         (remaining-p (filter (lambda (x) (not (member x filtered-car)))
+                              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
+             (cadr (parameter-type-accepted-values (package-parameter-type (parameter-spec-get-parameter pspec a)))))]
+      [(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 car 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
+       (lambda (x)
+         (unless
+             (let ((new-val (assq-ref plst (car x))))
+               (m+eqv? (if (eqv?
+                             new-val
+                             (parameter-spec-negation-supported?
+                               pspec
+                               (car x)))
+                         #:off new-val)
+                       (cdr x)))
+           (throw+f "Unsatisfied Requirements" x)))
+       (parameter-process-list ; cannot have duplicates here!
+        (parameter-spec-required pspec)))
+      (map ; one-of
+       (lambda (ls)
+         (unless
+             (let ((satisfied (count
+                                (lambda (x)
+                                  (let ((new-val (assq-ref plst (car x))))
+                                    (m+eqv?
+                                      (if
+                                        (eqv? new-val
+                                              (parameter-spec-negation-supported?
+                                                pspec
+                                                (car x)))
+                                        #:off new-val)
+                                      (cdr x))))
+                                (process-multi-list ls)))) ; duplicates could happen!
+               (or (= satisfied 1)
+                   (and (= satisfied 0)
+                        (eqv? (car 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 d to a proper cell
+                                            (let ((d (car
+                                                       (parameter-process-list
+                                                         (return-list dep)))))
+                                              ;; 1. assq-ref
+                                              (m+eqv?
+                                                (assq-ref plst (car d))
+                                                (cdr d))))
+                                          (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 (lambda (x)
+                                      (not (eqv? (cdr x)
+                                                 (parameter-spec-negation-supported?
+                                                  pspec
+                                                  (car x)))))
+                                    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 plst)
+     (not
+      (eqv? (or (assq-ref plst (car p))
+                (error "Parameter not found!"))
+            (parameter-type-negation
+             (package-parameter-type
+              (parameter-spec-get-parameter
+               (package-parameter-spec this-package)
+               p)))))]))
+
+(define-syntax parameter-if
+  (syntax-rules ()
+    [(parameter-if property exp)
+     (let ((properties
+            (parameter-spec-parameter-alist
+             (package-parameter-spec this-package))))
+       (if (member
+            #t
+            (map (cut parameter-inside? <> properties)
+                 (parameter-process-list (return-list property))))
+           exp
+           '()))]
+    [(parameter-if property exp exp-else)
+     (let ((properties
+            (parameter-spec-parameter-alist
+             (package-parameter-spec this-package))))
+       (if (member
+            #t
+            (map (cut parameter-inside? <> properties)
+                 (parameter-process-list (return-list property))))
+           exp
+           exp-else))]))
+
+(define-syntax parameter-if-all
+  (syntax-rules ()
+    [(parameter-if-all property exp)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (if (not (member
+                     #f
+            (map (cut parameter-inside? <> properties)
+                 (parameter-process-list (return-list property)))))
+           exp
+           '()))]
+    [(parameter-if-all property exp exp-else)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (if (not (member
+                     #f
+            (map (cut parameter-inside? <> properties)
+                 (parameter-process-list (return-list property)))))
+           exp
+           exp-else))]))
+
+(define-syntax parameter-match-any
+  (syntax-rules (_)
+    [(%) '()]
+    [(% (_ clauses ...)) (begin clauses ...)]
+    [(% ((parameters ...)) rest ...) (parameter-match-any rest ...)]
+    [(% ((parameters ...) clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (begin
+         (and (member #t (map (cut parameter-inside? <> properties)
+                              (list parameters ...)))
+              (begin clauses ...))
+         (parameter-match-any rest ...)))]
+    [(% (parameter clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (begin
+         (and (parameter-inside? parameter properties)
+              (begin clauses ...))
+         (parameter-match-any rest ...)))]))
+
+(define-syntax parameter-match-all
+  (syntax-rules (_)
+    [(%) '()]
+    [(% (_ clauses ...)) (begin clauses ...)]
+    [(% ((parameters ...)) rest ...) (parameter-match-all rest ...)]
+    [(% ((parameters ...) clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (begin
+         (and (not (member #f (map (cut parameter-inside? <> properties)
+                                   (list parameters ...))))
+              (begin clauses ...))
+         (parameter-match-all rest ...)))]
+    [(% (parameter clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (begin
+         (and (parameter-inside? parameter properties)
+              (begin clauses ...))
+         (parameter-match-all rest ...)))]))
+
+(define-syntax parameter-match-case-all
+  (syntax-rules ()
+    [(%) '()]
+    [(% (_ clauses ...)) (begin clauses ...)]
+    [(% ((parameters ...)) rest ...) (parameter-match-case-any rest ...)]
+    [(% ((parameters ...) clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (and (not (member #f (map (cut parameter-inside? <> properties)
+                                 (list parameters ...))))
+            (begin clauses ...)
+            (parameter-match-case-any rest ...)))]
+    [(% (parameter clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (and (parameter-inside? parameter properties)
+            (begin clauses ...)
+            (parameter-match-case-any rest ...)))]))
+
+(define-syntax parameter-match
+  (syntax-rules (_ all)
+    [(%) '()]
+    [(% (_ clauses ...) rest ...) (begin (begin clauses ...) (parameter-match rest ...))]
+    [(% (parameters) rest ...) (parameter-match rest ...)]
+    [(% ((all parameters ...) clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (begin
+         (and (not (member #f (map (cut parameter-inside? <> properties)
+                                   (list parameters ...))))
+              (begin clauses ...))
+         (parameter-match rest ...)))]
+    [(% ((parameters ...) clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (begin
+         (and (member #t (map (cut parameter-inside? <> properties)
+                              (list parameters ...)))
+              (begin clauses ...))
+         (parameter-match rest ...)))]
+    [(% (parameter clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (begin
+         (and (parameter-inside? parameter properties)
+              (begin clauses ...))
+         (parameter-match rest ...)))]))
+
+(define-syntax parameter-match-case
+  (syntax-rules (all _)
+    [(%) '()]
+    [(% (_ clauses ...) rest ...) (begin clauses ...)]
+    [(% (parameters) rest ...) (parameter-match-case rest ...)]
+    [(% ((all parameters ...) clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (if (not (member #f (map (cut parameter-inside? <> properties)
+                                (list parameters ...))))
+           (begin clauses ...)
+           (parameter-match-case rest ...)))]
+    [(% ((parameters ...) clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (if (member #t (map (cut parameter-inside? <> properties)
+                           (list parameters ...)))
+           (begin clauses ...)
+           (parameter-match-case rest ...)))]
+    [(% (parameter clauses ...) rest ...)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (if (parameter-inside? parameter properties)
+           (begin clauses ...)
+           (parameter-match-case rest ...)))]))
+
+(define-syntax parameter-modifier-if
+  (syntax-rules (_ all delete prepend append replace)
+    [(% _ exp exp2)
+     exp]
+    [(% (all parameters ...) exp exp2)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (if (member #t
+                   (map (cut parameter-inside? <> properties)
+                        (list parameters ...)))
+           exp
+           exp2))]
+    [(% parameter exp exp2)
+     (let ((properties (parameter-spec-parameter-alist (package-parameter-spec this-package))))
+       (if (member
+                #t
+                (map (cut parameter-inside? <> properties)
+                     (return-list parameter)))
+           exp
+           exp2))]))
+
+(define-syntax parameter-modify-inputs
+  (syntax-rules (_ all delete prepend append replace)
+    [(% inputs (parameter) clauses ...)
+     (parameter-modify-inputs inputs clauses ...)]
+    [(% inputs (parameter (delete name) rest ...) clauses ...)
+     (parameter-modify-inputs
+      (parameter-modifier-if
+       parameter
+       (alist-delete name inputs)
+       inputs)
+      (parameter rest ...)
+      clauses ...)]
+    [(% inputs (parameter (delete names ...) rest ...) clauses ...)
+     (parameter-modify-inputs
+      (parameter-modifier-if
+       parameter
+       (fold alist-delete inputs (list names ...))
+       inputs)
+      (parameter rest ...)
+      clauses ...)]
+    [(% inputs (parameter (prepend lst ...) rest ...) clauses ...)
+     (parameter-modify-inputs
+      (parameter-modifier-if
+       parameter
+       (append (map add-input-label (list lst ...)) inputs)
+       inputs)
+      (parameter rest ...)
+      clauses ...)]
+    [(% inputs (parameter (append lst ...) rest ...) clauses ...)
+     (parameter-modify-inputs
+      (parameter-modifier-if
+       parameter
+       (append inputs (map add-input-label (list lst ...)))
+       inputs)
+      (parameter rest ...)
+      clauses ...)]
+    [(% inputs (parameter (replace name replacement) rest ...) clauses ...)
+     (parameter-modify-inputs
+      (parameter-modifier-if
+       parameter
+       (replace-input name replacement inputs)
+       inputs)
+      (parameter rest ...)
+      clauses ...)]
+    [(% inputs)
+     inputs]))
+
+;; 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 ede914456f..e694539c3c 100644
--- a/guix/transformations.scm
+++ b/guix/transformations.scm
@@ -39,6 +39,7 @@ (define-module (guix transformations)
   #:use-module (guix utils)
   #:use-module (guix memoization)
   #:use-module (guix gexp)
+  #:use-module (guix parameters) ; g23
 
   ;; Use the procedure that destructures "NAME-VERSION" forms.
   #:use-module ((guix build utils)
@@ -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."
@@ -909,6 +963,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)
@@ -956,6 +1011,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..e43119a7a8 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.
 ;;;
@@ -49,6 +50,7 @@ (define-module (guix ui)
   #:use-module (guix derivations)
   #:use-module (guix build-system)
   #:use-module (guix serialization)
+  #:use-module (guix parameters)
   #:use-module ((guix licenses)
                 #:select (license? license-name license-uri))
   #:use-module ((guix build syscalls)
@@ -1608,6 +1610,12 @@ (define highlighting*
      (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: ")))