guix-parameters/GUIX/guix/parameters.scm

;;; 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)
  #:autoload (guix transformations) (options->transformation)
  #: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-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)))