12345678910111213141516171819202122232425262728293031323334353637383940414243444546474849505152535455565758596061626364656667686970717273747576777879808182838485868788899091929394959697989910010110210310410510610710810911011111211311411511611711811912012112212312412512612712812913013113213313413513613713813914014114214314414514614714814915015115215315415515615715815916016116216316416516616716816917017117217317417517617717817918018118218318418518618718818919019119219319419519619719819920020120220320420520620720820921021121221321421521621721821922022122222322422522622722822923023123223323423523623723823924024124224324424524624724824925025125225325425525625725825926026126226326426526626726826927027127227327427527627727827928028128228328428528628728828929029129229329429529629729829930030130230330430530630730830931031131231331431531631731831932032132232332432532632732832933033133233333433533633733833934034134234334434534634734834935035135235335435535635735835936036136236336436536636736836937037137237337437537637737837938038138238338438538638738838939039139239339439539639739839940040140240340440540640740840941041141241341441541641741841942042142242342442542642742842943043143243343443543643743843944044144244344444544644744844945045145245345445545645745845946046146246346446546646746846947047147247347447547647747847948048148248348448548648748848949049149249349449549649749849950050150250350450550650750850951051151251351451551651751851952052152252352452552652752852953053153253353453553653753853954054154254354454554654754854955055155255355455555655755855956056156256356456556656756856957057157257357457557657757857958058158258358458558658758858959059159259359459559659759859960060160260360460560660760860961061161261361461561661761861962062162262362462562662762862963063163263363463563663763863964064164264364464564664764864965065165265365465565665765865966066166266366466566666766866967067167267367467567667767867968068168268368468568668768868969069169269369469569669769869970070170270370470570670770870971071171271371471571671771871972072172272372472572672772872973073173273373473573673773873974074174274374474574674774874975075175275375475575675775875976076176276376476576676776876977077177277377477577677777877978078178278378478578678778878979079179279379479579679779879980080180280380480580680780880981081181281381481581681781881982082182282382482582682782882983083183283383483583683783883984084184284384484584684784884985085185285385485585685785885986086186286386486586686786886987087187287387487587687787887988088188288388488588688788888989089189289389489589689789889990090190290390490590690790890991091191291391491591691791891992092192292392492592692792892993093193293393493593693793893994094194294394494594694794894995095195295395495595695795895996096196296396496596696796896997097197297397497597697797897998098198298398498598698798898999099199299399499599699799899910001001100210031004100510061007100810091010101110121013101410151016101710181019102010211022102310241025102610271028102910301031103210331034103510361037103810391040104110421043104410451046104710481049105010511052105310541055105610571058105910601061106210631064106510661067106810691070107110721073107410751076107710781079108010811082108310841085108610871088108910901091109210931094109510961097109810991100110111021103110411051106110711081109111011111112111311141115111611171118111911201121112211231124112511261127112811291130113111321133113411351136113711381139114011411142114311441145114611471148114911501151115211531154115511561157115811591160116111621163116411651166116711681169117011711172117311741175117611771178117911801181 |
- ;;; GNU Guix --- Functional package management for GNU
- ;;; Copyright © 2020 Ludovic Courtès <ludo@gnu.org>
- ;;; Copyright © 2023 Sarthak Shah <shahsarthakw@gmail.com>
- ;;;
- ;;; This file is part of GNU Guix.
- ;;;
- ;;; GNU Guix is free software; you can redistribute it and/or modify it
- ;;; under the terms of the GNU General Public License as published by
- ;;; the Free Software Foundation; either version 3 of the License, or (at
- ;;; your option) any later version.
- ;;;
- ;;; GNU Guix is distributed in the hope that it will be useful, but
- ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
- ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
- ;;; GNU General Public License for more details.
- ;;;
- ;;; You should have received a copy of the GNU General Public License
- ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>.
- (define-module (guix parameters)
- #:use-module (guix diagnostics)
- #:use-module (guix i18n)
- #:use-module (guix packages)
- #:use-module (guix profiles)
- #:use-module (guix records)
- #:use-module (srfi srfi-1)
- #:use-module (srfi srfi-13)
- #:use-module (srfi srfi-26)
- #:use-module (srfi srfi-34)
- #:use-module (srfi srfi-35)
- #:use-module (ice-9 hash-table)
- #:use-module (ice-9 match)
- #:use-module (ice-9 receive)
- #:autoload (guix transformations) (options->transformation)
- #:export (parameter-type
- package-parameter
- parameter-spec
- boolean-parameter-type
- parameter-variant
- parameter-variant-match
- parameter-spec-property
- package-parameter-spec
- package-parameter-alist
- all-spec-parameters
- all-spec-parameters-with-types
- base-parameter-alist
- parameter-process-list
- package-override-plist
- parameter-spec-validate
- package-resolve-parameter-list
- %global-parameters
- define-global-parameter
- package-with-parameters
- parameterize-package
- apply-variants
- parameter-spec-parameter-alist
- parameter-if
- parameter-match
- parameter-match-case
- parameter-modify-inputs
- parameter-substitute-keyword-arguments
- ))
- ;;; Commentary:
- ;;;
- ;;; This module provides a way to express high-level "package parameters",
- ;;; which allow users to customize how packages are built. Parameters are an
- ;;; interface that package developers define, where each parameter has a name
- ;;; and type. The user interface then converts parameter values from string
- ;;; to Scheme values and records them in the package properties.
- ;;;
- ;;; Package parameters are discoverable; their description is
- ;;; internationalized. The possible values of a parameter can be enumerated,
- ;;; and thus the Cartesian product of all possible parameter values for a
- ;;; package can be enumerated as well.
- ;;;
- ;;; Code:
- (define (give-me-a-symbol ex)
- "Take a string or symbol EX and return a symbol."
- (cond ((symbol? ex) ex)
- ((string? ex) (string->symbol ex))
- (else (raise (formatted-message
- (G_ "Not a symbol or a string: ~s")
- ex)))))
- (define-record-type* <parameter-type> parameter-type
- make-parameter-type
- parameter-type?
- this-parameter-type
- (name parameter-type-name
- (sanitize give-me-a-symbol))
- (accepted-values parameter-type-accepted-values)
- (negation parameter-type-negation
- (default (first (parameter-type-accepted-values this-parameter-type)))
- (thunked))
- (default parameter-type-default
- (default (match (parameter-type-accepted-values this-parameter-type)
- [(first second . rest)
- (if (not (parameter-type-negation this-parameter-type))
- first
- second)]
- [oth (raise (formatted-message
- (G_ "Bad accepted-values form: ~s")
- oth))]))
- (thunked))
- (description parameter-type-description
- (default "")))
- (define boolean-parameter-type
- (parameter-type
- (name 'boolean)
- (accepted-values '(off on))
- (description "Boolean Parameter Type")))
- ;; Package parameter interface.
- (define-record-type* <package-parameter> package-parameter
- make-package-parameter
- package-parameter?
- (name package-parameter-name
- (sanitize give-me-a-symbol))
- (type package-parameter-type
- (default boolean-parameter-type))
- (variants package-parameter-variants
- (default '())
- (sanitize sanitize-parametric-variants))
- (dependencies package-parameter-dependencies
- (default '())
- (sanitize dependency-sanitizer)
- (thunked))
- (predicate package-parameter-predicate
- (sanitize predicate-sanitizer)
- (default (const #f)))
- (description package-parameter-description (default "")))
- (define %global-parameters
- (alist->hash-table '()))
- ;; SANITIZERS
- (define (sanitize-parametric-variants ls)
- "Raise an error if LS is not a list."
- (cond ((list? ls) ls)
- (else (raise (formatted-message
- (G_ "Not a list: ~s")
- ls)))))
- (define (predicate-sanitizer p)
- (match p
- [(? procedure? p) p]
- [#t (and (warning
- (G_ "Please use (const #t) instead of #t!~%"))
- (const #t))]
- [#f (and (warning
- (G_ "Please use (const #f) instead of #f!~%"))
- (const #f))]
- [_ (raise (formatted-message
- (G_ "Not a predicate: ~s")
- p))]))
- ;; % USEFUL HELPER FUNCTIONS %
- (define (return-list lst)
- "Take a value LST, return LST if it a list and (list LST) otherwise."
- (if (list? lst)
- lst
- (list lst)))
- (define (append-everything . things)
- "Take a number of THINGS, and append them all."
- (apply append
- (map return-list things)))
- (define (get-parameter-sym psym)
- "If the argument is a cons cell, return the CAR otherwise return the argument."
- (match psym
- [(a . b) a]
- [a a]))
- (define* (merge-same-key lst #:optional (carry '()))
- "Merge the cells of LST with the same value in their CAR."
- (match lst
- [((a . b) . rest)
- (if (null? (filter (lambda (y) (equal? a (first y)))
- carry))
- (merge-same-key rest (cons (cons a b) carry))
- (merge-same-key rest (assq-set! carry
- a
- (append (assq-ref carry a) b))))]
- [() carry]))
- (define-syntax lambdize-lambdas
- (syntax-rules (:cruise)
- [(% :cruise x . rest)
- (if (keyword? x)
- (lambdize-lambdas x . rest)
- (cons x (lambdize-lambdas :cruise . rest)))]
- [(% :cruise) '()]
- [(% #:lambda fn . rest)
- (cons #:lambda
- (cons fn
- (lambdize-lambdas :cruise . rest)))]
- [(% x . rest)
- (cons 'x (lambdize-lambdas . rest))]
- [(%) '()]))
- (define-syntax parameter-variant
- (syntax-rules ()
- [(%) '()]
- [(% psym variants ...)
- (let ((parsed-variants
- (parse-keyword-list (lambdize-lambdas variants ...))))
- (map (cut cons <>
- parsed-variants)
- (return-list 'psym)))]))
- (define* (parse-keyword-list kw-lst)
- "Parses a list of keywords, KW-LST and returns an alist."
- (define (list-till-keyword lst)
- (receive (a b)
- (break keyword? lst)
- (cons a b)))
- (define* (break-keywords lst)
- (match lst
- [((? keyword? key) vals ..1)
- (match (list-till-keyword vals)
- [(first . rest)
- (cons (cons (keyword->symbol key)
- first)
- (break-keywords rest))])]
- [((? keyword? just-a-key)) ; (... #:key)
- (cons (cons (keyword->symbol just-a-key) '())
- '())]
- [(singleton) '()]
- [() '()]
- [_ (raise (formatted-message
- (G_ "Error trying to break keywords at ~a")
- lst))]))
- (merge-same-key (break-keywords kw-lst)))
- ;; The lock here is used to signal when merge-same-key is to be used
- ;; having a :lock means merge-same-key has been used further up the tree
- ;; note that :lock is not a keyword but a symbol, as we are using keywords elsewhere
- (define-syntax parameter-variant-match
- (syntax-rules (:lock)
- ((% :lock (x ...))
- (return-list
- (parameter-variant x ...)))
- ((% :lock (x ...) rest ...)
- (append
- (return-list (parameter-variant x ...))
- (parameter-variant-match :lock rest ...)))
- ((% rest ...)
- (map
- (match-lambda
- [(v . lst)
- (cons v
- (merge-same-key lst))])
- (merge-same-key
- (parameter-variant-match :lock rest ...))))))
- (define (local-sanitizer ls)
- "Sanitize a list of local parameters, LS."
- (if (list? ls)
- (map (lambda (val)
- (cond ((package-parameter? val) val)
- ((symbol? val) (package-parameter (name val)))
- ((string? val) (package-parameter (name (string->symbol val))))
- (else (raise (formatted-message
- (G_ "Not a parameter, symbol or string: ~s")
- val)))))
- ls)
- (raise (formatted-message
- (G_ "Spec's local field is not a list: ~s")
- ls))))
- (define* (variant-sanitizer lv)
- "Sanitize a list of variants."
- ;; #:yes -> use default variant
- ;; #:no -> don't use variant
- ;; #:special -> use variant in rest
- (define (sym->parameter psym)
- "Take a symbol PSYM and return the corresponding parameter."
- (or (find (lambda (g) (eqv? psym
- (package-parameter-name g)))
- lv)
- (hash-ref %global-parameters psym)
- (raise (formatted-message
- (G_ "sym->parameter: not a symbol: ~s")
- psym))))
- (define-macro (assq-override! asslst key val)
- `(set! ,asslst
- (assq-set! ,asslst ,key ,val)))
- (lambda (ls)
- (let ((triad (parse-keyword-list ls)))
- (if (find (lambda (g) (not (or (eqv? (first g) 'yes)
- (eqv? (first g) 'no)
- (eqv? (first g) 'special))))
- triad)
- (raise (formatted-message
- (G_ "Invalid keyword in use-variants: ~s")
- (first g))))
- (let ((vars-lst '()))
- (map
- (match-lambda
- [('yes rest ...)
- (map
- (lambda (p)
- (if (not (symbol? p))
- (raise (formatted-message
- (G_ "Not a symbol: ~s")
- p))
- (assq-override! vars-lst p #:yes)))
- rest)]
- [('no rest ...)
- (map
- (lambda (p)
- (if (not (symbol? p))
- (raise (formatted-message
- (G_ "Not a symbol: ~s")
- p))
- (assq-override! vars-lst p #:no)))
- rest)]
- [('special rest ...)
- (map
- (match-lambda
- [(a . b)
- (assq-override! vars-lst
- a
- b)])
- rest)]
- [_ (error "wrongly formatted use-variant!")])
- triad)
- (map
- (lambda (x)
- (match (assq-ref vars-lst (package-parameter-name x))
- [#f (assq-override! vars-lst
- (package-parameter-name x)
- (package-parameter-variants x))]
- [#:yes (assq-override! vars-lst
- (package-parameter-name x)
- (package-parameter-variants x))]
- [#:no #f] ; do nothing
- [varn (assq-override! vars-lst
- (package-parameter-name x)
- varn)]))
- lv)
- vars-lst))))
- (define (dependency-sanitizer deps)
- "Sanitize the dependency-list of a package-parameter."
- (unless (eqv? deps '())
- (if (not (list? deps))
- (raise (formatted-message
- (G_ "Dependencies not a list: ~s")
- deps)))
- (if (keyword? (first deps))
- (if (match (first deps)
- [#:package (and (warning
- (G_ "Package Dependencies are not supported!~%"))
- #t)]
- [#:parameter #t]
- [_ #f])
- (parse-keyword-list deps)
- (raise (formatted-message
- (G_ "Bad dependency keyword: ~s")
- (first deps))))
- (dependency-sanitizer (cons #:parameter deps)))))
- (define-record-type* <parameter-spec> parameter-spec
- make-parameter-spec
- parameter-spec?
- this-parameter-spec
- (local parameter-spec-local
- (default '())
- (sanitize local-sanitizer)
- (thunked))
- (defaults parameter-spec-defaults
- (default '())
- (thunked))
- (required parameter-spec-required
- (default '())
- (thunked))
- (optional parameter-spec-optional
- (default '())
- (thunked))
- (one-of parameter-spec-one-of
- (default '())
- (thunked))
- (combinations-with-substitutes
- parameter-spec-combinations-with-substitutes
- (default parameter-spec-defaults)
- (thunked))
- (use-variants parameter-spec-use-variants
- (default '())
- (sanitize (variant-sanitizer
- (parameter-spec-local this-parameter-spec)))
- (thunked))
- (parameter-alist parameter-spec-parameter-alist
- (default (base-parameter-alist this-parameter-spec))
- (thunked)))
- (define-syntax parameter-spec-property
- (syntax-rules ()
- [(parameter-spec-property body ...)
- (cons 'parameter-spec
- (parameter-spec body ...))]))
- (define (apply-variants pkg vars)
- "Apply a list of variants, VARS to the given package PKG."
- (define (exact-sub v)
- (match v
- [(lst ...) ; to traverse the tree
- (map exact-sub v)]
- [#:package-name
- (package-name pkg)]
- [#:package
- pkg]
- [#:parameter-value
- (match vars
- [((_ . rest) . others)
- rest])]
- [x x]))
- ;; substitute keywords - transforms
- (define* (substitute-keywords-for-transforms in #:optional (ret '()))
- (match in
- [(a . rest)
- (substitute-keywords-for-transforms
- rest
- (cons (exact-sub a) ret))]
- [() (match (reverse ret)
- [(a . rest)
- (cons a (string-join rest "="))])]))
- ;; substitute keywords
- (define* (substitute-keywords in #:optional (ret '()))
- (match in
- [(a . rest)
- (substitute-keywords
- a
- (cons (exact-sub a) ret))]
- [() (reverse ret)]))
- (match vars
- [(pcell (option optargs ...) . rest)
- (match option
- ['build-system
- ;; halt execution if it does not match
- (if (member (package-build-system the-package)
- optargs) ; will be a list of build systems
- (apply-variants pkg (cons pcell
- rest))
- pkg)]
- ['transform
- (apply-variants
- ((options->transformation
- (map substitute-keywords-for-transforms optargs))
- pkg)
- (cons pcell
- rest))]
- ['lambda
- (apply-variants
- (fold
- (lambda (fn pack)
- (case (first (procedure-minimum-arity fn))
- [(0) (fn)]
- [(1) (fn pack)]
- [(2) (fn pack (match pcell [(_ . rest) rest]))]
- [else (raise (formatted-message
- (G_ "Procedure ~s has invalid arity.")
- fn))]))
- pkg
- optargs)
- (cons pcell
- rest))]
- [oth
- (raise (formatted-message
- (G_ "Invalid Option: ")
- oth))])]
- [(pcell (option) . rest)
- (apply-variants pkg (cons pcell rest))]
- [(pcell) pkg]
- [_ (raise (formatted-message
- (G_ "Poorly formatted variant spec: ~s")
- vars))]))
- (define-syntax package-with-parameters
- (syntax-rules ()
- [(% spec body ...)
- (let* [(the-package-0 (package body ...))
- (the-package (package
- (inherit the-package-0)
- (replacement (package-replacement the-package-0))
- (location (package-location the-package-0))
- (properties
- (cons (cons 'parameter-spec
- spec)
- (package-properties the-package-0)))))]
- (parameterize-package the-package
- (parameter-spec-parameter-alist spec)
- #:force-parameterization? #t))]))
- (define* (parameterize-package the-initial-package
- the-initial-list
- #:key (force-parameterization? #f))
- "Evaluates THE-INITIAL-PACKAGE with the parameter-list THE-INITIAL-LIST."
- (define-macro (assq-override! asslst key val)
- `(set! ,asslst
- (assq-set! ,asslst ,key ,val)))
- (define smoothen
- (match-lambda
- [(a . #:off)
- (cons a
- (parameter-type-negation
- (package-parameter-type (parameter-spec-get-parameter spec a))))]
- [(a . #:default)
- (cons a
- (parameter-type-default
- (package-parameter-type (parameter-spec-get-parameter spec a))))]
- [cell cell]))
- (let* [(the-initial-spec
- (package-parameter-spec the-initial-package))
- (the-original-parameter-list
- (package-parameter-alist the-initial-package))
- (the-parameter-list
- (package-resolve-parameter-list the-initial-package
- the-initial-list))]
- ;; exit and return the same package if no impactful changes
- (if (and (not force-parameterization?)
- (null? (filter (match-lambda
- [(parameter-sym . parameter-value)
- (not (eqv? (assq-ref
- the-original-parameter-list
- parameter-sym)
- parameter-value))])
- the-parameter-list)))
- the-initial-package
- (let* [(the-spec ; this value gets called very often
- (parameter-spec
- (inherit the-initial-spec)
- (parameter-alist
- the-parameter-list)))
- (the-package
- (package
- (inherit the-initial-package)
- (replacement (package-replacement the-initial-package))
- (location (package-location the-initial-package))
- (properties (assq-set! (package-properties the-initial-package)
- 'parameter-spec
- the-spec))))
- (the-variants
- ;; first get list of normal variants (local, etc)
- ;; then match over use-variants
- ;; if rest #:yes, check the-parameter-list for val
- ;; if rest #:no, purge from prev list
- ;; if rest #:special, /replace/ value
- (let ((var-lst (parameter-spec-use-variants the-spec)))
- (map (match-lambda
- [(key . rest)
- (set! var-lst
- (assq-set! var-lst
- key
- (package-parameter-variants
- (parameter-spec-get-parameter the-spec key))))])
- (filter (lambda (x)
- ((package-parameter-predicate
- (parameter-spec-get-parameter
- the-spec
- (first x)))
- the-package))
- (filter
- (lambda (x)
- (not (assq-ref var-lst (first x)))) ; not in the variant-lst?
- the-parameter-list)))
- (map
- (match-lambda
- [(key . rest)
- (match rest
- [#:yes (assq-override! var-lst
- key
- (package-parameter-variants
- (parameter-spec-get-parameter the-spec key)))]
- [#:no (set! var-lst
- (assq-remove! var-lst
- key))]
- [_ #f])])
- var-lst)
- var-lst))
- (applicable-variants
- (map (match-lambda
- [(key . rest)
- (cons (cons key
- (assq-ref the-parameter-list key))
- (apply append
- (map (match-lambda
- [(_ . remaining)
- (return-list remaining)])
- rest)))])
- ;; does it have values?
- (filter (match-lambda
- [(_ . rest)
- (not (null? rest))])
- (map ;; get list of applicable values
- (match-lambda
- [(p . lst)
- (let ((absv (assq-ref the-parameter-list p))
- ;; if absv is -ve, only -ve values allowed
- ;; if absv is +ve, only +ve and _ allowed
- (negv (parameter-type-negation
- (package-parameter-type
- (parameter-spec-get-parameter the-spec p))))
- (defv (parameter-type-default
- (package-parameter-type
- (parameter-spec-get-parameter the-spec p)))))
- (cons p
- (filter
- (lambda (ls)
- (match (first ls)
- ['_ (not (eqv? absv negv))]
- [#:off (eqv? absv negv)]
- [#:default (eqv? absv defv)]
- [oth (eqv? absv oth)]))
- lst)))])
- (filter (lambda (x) (assq-ref the-parameter-list (first x)))
- the-variants)))))]
- (fold (lambda (vlst pack)
- (apply-variants pack vlst))
- the-package
- applicable-variants)))))
- (define (package-parameter-spec package)
- "Takes a package PACKAGE and returns its parameter-spec."
- (or (assq-ref (package-properties package) 'parameter-spec)
- (parameter-spec))) ; returns empty spec
- (define (package-parameter-alist package)
- "Takes a package PACKAGE and returns its parameter-list."
- (parameter-spec-parameter-alist
- (package-parameter-spec package)))
- ;;; PROCESSING PIPELINE
- ;; Convention:
- ;; Works on Parameters? -> parameter-spec/fun
- ;; Works on Parameter-Spec? -> parameter-spec/fun
- (define (parameter-spec-get-parameter pspec pcons)
- "Takes a parameter cell PCONS and returns the corresponding package-parameter."
- (let ((psym (get-parameter-sym pcons)))
- (or (find (lambda (x)
- (eqv? psym
- (package-parameter-name x)))
- (parameter-spec-local pspec))
- (hash-ref %global-parameters psym)
- (raise (formatted-message
- (G_ "Parameter not found: ~s")
- psym)))))
- (define (parameter-spec-negation-supported? pspec x)
- "Is negation supported for the given parameter X?"
- (let ((negv
- (parameter-type-negation (package-parameter-type (parameter-spec-get-parameter pspec x)))))
- (if negv
- negv
- '_)))
- (define (get-parameter-spec-dependencies pspec psym)
- "Get the dependencies of the corresponding parameter to a given parameter symbol, PSYM."
- (let ([p (parameter-spec-get-parameter pspec psym)])
- (return-list
- (assq-ref (package-parameter-dependencies p)
- 'parameter))))
- ;; 1. Fetching
- (define (base-parameter-alist pspec) ; returns base case
- "Returns the BASE-PARAMETER-ALIST for a given parameter-spec PSPEC."
- ;; '((a . psym) (b . #f) ...)
- (let* ((v1 (parameter-process-list ; returns funneled list
- (append-everything
- (parameter-spec-defaults pspec)
- (parameter-spec-required pspec))))
- (v2 (parameter-process-list
- (append-everything
- (apply append
- ;; XXX: change to a filter-map
- (filter (cut first <>)
- (map (cut get-parameter-spec-dependencies pspec <>)
- (return-list v1))))
- v1))))
- ;; funnel will signal duplication err
- ;; check if base case is valid
- (parameter-spec-validate pspec v2)
- v2))
- ;; 2. Processing
- ;; IMPORTANT CHANGE: Symbolic Negation no longer supported (psym!)
- (define (parameter-process-list lst)
- "Processes and formats a list of parameters, LST."
- (define (return-cell p)
- (match p
- [(a b) (cons a b)]
- [(a . b) p]
- [a (cons a '_)]))
- (define (funnel plst)
- (define* (group-values lst #:optional (carry '()))
- (match lst
- [((a . b) . rest)
- (let ((v (assq-ref carry a)))
- (group-values rest
- (assq-set! carry
- a
- (cons b
- (if v v '())))))]
- [() carry]
- [_ (raise (formatted-message
- (G_ "Poorly formatted assoc-list in group-values! ~s")
- lst))]))
- (define (figure-out psym p)
- (or (and (< (length p) 3)
- (or (and (eq? (length p) 1) (first p))
- (and (member '_ p)
- (first (delq '_ p)))))
- (raise (formatted-message
- (G_ "Too many values for a single parameter: ~s with ~s")
- psym p))))
- (map (match-lambda [(parameter . values)
- (cons parameter
- (figure-out parameter ; for the error message
- (delete-duplicates values)))])
- (group-values plst)))
- (funnel (map
- return-cell
- lst)))
- ;; 3. Overriding
- (define (all-spec-parameters pspec) ; for the UI
- "Returns all the parameters in a parameter-spec, PSPEC."
- ;; '(sym-a sym-b ...)
- (delete-duplicates
- (map get-parameter-sym ; we do not care about the values
- (append-everything ; works same as before
- (map package-parameter-name
- (parameter-spec-local pspec))
- (parameter-spec-defaults pspec)
- (parameter-spec-required pspec)
- ;; We are NOT pulling dependencies at this phase
- ;; They will not be influenced by the user parameter alist
- (filter (lambda (x) (not (eqv? x '_)))
- (apply append (parameter-spec-one-of pspec)))
- (parameter-spec-optional pspec)))))
- (define* (all-spec-parameters-with-types pspec #:key (show-booleans? #t))
- (if show-booleans?
- (map (lambda (x)
- (string-append
- (symbol->string x)
- ":"
- (symbol->string
- (parameter-type-name
- (package-parameter-type (parameter-spec-get-parameter pspec (cons x #f)))))))
- (all-spec-parameters pspec))
- (map (lambda (x)
- (string-append
- (symbol->string x)
- ((lambda (x)
- (if (eqv? x 'boolean)
- ""
- (string-append ":" (symbol->string x))))
- (parameter-type-name
- (package-parameter-type (parameter-spec-get-parameter pspec (cons x #f)))))))
- (all-spec-parameters pspec))))
- ;; Now we compare it against the PLIST
- ;; NOTE: This is the only instance where GLOBAL PARAMETERS may be used
- ;; Since referring to the package is not possible, we pass it instead of pspec
- (define (package-override-plist pkg plist)
- "Takes a package PKG and parameter-list PLIST and overrides PLIST according to the package."
- (let* ((pspec (package-parameter-spec pkg))
- (all-p (all-spec-parameters pspec))
- (filtered-plist (filter (match-lambda
- [(sym . rest)
- (or (member sym all-p)
- (and (hash-ref %global-parameters sym)
- ((package-parameter-predicate
- (hash-ref %global-parameters sym))
- pkg)))])
- (parameter-process-list plist)))
- (filtered-first (map first filtered-plist))
- (remaining-p (filter (lambda (x) (not (member x filtered-first)))
- all-p)))
- (append-everything filtered-plist
- (map (lambda (x) (if (parameter-spec-negation-supported? pspec x)
- (cons x #:off)
- (cons x '_)))
- remaining-p))))
- ;; 4. Funneling
- (define (override-spec-multi-match pspec plst)
- "Overrides various keyword values in the parameter-list PLST."
- (map
- (match-lambda
- [(a . '_)
- (cons a
- (match
- (parameter-type-accepted-values
- (package-parameter-type (parameter-spec-get-parameter pspec a)))
- [(_ . (val . rest)) val]))]
- [(a . #:off)
- (cons a
- (parameter-type-negation (package-parameter-type (parameter-spec-get-parameter pspec a))))]
- [(a . #:default)
- (cons a
- (parameter-type-default (package-parameter-type (parameter-spec-get-parameter pspec a))))]
- [cell cell])
- plst))
- ;; 5. Validation
- (define (parameter-spec-validate pspec plst)
- "Validates a parameter-list PLST against the parameter-spec PSPEC."
- (define (process-multi-list lst)
- (apply append
- (map (lambda (x)
- (parameter-process-list (list x)))
- (filter (lambda (x) (not (eqv? x '_)))
- lst))))
- ;; We want all tests to run
- (let ((works? #t))
- (define (m+eqv? new-val orig-val)
- (or (and (eqv? orig-val '_)
- (not (eqv? new-val #:off)))
- (eqv? orig-val new-val)))
- (define (throw+f sym vals)
- (raise (formatted-message
- (G_ "Parameter Validation Error: ~a with values ~s~%")
- sym vals))
- (set! works? #f))
- ;; first we check duplication
- ;; a bit unnecessary
- (define (validate/duplication)
- (let ((symlst (map first plst)))
- (unless (eqv? symlst (delete-duplicates symlst))
- (throw+f "Duplicates" plst))))
- ;; logic checking checks for:
- ;; - presence of required parameters
- ;; - 'one-of' conflicts
- ;; - dependency satisfaction
- (define (validate/logic)
- (map ; required
- (match-lambda
- [(psym . value)
- (unless
- (let ((new-val (assq-ref plst psym)))
- (m+eqv? (if (eqv?
- new-val
- (parameter-spec-negation-supported?
- pspec
- psym))
- #:off new-val)
- value))
- (throw+f "Unsatisfied Requirements" (cons psym value)))])
- (parameter-process-list ; cannot have duplicates here!
- (parameter-spec-required pspec)))
- (map ; one-of
- (lambda (ls)
- (unless
- (let ((satisfied (count
- (match-lambda
- [(psym . value)
- (let ((new-val (assq-ref plst psym)))
- (m+eqv?
- (if
- (eqv? new-val
- (parameter-spec-negation-supported?
- pspec
- psym))
- #:off new-val)
- value))])
- (process-multi-list ls)))) ; duplicates could happen!
- (or (= satisfied 1)
- (and (= satisfied 0)
- (eqv? (first ls) '_))))
- (throw+f "Unsatisfied One-Of" ls)))
- (parameter-spec-one-of pspec))
- (unless (not (member #f
- (return-list
- (map (lambda (x)
- (let ((deps (package-parameter-dependencies
- (parameter-spec-get-parameter pspec x))))
- (if deps
- (not
- (member
- #f
- (map
- (lambda (dep)
- ;; 0. restructure dep to a proper cell
- (match (first
- (parameter-process-list
- (return-list dep)))
- ;; 1. assq-ref
- [(psym . value)
- (m+eqv?
- (assq-ref plst psym)
- value)]))
- (return-list
- ;;; XXX: check for packages
- ;; not doable in the current state as the validator
- ;; does not take the entire package as an argument
- ;; the validator will have to be heavily modified
- (assq-ref deps 'parameter)))))
- #t)))
- ;; filter to check if parameter is not its negation
- (filter (match-lambda
- [(psym . value)
- (not (eqv? value
- (parameter-spec-negation-supported?
- pspec
- psym)))])
- plst)))))
- (throw+f "Bad dependencies!" plst)))
- (validate/duplication)
- (validate/logic)
- works?))
- ;; need pkg instead of pspec for override-spec
- (define (package-resolve-parameter-list pkg plst)
- "Resolves a parameter-list PLST against the package PKG."
- (let* ([pspec (package-parameter-spec pkg)]
- [proper-plst (override-spec-multi-match
- pspec
- (package-override-plist
- pkg
- (parameter-process-list plst)))])
- (if (parameter-spec-validate pspec proper-plst)
- proper-plst
- (base-parameter-alist pspec))))
- ;; %global-parameters: hash table containing global parameters ref'd by syms
- (define-syntax define-global-parameter
- (syntax-rules ()
- [(define-global-parameter parameter-definition)
- (let ((gp-val parameter-definition))
- (hash-set! %global-parameters
- (package-parameter-name gp-val)
- gp-val))]))
- (define-syntax parameter-inside?
- (syntax-rules ()
- [(% p pkg)
- (let ((plst
- (parameter-spec-parameter-alist
- (package-parameter-spec pkg))))
- (not
- (eqv? (or (assq-ref plst (first p))
- (error "Parameter not found!"))
- (parameter-type-negation
- (package-parameter-type
- (parameter-spec-get-parameter
- (package-parameter-spec pkg)
- p))))))]))
- (define-syntax parameter-if
- (syntax-rules ()
- [(parameter-if #:package pkg rest ...)
- (parameter-if-branches pkg rest ...)]
- [(parameter-if rest ...)
- (parameter-if-branches this-pkg rest ...)]))
- (define-syntax parameter-if-branches
- (syntax-rules ()
- [(parameter-if-branches pkg parameters exp)
- (parameter-if-driven pkg parameters exp '())]
- [(parameter-if-branches pkg parameters exp exp-else)
- (parameter-if-driven pkg parameters exp exp-else)]
- [(% anything ...)
- (raise (formatted-message
- (G_ "Poorly formatted parameter-if: ~s"
- '(parameter-if anything ...))))]))
- (define-syntax parameter-if-driven
- (syntax-rules ()
- [(parameter-if-driven pkg (#:all parameters ...) exp exp-else)
- (if (not (member
- #f
- (map (cut parameter-inside? <> pkg)
- (parameter-process-list '(parameters ...)))))
- exp
- exp-else)]
- [(parameter-if-driven pkg (parameters ...) exp exp-else)
- (if (member
- #t
- (map (cut parameter-inside? <> pkg)
- (parameter-process-list '(parameters ...))))
- exp
- exp-else)]))
- (define-syntax parameter-match
- (syntax-rules (_)
- [(% #:package pkg rest ...)
- (parameter-match-driven pkg rest ...)]
- [(% rest ...)
- (parameter-match-driven this-package rest ...)]))
- (define-syntax parameter-match-driven
- (syntax-rules (_)
- [(% pkg) '()]
- [(% pkg (_ clauses ...) rest ...) (begin (begin clauses ...) (parameter-match-driven pkg rest ...))]
- [(% pkg (parameters) rest ...) (parameter-match-driven pkg rest ...)]
- [(% pkg ((#:all parameters ...) clauses ...) rest ...)
- (begin
- (and (not (member #f (map (cut parameter-inside? <> pkg)
- (parameter-process-list '(parameters ...)))))
- (begin clauses ...))
- (parameter-match-driven pkg rest ...))]
- [(% pkg ((parameters ...) clauses ...) rest ...)
- (begin
- (and (member #t (map (cut parameter-inside? <> pkg)
- (parameter-process-list '(parameters ...))))
- (begin clauses ...))
- (parameter-match-driven pkg rest ...))]
- [(% pkg (parameter clauses ...) rest ...)
- (begin
- (and (parameter-inside? parameter pkg)
- (begin clauses ...))
- (parameter-match-driven pkg rest ...))]
- [(% pkg anything ...)
- (raise (formatted-message
- (G_ "Poorly formatted parameter-match: ~s"
- '(parameter-match anything ...))))]))
- (define-syntax parameter-match-case
- (syntax-rules (_)
- [(% #:package pkg rest ...)
- (parameter-match-case-driven pkg rest ...)]
- [(% rest ...)
- (parameter-match-case-driven this-package rest ...)]))
- (define-syntax parameter-match-case-driven
- (syntax-rules (_)
- [(% pkg) '()]
- [(% pkg (_ clauses ...) rest ...) (begin clauses ...)]
- [(% pkg (parameters) rest ...) (parameter-match-case-driven pkg rest ...)]
- [(% pkg ((#:all parameters ...) clauses ...) rest ...)
- (if (not (member #f (map (cut parameter-inside? <> pkg)
- (parameter-process-list '(parameters ...)))))
- (begin clauses ...)
- (parameter-match-case-driven pkg rest ...))]
- [(% pkg ((parameters ...) clauses ...) rest ...)
- (if (member #t (map (cut parameter-inside? <> pkg)
- (parameter-process-list '(parameters ...))))
- (begin clauses ...)
- (parameter-match-case-driven pkg rest ...))]
- [(% pkg (parameter clauses ...) rest ...)
- (if (parameter-inside? parameter pkg)
- (begin clauses ...)
- (parameter-match-case-driven pkg rest ...))]
- [(% pkg anything ...)
- (raise (formatted-message
- (G_ "Poorly formatted parameter-match-case: ~s"
- '(parameter-match-case anything ...))))]))
- ;; modified to take the original package, similar to modify-inputs
- (define-syntax parameter-modify-inputs
- (syntax-rules (_ :lock prepend append delete replace)
- [(% inputs) inputs]
- [(% inputs :lock ())
- inputs]
- [(% inputs :lock (stuff ...))
- (modify-inputs inputs stuff ...)]
- [(% inputs :lock (stuff ...) (_ clauses ...) rest ...)
- (parameter-modify-inputs inputs :lock (stuff ... clauses ...) rest ...)]
- [(% inputs :lock stuff (parameters) rest ...)
- (parameter-modify-inputs inputs :lock stuff rest ...)]
- [(% inputs :lock (stuff ...) ((#:all parameters ...) clauses ...) rest ...)
- (if (not (member #f (map (cut parameter-inside?
- <> this-package)
- (parameter-process-list '(parameters ...)))))
- (parameter-modify-inputs inputs :lock
- (stuff ... clauses ...)
- rest ...)
- (parameter-modify-inputs inputs :lock (stuff ...) rest ...))]
- [(% inputs :lock (stuff ...) ((parameters ...) clauses ...) rest ...)
- (if (member #t (map (cut parameter-inside?
- <> this-package)
- (parameter-process-list '(parameters ...))))
- (parameter-modify-inputs inputs :lock
- (stuff ... clauses ...)
- rest ...)
- (parameter-modify-inputs inputs :lock (stuff ...) rest ...))]
- [(% inputs :lock (stuff ...) (parameter clauses ...) rest ...)
- (if (parameter-inside? parameter
- this-package)
- (parameter-modify-inputs inputs :lock
- (stuff ... clauses ...)
- rest ...)
- (parameter-modify-inputs inputs :lock (stuff ...) rest ...))]
- [(% inputs rest ...)
- (parameter-modify-inputs inputs :lock () rest ...)]
- [(% . anything)
- (raise (formatted-message (G_ "Poorly formatted parameter-modify-inputs: ~s" anything)))]))
- (define-syntax parameter-substitute-keyword-arguments
- (syntax-rules (_ :lock prepend append delete replace)
- [(% arguments) arguments]
- [(% arguments :lock ())
- arguments]
- [(% arguments :lock (stuff ...))
- (substitute-keyword-arguments arguments stuff ...)]
- [(% arguments :lock (stuff ...) (_ clauses ...) rest ...)
- (parameter-substitute-keyword-arguments arguments :lock (stuff ... clauses ...) rest ...)]
- [(% arguments :lock stuff (parameters) rest ...)
- (parameter-substitute-keyword-arguments arguments :lock stuff rest ...)]
- [(% arguments :lock (stuff ...) ((#:all parameters ...) clauses ...) rest ...)
- (if (not (member #f (map (cut parameter-inside?
- <> this-package)
- (parameter-process-list '(parameters ...)))))
- (parameter-substitute-keyword-arguments arguments :lock
- (stuff ... clauses ...)
- rest ...)
- (parameter-substitute-keyword-arguments arguments :lock (stuff ...) rest ...))]
- [(% arguments :lock (stuff ...) ((parameters ...) clauses ...) rest ...)
- (if (member #t (map (cut parameter-inside?
- <> this-package)
- (parameter-process-list '(parameters ...))))
- (parameter-substitute-keyword-arguments arguments :lock
- (stuff ... clauses ...)
- rest ...)
- (parameter-substitute-keyword-arguments arguments :lock (stuff ...) rest ...))]
- [(% arguments :lock (stuff ...) (parameter clauses ...) rest ...)
- (if (parameter-inside? parameter
- this-package)
- (parameter-substitute-keyword-arguments arguments :lock
- (stuff ... clauses ...)
- rest ...)
- (parameter-substitute-keyword-arguments arguments :lock (stuff ...) rest ...))]
- [(% arguments rest ...)
- (parameter-substitute-keyword-arguments arguments :lock () rest ...)]
- [(% . anything)
- (raise (formatted-message (G_ "Poorly formatted parameter-substitute-keyword-arguments: ~s" anything)))]))
- ;; Some global parameters
- (define-global-parameter
- (package-parameter
- (name 'static-lib)
- (variants
- (parameter-variant-match
- (_ #:transform
- (with-configure-flag #:package-name "=--disable-shared")
- (with-configure-flag #:package-name "=--enable-static"))))
- (predicate #t)))
- (define-global-parameter
- (package-parameter
- (name 'tests)
- (variants
- (parameter-variant-match
- (#:off #:transform (without-tests #:package-name))))
- (description "Toggle for tests")
- (predicate #t)))
|