123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594595596597598599600601602603604605606607608609610611612613614615616617618619620621622623624625626627628629630631632633634635636637638639640641642643644645646647648649650651652653654655656657658659660661662663664665666667668669670671672673674675676677678679680681682683684685686687688689690691692693694695696697698699700701702703704705706707708709710711712713714715716717718719720721722723724725726727728729730731732733734735736737738739740741742743744745746747748749750751752753754755756757758759760761762763764765766767768769770771772773774775776777778779780781782783784785786787788789790791792793794795796797798799800801802803804805806807808809810811812813814815816817818819820821822823824825826827828829830831832833834835836837838839840841842843844845846847848849850851852853854855856857858859860861862863864865866867868869870871872873874875876877878879880881882883884885886887888889890891892893894895896897898899900901902903904905906907908909910911912913914915916917918919920921922923924925926927928929930931932933934935936937938939940941942943944945946947948949950951952953954955956957958959960961962963964965966967968969970971972973974975976977978979980981982983984985986987988989990991992993994995996997998999100010011002100310041005100610071008100910101011101210131014101510161017101810191020102110221023102410251026102710281029103010311032103310341035103610371038103910401041104210431044104510461047104810491050105110521053105410551056105710581059106010611062106310641065106610671068106910701071107210731074107510761077107810791080108110821083108410851086 |
- ;;; 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 packages)
- #:use-module (guix records)
- #:use-module (guix transformations)
- #:use-module (guix profiles)
- #:use-module (guix diagnostics)
- #:use-module (guix i18n)
- #: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 match)
- #:use-module (ice-9 hash-table)
- #:export (package-parameter
- parameter-type
- parameter-spec
- boolean
- parameter/morphism
- parameter/morphism-match
- parameter-spec-property
- package-parameter-spec
- parameter-spec/all-parameters
- parameter-spec/base-parameter-alist
- parameter-spec/override-alist
- parameter-spec/validate-parameter-alist
- parameter-spec/resolve-parameter-alist
- %global-parameters
- define-global-parameter
- package-with-parameters
- parameter-spec/parameter-alist
- parameter/if
- parameter/if-all
- parameter/match-any
- parameter/match-all
- parameter/match-case-any
- 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)
- (cond ((symbol? ex) ex)
- ((string? ex) (string->symbol ex))
- (else (throw 'bad! 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))
- (universe parameter-type-universe)
- (negation parameter-type-negation
- (default (car (parameter-type-universe this-parameter-type)))
- (thunked))
- (description parameter-type-description
- (default "")))
- (define boolean
- (parameter-type
- (name 'boolean)
- (universe '(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 sanitize-package-parameter-name))
- (type package-parameter-type
- (default boolean))
- (morphisms package-parameter-morphisms
- (default '())
- (sanitize sanitize-build-system-morphisms))
- (dependencies package-parameter-dependencies ; 7/14
- (default '())
- (thunked))
- ;; XXX: universal parameters don't need to be in the pspec
- (universal? package-parameter-universal?
- (default #f))
- (description package-parameter-description (default "")))
- ;; SANITIZERS
- (define %global-parameters
- (alist->hash-table '()))
- (define (sanitize-package-parameter-name x)
- (cond ((string? x)
- (if (string= (string-take-right x 1) "!")
- (throw "Negation in parameter name!" x) ; we cannot have negation in parameter name!
- (string->symbol x)))
- ((symbol? x)
- (if (string= (string-take-right (symbol->string x) 1) "!")
- (throw "Negation in parameter name!" x) ; we cannot have negation in parameter name!
- x))
- (else (throw 'bad! x))))
- ;; (sanitize-package-parameter-name 'x!)
- ;; (define (sanitize-build-system-transforms ls)
- (define (sanitize-build-system-morphisms ls)
- ;; ((a . t1 t2 ...) ((b c) t3 t4 ...))
- (cond ((list? ls) ls)
- (else (throw 'bad! ls))))
- (define-syntax lots-of-cons->alist
- (syntax-rules ()
- ((_ (a . b))
- (list (cons 'a b)))
- ((_ (a . b) rest ...)
- (cons (cons 'a b)
- (lots-of-cons->alist rest ...)))))
- ;; (define-syntax build-system/transform
- ;; (syntax-rules (-> _)
- ;; ((build-system/transform (x ...) -> y ...)
- ;; (map (lambda (g)
- ;; (cons g (lots-of-cons->alist y ...)))
- ;; (list x ...)))
- ;; ((build-system/transform _ -> y ...) ; for local parameter definitions
- ;; (cons 'any ; matches any build system
- ;; (lots-of-cons->alist y ...)))
- ;; ((build-system/transform x -> y ...)
- ;; (cons x (lots-of-cons->alist y ...)))))
- ;; Parameter Morphisms:
- ;; (parameter/morphism
- ;; (sym + build-system -> morphism-list))
- ;; alist->hash-table of the format
- ;; ((build-system . ((sym . ((transforms (a . b) ...) ...)) ...)) ...)
- (define (return-list lst)
- (or (and (list? lst) lst)
- (list lst)))
- (define* (merge-same-car lst #:optional (carry '()))
- (define (assq-append alist key cont)
- (if (eqv? (caar alist) key)
- (cons (cons key (append (cdar alist) cont))
- (cdr alist))
- (cons (car alist) (assq-append (cdr alist) key cont))))
- (cond ((null? lst) carry)
- ((null? (filter (lambda (y) (eqv? (caar lst)
- (car y)))
- carry))
- (merge-same-car (cdr lst) (cons (car lst) carry)))
- (else
- (merge-same-car (cdr lst)
- (assq-append carry (caar lst) (cdar lst))))))
- (define-syntax parameter/morphism
- (syntax-rules (-> + _)
- [(%) '()]
- [(% _ -> morphisms ...)
- (cons 'any (cons 'any (parameter/parse-morphisms '(morphisms ...))))]
- [(% _ + _ -> morphisms ...)
- (cons 'any (cons 'any (parameter/parse-morphisms '(morphisms ...))))]
- [(% sym + _ -> morphisms ...)
- (let ((parsed-morphisms (parameter/parse-morphisms '(morphisms ...))))
- (cons 'any (map (lambda (g)
- (cons g parsed-morphisms))
- (return-list 'sym))))]
- [(% _ + b-system -> morphisms ...)
- (let ((parsed-morphisms (parameter/parse-morphisms '(morphisms ...))))
- (map (lambda (g) (cons g (cons 'any parsed-morphisms)))
- (return-list 'b-system)))]
- [(% sym + b-system -> morphisms ...)
- (let ((parsed-morphisms (parameter/parse-morphisms '(morphisms ...))))
- (map (lambda (g) (cons g (map (lambda (h) (cons h parsed-morphisms))
- (return-list 'sym))))
- (return-list 'b-system)))]
- [(% sym -> morphisms ...)
- (let ((parsed-morphisms (parameter/parse-morphisms '(morphisms ...))))
- (cons 'any (map (lambda (g)
- (cons g parsed-morphisms))
- (return-list 'sym))))]))
- ;; (parameter/morphism (! _ 3) + (a b c) -> #:transform m1 #:rewrite m2 m3 #:modify c3)
- ;; look into more efficient ways to store this data
- ;; if we want to use break, (use-modules (srfi srfi-1) (ice-9 receive))
- ;;
- ;; (define (list-till-kw lst)
- ;; (receive (a b)
- ;; (break keyword? lst)
- ;; (cons a b)))
- ;;
- ;; (list-till-kw '(a b #:c d e))
- (define* (parameter/parse-morphisms kw-lst)
- (define* (list-till-kw lst #:optional (carry '()))
- (cond ((null? lst) (cons (reverse carry) '()))
- ((and (not (null? (cdr lst)))
- (keyword? (car lst)))
- (cons (reverse carry) lst))
- (else (list-till-kw (cdr lst) (cons (car lst) carry)))))
- (define* (break-keywords lst)
- (cond ((null? lst) '())
- ((null? (cdr lst)) '())
- ((keyword? (car lst))
- (let ((next-lst (list-till-kw (cdr lst))))
- (cons (cons (keyword->symbol (car lst))
- (car next-lst))
- (break-keywords (cdr next-lst)))))
- (else (throw 'bad! lst))))
- (merge-same-car (break-keywords kw-lst)))
- ;; (define-syntax build-system/transform-match
- ;; (syntax-rules ()
- ;; ((_ (x ...))
- ;; (list
- ;; (build-system/transform x ...)))
- ;; ((_ (x ...) rest ...)
- ;; (cons
- ;; (build-system/transform x ...)
- ;; (build-system/transform-match rest ...)))))
- ;; (parameter/parse-morphisms '(#:transform a (b c) #:rewrite d #:transform h))
- ;; 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
- (define-syntax parameter/morphism-match
- (syntax-rules (:lock _ -> +)
- ((% :lock (x ...))
- (list
- (parameter/morphism x ...)))
- ((% :lock (x ...) rest ...)
- (cons
- (parameter/morphism x ...)
- (parameter/morphism-match :lock rest ...)))
- ((% rest ...)
- (merge-same-car
- (parameter/morphism-match :lock rest ...)))))
- ;; (use-modules (ice-9 pretty-print))
- ;; (pretty-print
- ;; (parameter/morphism-match
- ;; ((a b c) + (d e f) -> #:transform (x _) y #:rewrite z)
- ;; ((a b c) + _ -> #:transform u)))
- (define (local-sanitizer 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 (throw 'bad! val))))
- ls)
- (throw 'bad! ls)))
- ;; (use-modules (ice-9 match))
- ;; morphism rewrite:
- ;; ((a b) (c d))..
- ;; (((a sym sym2) m) (b m2) ((c sym3)) (d))
- (define (morphism-sanitizer lv) ; ((a^ m) ((b sym) m2) c ((d sym1 sym2 ...) m3) ...)
- (define (default-morphism? psym) ; check if parameter is given as parameter^
- ;; TAKE SPECIAL CARE:
- ;; As we are treating ^ as a special character,
- ;; it will trim it away from the parameter symbol.
- ;; DO NOT USE IT AT THE END OF THE PARAMETER!
- (or (and (string=? (string-take-right (symbol->string psym) 1) "^")
- (string->symbol (string-drop-right (symbol->string psym) 1)))
- (and (string=? (string-take-right (symbol->string psym) 2) "^!")
- (string->symbol (string-append (string-drop-right (symbol->string psym) 2)
- "!")))))
- (define (default-morphism-list psym)
- (or (find (lambda (g) (eqv? psym
- (package-parameter-name g)))
- lv)
- (hash-ref %global-parameters psym)
- (throw 'bad! psym)))
- (lambda (ls)
- (map
- (match-lambda
- [psym
- ;; default morphism for psym
- (list
- (cons psym
- (default-morphism-list psym)))]
- [((psym vals ...) m)
- ;; assign morphism to psym at vals
- (let ((morphisms (if (keyword? (car m))
- (parameter/parse-morphisms m)
- m)))
- (map (lambda (x) (cons x morphisms))
- (return-list vals)))]
- [((? default-morphism? psym) sym)
- ;; get default morphism at sym
- (let ((csym (default-morphism? psym)))
- (list
- (cons (cons csym sym)
- (default-morphism-list csym))))]
- [(psym m)
- ;; morphism for psym
- (let ((morphisms (if (keyword? (car m))
- (parameter/parse-morphisms m)
- m)))
- (list
- (cons psym morphisms)))]
- [x
- (throw 'bad! x)])
- ls)))
- (define-syntax parameter/dependency
- (lambda (defn)
- (syntax-case defn (->)
- [(% p-lst -> rest ...)
- (syntax
- (let ((morphism-list (return-list '(rest ...))))
- (map
- (lambda (x)
- (cons x
- (parameter/parse-morphisms (if (keyword? (car morphism-list))
- morphism-list
- (cons #:parameters morphism-list)))))
- (return-list 'p-lst))))])))
- ;; (parameter/dependency (a b) -> #:parameters a b #:packages d)
- ;; (parameter/dependency (a (b yyy)) -> m n o)
- (define-syntax parameter/dependency-match
- (syntax-rules (:lock _ ->)
- ((% :lock (x ...))
- (parameter/dependency x ...))
- ((% :lock (x ...) rest ...)
- (append
- (parameter/dependency x ...)
- (parameter/dependency-match :lock rest ...)))
- ((% rest ...)
- (merge-same-car
- (parameter/dependency-match :lock rest ...)))))
- ;; (parameter/dependency-match
- ;; (a -> k)
- ;; ((a b) -> #:parameters a b #:packages d)
- ;; ((a (b yyy)) -> m n o))
- ;; thunked -> we can do stuff like (parameter-spec-optional-parameters ps) to get the optional parameters
- (define-record-type* <parameter-spec> parameter-spec
- make-parameter-spec
- parameter-spec?
- this-parameter-spec
- ;; local-parameters: parameters specific to the package
- (local parameter-spec/local
- ;; keeping it as an alist as it will be useful to retrieve them for the UI
- (default '())
- (sanitize local-sanitizer) ; morphism-update: all good!
- (thunked))
- ;; 6/15: Pjotr recommended using a global hash table instead.
- ;; See: (define-global-parameter), %global-parameters
- ;; Lines commented out due to this will have an 'x615' next to them
- ;; (global parameter-spec/global ;; global parameters used must be declared
- ;; (default '())
- ;; (sanitizer (lambda (ls)
- ;; (map (lambda (val) ; they must be package parameters
- ;; (if (package-parameter? val)
- ;; val
- ;; (throw 'bad! val)))
- ;; ls)))
- ;; (thunked))
- (defaults parameter-spec/defaults ; '(a b c d ...) -> '(a (b sym) (c sym2) e! ...)
- (default '())
- (thunked))
- (required parameter-spec/required
- (default '())
- (thunked))
- (optional parameter-spec/optional
- (default '()) ; 6/16: causing problems with parameter-spec/all-parameters
- ;; 6/13: removed the sanitizer as merging local and optional
- ;; should be handled by the parser instead.
- (thunked))
- ;; XXX: automatically create (x x!) if both are defined
- ;; 6/12: this will be handled by the parser
- (one-of parameter-spec/one-of
- (default '())
- (thunked))
- ;; add dependencies
- ;; (dependencies (parameter/dependencies
- ;; (a b -> d e f)
- ;; (c -> g h)))
- ;; (dependencies parameter-spec/dependencies
- ;; (default '())
- ;; (thunked))
- ;; 7/14 : Moved to the package-parameter record
- (canonical parameter-spec/canonical-combinations
- (default parameter-spec/defaults)
- (thunked))
- ;; (use-transforms parameter-spec/use-transforms ;; only use transforms for these
- ;; (default '())
- ;; (sanitize (transform-sanitizer (parameter-spec/local this-parameter-spec)))
- ;; (thunked))
- (use-morphisms parameter-spec/use-morphisms ;; only use morphisms for these
- (default '())
- (sanitize (morphism-sanitizer (parameter-spec/local this-parameter-spec)))
- (thunked))
- (parameter-alist parameter-spec/parameter-alist ;; this is ultimately what will be transformed by --with-parameters
- ;; '((a . #t) (b . #f) ...)
- (default (parameter-spec/base-parameter-alist this-parameter-spec)) ; if this doesn't work some tricks might be needed
- (thunked)))
- ;; g23: Most parameters should be boolean
- ;; Might make sense to add a recursive type
- ;; (define boolean
- ;; ;; The Boolean parameter type.
- ;; (parameter-type (name 'boolean)
- ;; (universe '(#t #f))
- ;; (value->string
- ;; (match-lambda
- ;; (#f "off")
- ;; (#t "on")))
- ;; (string->value
- ;; (lambda (str)
- ;; (cond ((string-ci=? str "on")
- ;; #t)
- ;; ((string-ci=? str "off")
- ;; #f)
- ;; (else
- ;; (raise (condition
- ;; (&message (message "wrong value"))))))))))
- (define-syntax parameter-spec-property
- (syntax-rules ()
- [(parameter-spec-property body ...)
- (cons 'parameter-spec
- (parameter-spec body ...))]))
- (define-syntax package-with-parameters
- (syntax-rules ()
- [(package-with-parameters body ...)
- (let ((the-package (package body ...)))
- ((options->transformation
- (apply append
- (let ((the-build-system (package-build-system the-package)))
- (map (lambda (x)
- (transform-for-build-system
- (assq-ref (parameter-spec/use-transforms
- (package-parameter-spec the-package))
- (car x))
- the-build-system))
- (filter (lambda (x) (eqv? #t (cdr x)))
- (parameter-spec/parameter-alist
- (package-parameter-spec the-package)))))))
- the-package))]))
- (define (package-parameter-spec package)
- (or (assq-ref (package-properties package) 'parameter-spec)
- '()))
- ;;; PROCESSING PIPELINE
- ;; % HELPER FUNCTIONS %
- (define (return-list lst)
- (or (and (list? lst) lst)
- (list lst)))
- (define (append-everything . things)
- (apply append
- (map return-list things)))
- (define (get-parameter-sym psym)
- (match psym
- [(a . b) a]
- [a a]))
- ;; Convention:
- ;; Works on Parameters? -> parameter-spec/fun
- ;; Works on Parameter-Spec? -> parameter-spec/fun
- (define (parameter-spec/get-parameter pspec psym)
- (or (find (lambda (x)
- (eqv? psym
- (package-parameter-name x)))
- (parameter-spec/local pspec))
- (hash-ref %global-parameters psym)
- (throw "Parameter not found: " psym)))
- (define (paramerer-spec/negation-supported? pspec x)
- (let ((negv
- (parameter-type-negation (parameter/paramerer-type (parameter-spec/get-parameter pspec x)))))
- (if negv
- negv
- %match-all)))
- ;; (define (parameter-spec/get-dependencies pspec lst)
- ;; (apply
- ;; append
- ;; (map
- ;; (lambda (x)
- ;; (cons x
- ;; (assq-ref
- ;; (assq-ref (parameter-spec-dependencies pspec) x)
- ;; 'parameters)))
- ;; lst)))
- (define (parameter-spec/get-dependencies psym)
- (let ([p (parameter-spec/get-parameter pspec psym)])
- (return-list
- (assq-ref (package-parameter-dependencies p)
- 'parameters))))
- ;; 1. Fetching
- (define (parameter-spec/base-parameter-alist pspec) ; returns base case
- ;; '((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
- (map (cut parameter-spec/get-dependencies pspec <>)
- (return-list v1)))
- v1))))
- ;; funnel will signal duplication err
- v2))
- ;; 2. Processing
- (define (parameter/process-list lst)
- (define (unexclaim p) ; step 1
- (define (negated-sym? p)
- (string=? (string-take-right (symbol->string (car (return-list p))) 1) "!"))
- (match p
- ;; Signal error if p! is in a cell
- [((? negated-sym? a) . b) (throw 'negation-in-cell! p)]
- [(a . b) p] ; normal cells are OK
- [(? negated-sym? a) (cons (string->symbol
- (string-drop-right (symbol->string a) 1))
- '%match-none)]
- [_ p]))
- (define (cellulize p) ; step 2 + 3
- (match p
- [(a b) (cons a b)]
- [(a . b) p]
- [a (cons a '%match-any)]))
- (define (desugarize p) ; step 4
- (match p
- [(a . '_) (cons a '%match-any)]
- [(a . '!) (cons a '%match-none)]
- [_ p]))
- (define (funnel plst) ; step 5
- ;; first we will get a list indexed by keys
- (define (group-val carry lst)
- (if (null-list? lst)
- carry
- (let ((v (assq-ref carry (caar lst))))
- (group-val
- (assq-set! carry (caar lst)
- (if v
- (cons (cdar lst) v)
- ;; We want a list in cdr
- (cons (cdar lst) '())))
- (cdr lst)))))
- (define (figure-out p)
- (or (and (< (length p) 3)
- (or (and (eq? (length p) 1) (car p))
- (and (member '%match-any p)
- (car (delq '%match-any p)))))
- (throw 'too-many-elements! p)))
- (map (lambda (x) (cons (car x)
- (figure-out
- (delete-duplicates (cdr x)))))
- (group-val '() plst)))
- (funnel (map (lambda (x)
- (desugarize (cellulize (unexclaim x))))
- lst)))
- ;; 3. Overriding
- ;; This will get us all the parameters
- (define (parameter-spec/all-parameters pspec) ; for the UI
- ;; '(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
- (apply append (parameter-spec/one-of pspec))
- (parameter-spec/optional pspec)))))
- ;; Now we compare it against the PLIST
- (define (parameter-spec/override-plist pspec plist)
- (let* ((all-p (parameter-spec/all-parameters pspec))
- (filtered-plist (filter (lambda (x) (member (car x) all-p))
- (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 (paramerer-spec/negation-supported? pspec x)
- (cons x %match-none)
- (cons x %match-all)))
- remaining-p))))
- ;; 4. Funneling
- (define (parameter-spec/override-multi-match pspec plst)
- (map
- (match-lambda
- [(a . '%match-any)
- (cons a
- (cadr (parameter-type-universe (package-parameter (parameter-spec/get-parameter pspec a)))))]
- [(a . '%match-none)
- (cons a
- (parameter-type-negation (package-parameter (parameter-spec/get-parameter pspec a))))]
- [cell cell])
- plst))
-
- ;; 5. Validation
- (define (parameter-spec/validate pspec plst)
- ;; We want all tests to run
- (let ((works? #t))
- (define (m+eqv? new-val orig-val)
- (or (eqv? orig-val '%match-any)
- (eqv? orig-val new-val)))
- (define (throw+f sym vals)
- (display "Error: ")
- (display sym)
- (display " with values ")
- (display vals)
- (newline)
- (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
- (m+eqv? (assq-ref plst (car x))
- (cdr x))
- (throw+f 'unsatisfied-requirement x)))
- (parameter/process-list
- (parameter-spec-required pspec)))
- (map ; one-of
- (lambda (ls)
- (unless
- (= 1
- (count
- (lambda (x)
- (m+eqv? (assq-ref plst (car x))
- (cdr x)))
- (parameter/process-list ls)))
- (throw+f 'one-of-unsatisfied ls)))
- (parameter-spec-one-of pspec))
- ;; XXX: Needs a per-parameter rewrite
- ;; (map ; dependencies
- ;; (lambda (x)
- ;; (let ([deplst (parameter/process-list
- ;; (assq-ref
- ;; (assq-ref (parameter-spec-dependencies pspec) x)
- ;; 'parameters))])
- ;; (map
- ;; (lambda (y)
- ;; (unless (m+eqv? (assq-ref plst (car y))
- ;; (cdr y))
- ;; (throw+f 'dependency-unsatisfied y)))
- ;; deplst)))
- ;; plst)
- )
- (validate/duplication)
- (validate/logic)
- works?))
- (define (parameter-spec/resolve-list pspec plst)
- (let ([proper-plst (parameter-spec/override-multi-match
- pspec
- (parameter-spec/override-plist
- pspec
- (parameter/process-list plst)))])
- (if (parameter-spec/validate pspec proper-plst)
- proper-plst
- (parameter-spec/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-global-parameter (package-parameter
- ;; (name "tests!")
- ;; (description "no tests")))
- ;; Works!
- (define-syntax parameter/inside?
- (syntax-rules ()
- [(% p plst)
- (not
- (eqv? (or (assq-ref plst 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))]))
- ;; Test these macros without using packages:
- ;; (define (parameter-spec/parameter-alist _)
- ;; (list (cons 'a 1)
- ;; (cons 'b 2)
- ;; (cons 'c 3)))
- ;; (define (package-parameter-spec _) #t)
- ;; (define this-package '())
- ;; (parameter/if '(a (b 3))
- ;; "YES"
- ;; "NO")
- ;; (parameter/if-all '(a (b 3))
- ;; "NO"
- ;; "YES)
- ;; parameter/match-any:
- ;; (parameter/match-any
- ;; ((a b) e1 e2 ..)
- ;; ((c) d1 d2 ..)
- ;; (else c1 c2 ...))
- (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 ...)))]))
- ;; (let ((SOME_ALIST_FOR_THIS_EXAMPLE '()))
- ;; (parameter/match-any
- ;; (('a 'd)
- ;; (set! SOME_ALIST_FOR_THIS_EXAMPLE (append '(1) SOME_ALIST_FOR_THIS_EXAMPLE))
- ;; (set! SOME_ALIST_FOR_THIS_EXAMPLE (append '(2) SOME_ALIST_FOR_THIS_EXAMPLE)))
- ;; (('c))
- ;; (('e)
- ;; (set! SOME_ALIST_FOR_THIS_EXAMPLE (append '(3) SOME_ALIST_FOR_THIS_EXAMPLE)))
- ;; (all
- ;; (set! SOME_ALIST_FOR_THIS_EXAMPLE (append '(4) SOME_ALIST_FOR_THIS_EXAMPLE))))
- ;; SOME_ALIST_FOR_THIS_EXAMPLE)
- ;; The answer to this should be '(4 2 1)
- ;; note that all is essentially useless, one can simply put the expression in all
- ;; outside the macro and it will work the same
- (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 ...)))]))
- ;; (parameter/match-all
- ;; (('a 'b) (display "YES") (display "YES"))
- ;; (('c 'd) (display "NO"))
- ;; (all (display "ALL")))
- (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 ...)))]))
- ;; should short-circuit at YESYES
- ;; (parameter/match-case
- ;; (('a 'b 'e) (display "YES") (display "YES"))
- ;; (('c 'd) (display "NO"))
- ;; (all (display "ALL")))
- ;; parameter/match:
- ;; combine all and any into one
- ;; (parameter/match
- ;; ((any a b) ...)
- ;; ((all a b c) ...)
- ;; (all ...))
- (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 ...)))]))
- ;; (parameter/match
- ;; ((all 'a 'b) (display "YES"))
- ;; (_ (display "YES"))
- ;; (('c 'e) (display "YES"))
- ;; ((all 'a 'o) (display "NO"))
- ;; (_ (display "ALL")))
- (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 ...)))]))
- ;; (parameter/match-case
- ;; ((all 'a 'f) (display "NO"))
- ;; ;; (all (display "YES"))
- ;; ;; ((any 'c 'e) (display "YES"))
- ;; ;; ((all 'a 'b) (display "YES"))
- ;; (all (display "ALL")))
- (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))]
- ;; [(% (all parameter) exp exp2) ; unnecessary
- ;; (let ((properties (parameter-spec/parameter-alist (package-parameter-spec this-package))))
- ;; (if (parameter/inside? parameter properties)
- ;; exp
- ;; exp-else))]
- [(% 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]))
- ;; (parameter-type-negation
- ;; (parameter-type
- ;; (name "ok")
- ;; (universe '(not-ok ok))))
- (define-syntax parameter/type
- (syntax-rules (_)
- [(% _ rest ...)
- (parameter/type (string-append (or (package-parameter-name this-package-parameter)
- "%blank")
- "-type")
- rest ...)]
- [(% t-name t-universe)
- (parameter-type
- (name t-name)
- (universe t-universe))]
- [(% t-name t-universe t-negation)
- (parameter-type
- (name t-name)
- (universe t-universe)
- (negation t-negation))]
- [(% t-name t-universe t-negation t-description)
- (parameter-type
- (name t-name)
- (universe t-universe)
- (negation t-negation)
- (description t-description))]))
- ;; (parameter-type-negation (parameter/type _ '(1 2 3)))
- ;;
- ;; (define (package-parameter-name _) #f)
- ;; (define this-package-parameter #f)
|