aboutsummaryrefslogtreecommitdiff
path: root/lib/scope.js
AgeCommit message (Expand)Author
2017-11-24fix `rename` (#2501)...- suppress spurious `rename` from `commander` - handle `AST_SymbolCatch` correctlyAlex Lam S.L
2017-11-19expand symbol space to improve compression (#2460)...- give globally distinct names to distinct variables - improve ability to compress cross-scoped - introduce `options.rename` to `minify()` - default `true` if both `compress` & `mangle`Alex Lam S.L
2017-11-12allow symbol replacement on multiple occurrences (#2472)...- all-or-nothing replacement - avoid unmangleable names fixes #2436Alex Lam S.L
2017-08-01fix `ie8` mangling of top-level `AST_SymbolCatch` (#2263)...fixes #2254 Alex Lam S.L
2017-07-15drop `unused` builtin globals under `unsafe` (#2236)...fixes #2233Alex Lam S.L
2017-06-23refactor `compute_char_frequency()` (#2152)...- minimise maintenance when updating AST - maximise code sharing between `master` & `harmony`Alex Lam S.L
2017-06-20ensure mangling works if catch reuses a scope variable (#2123)...fixes #2120Alex Lam S.L
2017-06-15compute `uses_arguments` correctly in `figure_out_scope()` (#2099)...fixes #2097Alex Lam S.L
2017-06-09marshal `mangle[.properties].reserved` from non-Array values (#2072)Alex Lam S.L
2017-05-26clean up `lib/scope.js` (#2003)...fixes #2004Alex Lam S.L
2017-05-14fix bugs with getter/setter (#1926)...- `reduce_vars` - `side_effects` - property access for object - `AST_SymbolAccessor` as key names enhance `test/ufuzz.js` - add object getter & setter - property assignment to setter - avoid infinite recursion in setter - fix & adjust assignment operators - 50% `=` - 25% `+=` - 2.5% each for the rest - avoid "Invalid array length" - fix `console.log()` - bypass getter - curb recursive reference - deprecate `-E`, always report runtime errorsAlex Lam S.L
2017-05-12remove support for `const` (#1910)...As this is not part of ES5.Alex Lam S.L
2017-04-17compress duplicated variable definitions (#1817)...These are surprisingly common, as people reuse the same variable name within loops or switch branches.Alex Lam S.L
2017-04-15unify CLI & API under `minify()` (#1811)...- rename `screw_ie8` to `ie8` - rename `mangle.except` to `mangle.reserved` - rename `mangle.properties.ignore_quoted` to `mangle.properties.keep_quoted` - compact `sourceMap` options - more stringent verification on input `options` - toplevel shorthands - `ie8` - `keep_fnames` - `toplevel` - `warnings` - support arrays and unquoted string values on CLI - drop `fromString` from `minify()` - `minify()` no longer handles any `fs` operations - unify order of operations for `mangle_properties()` on CLI & API - `bin/uglifyjs` used to `mangle_properties()` before even `Compressor` - `minify()` used to `mangle_properties()` after `Compressor` but before `mangle_names()` - both will now do `Compressor`, `mangle_names()` then `mangle_properties()` - `options.parse` / `--parse` for parser options beyond `bare_returns` - add `mangle.properties.builtins` to disable built-in reserved list - disable with `--mangle-props builtins` on CLI - `warnings` now off by default - add `--warn` and `--verbose` on CLI - drop `--enclose` - drop `--export-all` - drop `--reserved-file` - use `--mangle reserved` instead - drop `--reserve-domprops` - enabled by default, disable with `--mangle-props domprops` - drop `--prefix` - use `--source-map base` instead - drop `--lint` - remove `bin/extract-props.js` - limit exposure of internal APIs - update documentations closes #96 closes #102 closes #136 closes #166 closes #243 closes #254 closes #261 closes #311 closes #700 closes #748 closes #912 closes #1072 closes #1366 fixes #101 fixes #123 fixes #124 fixes #263 fixes #379 fixes #419 fixes #423 fixes #461 fixes #465 fixes #576 fixes #737 fixes #772 fixes #958 fixes #1036 fixes #1142 fixes #1175 fixes #1220 fixes #1223 fixes #1280 fixes #1359 fixes #1368Alex Lam S.L
2017-03-31sort options in alphabetical order (#1743)...They started off as functional groups I guess, but given the sheer number of options this is becoming too difficult to read.Alex Lam S.L
2017-03-31fix catch symbol mangling (#1734)...Only need to look up the immediate non-block/catch scope for the same-name special case. fixes #1733Alex Lam S.L
2017-03-28handle var within catch of the same name (#1711)...The following code prints `1`: var a = 1; !function(){ a = 4; try{ throw 2; } catch (a) { var a = 3; } }(); console.log(a); fixes #1708Alex Lam S.L
2017-03-28fix mangle for variable declared within catch block (#1706)...fixes #1704Alex Lam S.L
2017-03-27handle overlapped variable definitions (#1691)...Process variable definitions with or without assigned values against: - `arguments` - named function arguments - multiple definitions within same scope Essentially demote variable declarations with no value assignments. Also fixed invalid use of `AST_VarDef` over `arguments` - should use a member of `AST_SymbolDeclaration` instead.Alex Lam S.L
2017-03-10fix catch variable reference in IE8 (#1587)...`AST_Scope.def_variable()` will overwrite `AST_Symbol.thedef`, so save a copy before calling. fixes #1586Alex Lam S.L
2017-03-05handle variable declaration within catch blocks (#1546)...accounts for IE8- scopingAlex Lam S.L
2017-03-05stay safe with constants in IE8- (#1547)...- `undefined` etc. can be redefined at top-level for IE8-, so disable related optimisations - fixed `--support-ie8` catch mangle bugAlex Lam S.L
2017-02-26consolidate `evaluate` & `reduce_vars` (#1505)...- improve marking efficiency - apply smarter `const` replacement to `var` fixes #1501Alex Lam S.L
2017-02-24enable `collapse_vars` & `reduce_vars` by default...- fix corner cases in `const` optimisation - deprecate `/*@const*/` fixes #1497 closes #1498 alexlamsl
2017-02-21enhance `global_defs`...- support arrays, objects & AST_Node - support `"a.b":1` on both cli & API - emit warning if variable is modified - override top-level variables fixes #1416 closes #1198 closes #1469 alexlamsl
2017-02-21improve reduce_vars and fix a bug...- update modified flag between compress() passes - support IIFE arguments - fix corner case with multiple definitions closes #1473 alexlamsl
2017-02-18fix corner case in keep_fnames...happens when inner function: - just below top level - not referenced - `unused` is disabled closes #1445 alexlamsl
2017-02-18remove unused AST_Scope.nesting & AST_SymbolRef.frame...they are computed but never used closes #1444 alexlamsl
2017-01-26fix mangling collision with keep_fnames (#1431)...* fix mangling collision with keep_fnames fixes #1423 * pass mangle options to figure_out_scope() bring command-line in line with minify() Alex Lam S.L
2017-01-26augment evaluate to extract within objects (#1425)...- gated by `unsafe` - replaces previous optimisation specific to String.length - "123"[0] => 1 - [1, 2, 3][0] => 1 - [1, 2, 3].length => 3 - does not apply to objects with overridden prototype functionsAlex Lam S.L
2017-01-19add missing LHS cases which global_defs should avoidalexlamsl
2016-10-23fix uses_arguments handling (broken since 6605d1578351)...Using the symbol declaration tracking of UglifyJS doesn't make sense here anyway, `arguments` always comes from something in the current scope. fixes #1299 Jann Horn
2016-10-01Optimize unmodified variablesalexlamsl
2016-07-15Fix mangle with option keep_fnames=true for Safari....Fixes: #1202 kzc
2016-06-30Enable --screw-ie8 by default....catch identifier is mangled correctly for ES5 standards-compliant JS engines by default. Unconditionally use the ie8 if/do-while workaround whether or not --screw-ie8 is enabled. To support non-standard ie8 javascript use: uglifyjs --support-ie8 kzc
2016-03-28Speedup `unused` compress option for already minified code...Fixes: #321 #917 #1022 kzc
2016-02-27#877 Ignore mangle sort optionkzc
2016-02-17preserve ThisBinding for side_effectsalexlamsl
2016-01-27Add start/end in the `arguments` definition...(keeps my https://github.com/mishoo/jsinfo.el working) Mihai Bazon
2016-01-20Tighten up @const regex.Samuel Reed
2016-01-20Simplify by skipping extra tree walk.Samuel Reed
2016-01-20Use TreeWalker for more accurate @const results and update testsSamuel Reed
2016-01-19Mark vars with /** @const */ pragma as consts so they can be eliminated....Fixes older browser support for consts and allows more flexibility in dead code removal. Samuel Reed
2016-01-14Never mangle arguments and keep them in their scope...Fixes #892 Helped-by: kzc Anthony Van de Gejuchte
2015-11-12Build label def/refs info when figuring out scope...Fix #862 Mihai Bazon
2015-11-11Rework has_directive...It's now available during tree walking, i.e. walker.has_directive("use asm"), rather than as part of the scope. It's thus no longer necessary to call `figure_out_scope` before codegen. Added special bits in the code generator to overcome the fact that it doesn't inherit from TreeWalker. Fix #861 Mihai Bazon
2015-10-07Add proper support for "use asm"; blocks. Disable -c optimization within "use...kzc
2015-03-16rename --prop-cache to --name-cache...... and support storing there variable names as well, to help with multiple invocations when mangling toplevel. Mihai Bazon
2015-01-04Add an option to prevent function names from being mangled...See #552. This is mostly useful for having the actual function names in traces. Richard van Velzen
2014-12-01fix base54Cheng Liangyu
-file)) ,@(if channels `(("channels.scm" ,(plain-file "channels.scm" (object->pretty-string `(list ,@(map channel->code channels)))))) '()) ,@(if config-file `(("configuration.scm" ,config-file)) '())))))) (define provenance-service-type (service-type (name 'provenance) (extensions (list (service-extension system-service-type provenance-entry))) (default-value #f) ;the OS config file (description "Store provenance information about the system in the system itself: the channels used when building the system, and its configuration file, when available."))) (define (sexp->system-provenance sexp) "Parse SEXP, an s-expression read from /run/current-system/provenance or similar, and return two values: the list of channels listed therein, and the OS configuration file or #f." (match sexp (('provenance ('version 0) ('channels channels ...) ('configuration-file config-file)) (values (map sexp->channel channels) config-file)) (_ (values '() #f)))) (define (system-provenance system) "Given SYSTEM, the file name of a system generation, return two values: the list of channels SYSTEM is built from, and its configuration file. If that information is missing, return the empty list (for channels) and possibly #false (for the configuration file)." (catch 'system-error (lambda () (sexp->system-provenance (call-with-input-file (string-append system "/provenance") read))) (lambda _ (values '() #f)))) ;;; ;;; Cleanup. ;;; (define (cleanup-gexp _) "Return a gexp to clean up /tmp and similar places upon boot." (with-imported-modules '((guix build utils)) #~(begin (use-modules (guix build utils)) ;; Clean out /tmp, /var/run, and /run. ;; ;; XXX This needs to happen before service activations, so it ;; has to be here, but this also implicitly assumes that /tmp ;; and /var/run are on the root partition. (letrec-syntax ((fail-safe (syntax-rules () ((_ exp rest ...) (begin (catch 'system-error (lambda () exp) (const #f)) (fail-safe rest ...))) ((_) #t)))) ;; Ignore I/O errors so the system can boot. (fail-safe ;; Remove stale Shadow lock files as they would lead to ;; failures of 'useradd' & co. (delete-file "/etc/group.lock") (delete-file "/etc/passwd.lock") (delete-file "/etc/.pwd.lock") ;from 'lckpwdf' ;; Force file names to be decoded as UTF-8. See ;; <https://bugs.gnu.org/26353>. (setenv "GUIX_LOCPATH" #+(file-append (libc-utf8-locales-for-target (%current-system)) "/lib/locale")) (setlocale LC_CTYPE "en_US.utf8") (delete-file-recursively "/tmp") (delete-file-recursively "/var/run") (delete-file-recursively "/run") ;; Note: The second argument to 'mkdir' is and'ed with umask, ;; hence the 'chmod' calls. (mkdir "/tmp" #o1777) (chmod "/tmp" #o1777) (mkdir "/var/run" #o755) (chmod "/var/run" #o755) (mkdir "/run" #o755) (chmod "/var/run" #o755)))))) (define cleanup-service-type ;; Service that cleans things up in /tmp and similar. (service-type (name 'cleanup) (extensions (list (service-extension boot-service-type cleanup-gexp))) (description "Delete files from @file{/tmp}, @file{/var/run}, and other temporary locations at boot time."))) (define* (activation-service->script service) "Return as a monadic value the activation script for SERVICE, a service of ACTIVATION-SCRIPT-TYPE." (activation-script (service-value service))) (define (activation-script gexps) "Return the system's activation script, which evaluates GEXPS." (define actions (map (cut program-file "activate-service.scm" <>) gexps)) (program-file "activate.scm" (with-imported-modules (source-module-closure '((gnu build activation) (guix build utils))) #~(begin (use-modules (gnu build activation) (guix build utils)) (mkdir-p "/var/run") ;; Make sure the user accounting database exists. If it ;; does not exist, 'setutxent' does not create it and ;; thus there is no accounting at all. (close-port (open-file "/var/run/utmpx" "a0")) ;; Same for 'wtmp', which is populated by mingetty et ;; al. (mkdir-p "/var/log") (close-port (open-file "/var/log/wtmp" "a0")) ;; Set up /run/current-system. Among other things this ;; sets up locales, which the activation snippets ;; executed below may expect. (activate-current-system) ;; Run the services' activation snippets. ;; TODO: Use 'load-compiled'. (for-each primitive-load '#$actions))))) (define (gexps->activation-gexp gexps) "Return a gexp that runs the activation script containing GEXPS." #~(primitive-load #$(activation-script gexps))) (define (activation-profile-entry gexps) "Return, as a monadic value, an entry for the activation script in the system directory." (mlet %store-monad ((activate (lower-object (activation-script gexps)))) (return `(("activate" ,activate))))) (define (second-argument a b) b) (define activation-service-type (service-type (name 'activate) (extensions (list (service-extension boot-service-type gexps->activation-gexp) (service-extension system-service-type activation-profile-entry))) (compose identity) (extend second-argument) (default-value #f) (description "Run @dfn{activation} code at boot time and upon @command{guix system reconfigure} completion."))) (define %activation-service ;; The activation service produces the activation script from the gexps it ;; receives. (service activation-service-type #t)) (define %modprobe-wrapper ;; Wrapper for the 'modprobe' command that knows where modules live. ;; ;; This wrapper is typically invoked by the Linux kernel ('call_modprobe', ;; in kernel/kmod.c), a situation where the 'LINUX_MODULE_DIRECTORY' ;; environment variable is not set---hence the need for this wrapper. (let ((modprobe "/run/current-system/profile/bin/modprobe")) (program-file "modprobe" #~(begin (setenv "LINUX_MODULE_DIRECTORY" "/run/booted-system/kernel/lib/modules") ;; FIXME: Remove this crutch when the patch #40422, ;; updating to kmod 27 is merged. (setenv "MODPROBE_OPTIONS" "-C /etc/modprobe.d") (apply execl #$modprobe (cons #$modprobe (cdr (command-line)))))))) (define %linux-kernel-activation ;; Activation of the Linux kernel running on the bare metal (as opposed to ;; running in a container.) #~(begin ;; Tell the kernel to use our 'modprobe' command. (activate-modprobe #$%modprobe-wrapper) ;; Let users debug their own processes! (activate-ptrace-attach))) (define %linux-bare-metal-service ;; The service that does things that are needed on the "bare metal", but not ;; necessary or impossible in a container. (simple-service 'linux-bare-metal activation-service-type %linux-kernel-activation)) (define %hurd-rc-script ;; The RC script to be started upon boot. (program-file "rc" (with-imported-modules (source-module-closure '((guix build utils) (gnu build hurd-boot) (guix build syscalls))) #~(begin (use-modules (guix build utils) (gnu build hurd-boot) (guix build syscalls) (ice-9 match) (system repl repl) (srfi srfi-1) (srfi srfi-26)) (boot-hurd-system))))) (define (hurd-rc-entry rc) "Return, as a monadic value, an entry for the RC script in the system directory." (mlet %store-monad ((rc (lower-object rc))) (return `(("rc" ,rc))))) (define hurd-startup-service-type ;; The service that creates the initial SYSTEM/rc startup file. (service-type (name 'startup) (extensions (list (service-extension system-service-type hurd-rc-entry))) (default-value %hurd-rc-script) (description "This service creates an @file{rc} script in the system; that script is responsible for booting the Hurd."))) (define %hurd-startup-service ;; The service that produces the RC script. (service hurd-startup-service-type %hurd-rc-script)) (define special-files-service-type ;; Service to install "special files" such as /bin/sh and /usr/bin/env. (service-type (name 'special-files) (extensions (list (service-extension activation-service-type (lambda (files) #~(activate-special-files '#$files))))) (compose concatenate) (extend append) (description "Add special files to the root file system---e.g., @file{/usr/bin/env}."))) (define (extra-special-file file target) "Use TARGET as the \"special file\" FILE. For example, TARGET might be (file-append coreutils \"/bin/env\") and FILE could be \"/usr/bin/env\"." (simple-service (string->symbol (string-append "special-file-" file)) special-files-service-type `((,file ,target)))) (define (etc-directory service) "Return the directory for SERVICE, a service of type ETC-SERVICE-TYPE." (files->etc-directory (service-value service))) (define (files->etc-directory files) (define (assert-no-duplicates files) (let loop ((files files) (seen (set))) (match files (() #t) (((file _) rest ...) (when (set-contains? seen file) (raise (formatted-message (G_ "duplicate '~a' entry for /etc") file))) (loop rest (set-insert file seen)))))) ;; Detect duplicates early instead of letting them through, eventually ;; leading to a build failure of "etc.drv". (assert-no-duplicates files) (file-union "etc" files)) (define (etc-entry files) "Return an entry for the /etc directory consisting of FILES in the system directory." (with-monad %store-monad (return `(("etc" ,(files->etc-directory files)))))) (define etc-service-type (service-type (name 'etc) (extensions (list (service-extension activation-service-type (lambda (files) (let ((etc (files->etc-directory files))) #~(activate-etc #$etc)))) (service-extension system-service-type etc-entry))) (compose concatenate) (extend append) (default-value '()) (description "Populate the @file{/etc} directory."))) (define-deprecated (etc-service files) etc-service-type "Return a new service of ETC-SERVICE-TYPE that populates /etc with FILES. FILES must be a list of name/file-like object pairs." (service etc-service-type files)) (define (privileged-program->activation-gexp programs) "Return an activation gexp for privileged-program from PROGRAMS." (let ((programs (map (lambda (program) ;; FIXME This is really ugly, I didn't manage to use "inherit". (let ((program-name (privileged-program-program program)) (setuid? (privileged-program-setuid? program)) (setgid? (privileged-program-setgid? program)) (user (privileged-program-user program)) (group (privileged-program-group program)) (capabilities (privileged-program-capabilities program))) (unless (or setuid? setgid? capabilities) (warning (G_ "so-called privileged-program ~s lacks any privilege~%") program-name)) #~(privileged-program (setuid? #$setuid?) (setgid? #$setgid?) (user #$user) (group #$group) (capabilities #$capabilities) (program #$program-name)))) programs))) (with-imported-modules (source-module-closure '((gnu system privilege))) #~(begin (use-modules (gnu system privilege)) (let ((libcap #$(let-system (system target) ;; When cross-compiling, assume libcap is ;; available on GNU/Linux only. (and (if target (string-suffix? "linux-gnu" target) (supported-package? libcap system)) libcap)))) (activate-privileged-programs (list #$@programs) libcap)))))) (define privileged-program-service-type (service-type (name 'privileged-program) (extensions (list (service-extension activation-service-type privileged-program->activation-gexp))) (compose concatenate) (extend (lambda (config extensions) (append config extensions))) (description "Copy the specified executables to @file{/run/privileged/bin} and apply special privileges like setuid and/or setgid. The deprecated @file{/run/setuid-programs} directory is also populated with symbolic links to their @file{/run/privileged/bin} counterpart. It will be removed in a future Guix release."))) (define-deprecated/alias setuid-program-service-type ;; Deprecated alias to ease transition. Will be removed! privileged-program-service-type) (define (packages->profile-entry packages) "Return a system entry for the profile containing PACKAGES." ;; XXX: 'mlet' is needed here for one reason: to get the proper ;; '%current-target' and '%current-target-system' bindings when ;; 'packages->manifest' is called, and thus when the 'package-inputs' ;; etc. procedures are called on PACKAGES. That way, conditionals in those ;; inputs see the "correct" value of these two parameters. See ;; <https://issues.guix.gnu.org/44952>. (mlet %store-monad ((_ (current-target-system))) (return `(("profile" ,(profile (content (packages->manifest (delete-duplicates packages eq?))))))))) (define profile-service-type ;; The service that populates the system's profile---i.e., ;; /run/current-system/profile. It is extended by package lists. (service-type (name 'profile) (extensions (list (service-extension system-service-type packages->profile-entry))) (compose concatenate) (extend append) (default-value '()) (description "This is the @dfn{system profile}, available as @file{/run/current-system/profile}. It contains packages that the sysadmin wants to be globally available to all the system users."))) (define (firmware->activation-gexp firmware) "Return a gexp to make the packages listed in FIRMWARE loadable by the kernel." (let ((directory (directory-union "firmware" firmware))) ;; Tell the kernel where firmware is. #~(activate-firmware (string-append #$directory "/lib/firmware")))) (define firmware-service-type ;; The service that collects firmware. (service-type (name 'firmware) (extensions (list (service-extension activation-service-type firmware->activation-gexp))) (compose concatenate) (extend append) (description "Make ``firmware'' files loadable by the operating system kernel. Firmware may then be uploaded to some of the machine's devices, such as Wifi cards."))) (define (gc-roots->system-entry roots) "Return an entry in the system's output containing symlinks to ROOTS." (mlet %store-monad ((entry (gexp->derivation "gc-roots" #~(let ((roots '#$roots)) (mkdir #$output) (chdir #$output) (for-each symlink roots (map number->string (iota (length roots)))))))) (return (if (null? roots) '() `(("gc-roots" ,entry)))))) (define gc-root-service-type ;; A service to associate extra garbage-collector roots to the system. This ;; is a simple hack that guarantees that the system retains references to ;; the given list of roots. Roots must be "lowerable" objects like ;; packages, or derivations. (service-type (name 'gc-roots) (extensions (list (service-extension system-service-type gc-roots->system-entry))) (compose concatenate) (extend append) (description "Register garbage-collector roots---i.e., store items that will not be reclaimed by the garbage collector.") (default-value '()))) ;; Configuration for the Linux kernel builder. (define-record-type* <linux-builder-configuration> linux-builder-configuration make-linux-builder-configuration linux-builder-configuration? this-linux-builder-configuration (kernel linux-builder-configuration-kernel) ; package (modules linux-builder-configuration-modules (default '()))) ; list of packages (define (package-for-kernel target-kernel module-package) "Return a package like MODULE-PACKAGE, adapted for TARGET-KERNEL, if possible (that is if there's a LINUX keyword argument in the build system)." (package (inherit module-package) (arguments (substitute-keyword-arguments (package-arguments module-package) ((#:linux kernel #f) target-kernel))))) (define (linux-builder-configuration->system-entry config) "Return the kernel entry of the 'system' directory." (let* ((kernel (linux-builder-configuration-kernel config)) (modules (linux-builder-configuration-modules config)) (kernel (profile (content (packages->manifest (cons kernel (map (lambda (module) (cond ((package? module) (package-for-kernel kernel module)) ;; support (,package "kernel-module-output") ((and (list? module) (package? (car module))) (cons (package-for-kernel kernel (car module)) (cdr module))) (else module))) modules)))) (hooks (list linux-module-database))))) (with-monad %store-monad (return `(("kernel" ,kernel)))))) (define linux-builder-service-type (service-type (name 'linux-builder) (extensions (list (service-extension system-service-type linux-builder-configuration->system-entry))) (default-value '()) (compose identity) (extend (lambda (config modifiers) (if (null? modifiers) config ((apply compose modifiers) config)))) (description "Builds the linux-libre kernel profile, containing the kernel itself and any linux-loadable kernel modules. This can be extended with a function that accepts the current configuration and returns a new configuration."))) (define (linux-loadable-module-builder-modifier modules) "Extends linux-builder-service-type by appending the given MODULES to the configuration of linux-builder-service-type." (lambda (config) (linux-builder-configuration (inherit config) (modules (append (linux-builder-configuration-modules config) modules))))) (define linux-loadable-module-service-type (service-type (name 'linux-loadable-modules) (extensions (list (service-extension linux-builder-service-type linux-loadable-module-builder-modifier))) (default-value '()) (compose concatenate) (extend append) (description "Adds packages and package outputs as modules included in the booted linux-libre profile. Other services can extend this service type to add particular modules to the set of linux-loadable modules."))) ;;; ;;; Service folding. ;;; (define-condition-type &missing-target-service-error &service-error missing-target-service-error? (service missing-target-service-error-service) (target-type missing-target-service-error-target-type)) (define-condition-type &ambiguous-target-service-error &service-error ambiguous-target-service-error? (service ambiguous-target-service-error-service) (target-type ambiguous-target-service-error-target-type)) (define (missing-target-error service target-type) (raise (condition (&missing-target-service-error (service service) (target-type target-type)) (&message (message (format #f (G_ "no target of type '~a' for service '~a'") (service-type-name target-type) (service-type-name (service-kind service)))))))) (define (service-back-edges services) "Return a procedure that, when passed a <service>, returns the list of <service> objects that depend on it." (define (add-edges service edges) (define (add-edge extension edges) (let ((target-type (service-extension-target extension))) (match (filter (lambda (service) (eq? (service-kind service) target-type)) services) ((target) (vhash-consq target service edges)) (() (missing-target-error service target-type)) (x (raise (condition (&ambiguous-target-service-error (service service) (target-type target-type)) (&message (message (format #f (G_ "more than one target service of type '~a'") (service-type-name target-type)))))))))) (fold add-edge edges (service-type-extensions (service-kind service)))) (let ((edges (fold add-edges vlist-null services))) (lambda (node) (reverse (vhash-foldq* cons '() node edges))))) (define (instantiate-missing-services services) "Return SERVICES, a list, augmented with any services targeted by extensions and missing from SERVICES. Only service types with a default value can be instantiated; other missing services lead to a '&missing-target-service-error'." (define (adjust-service-list svc result instances) (fold2 (lambda (extension result instances) (define target-type (service-extension-target extension)) (match (vhash-assq target-type instances) (#f (let ((default (service-type-default-value target-type))) (if (eq? &no-default-value default) (missing-target-error svc target-type) (let ((new (service target-type))) (values (cons new result) (vhash-consq target-type new instances)))))) (_ (values result instances)))) result instances (service-type-extensions (service-kind svc)))) (let loop ((services services)) (define instances (fold (lambda (service result) (vhash-consq (service-kind service) service result)) vlist-null services)) (define adjusted (fold2 adjust-service-list services instances services)) ;; If we instantiated services, they might in turn depend on missing ;; services. Loop until we've reached fixed point. (if (= (length adjusted) (vlist-length instances)) adjusted (loop adjusted)))) (define* (fold-services services #:key (target-type system-service-type)) "Fold SERVICES by propagating their extensions down to the root of type TARGET-TYPE; return the root service adjusted accordingly." (define dependents (service-back-edges services)) (define (matching-extension target) (let ((target (service-kind target))) (match-lambda (($ <service-extension> type) (eq? type target))))) (define (apply-extension target) (lambda (service) (match (find (matching-extension target) (service-type-extensions (service-kind service))) (($ <service-extension> _ compute) (compute (service-value service)))))) (match (filter (lambda (service) (eq? (service-kind service) target-type)) services) ((sink) ;; Use the state monad to keep track of already-visited services in the ;; graph and to memoize their value once folded. (run-with-state (let loop ((sink sink)) (mlet %state-monad ((visited (current-state))) (match (vhash-assq sink visited) (#f (mlet* %state-monad ((dependents (mapm %state-monad loop (dependents sink))) (visited (current-state)) (extensions -> (map (apply-extension sink) dependents)) (extend -> (service-type-extend (service-kind sink))) (compose -> (service-type-compose (service-kind sink))) (params -> (service-value sink)) (service -> ;; Distinguish COMPOSE and EXTEND because PARAMS typically ;; has a different type than the elements of EXTENSIONS. (if extend (service (service-kind sink) (extend params (compose extensions))) sink))) (mbegin %state-monad (set-current-state (vhash-consq sink service visited)) (return service)))) ((_ . service) ;SINK was already visited (return service))))) vlist-null)) (() (raise (make-compound-condition (condition (&missing-target-service-error (service #f) (target-type target-type))) (formatted-message (G_ "service of type '~a' not found") (service-type-name target-type))))) (x (raise (condition (&ambiguous-target-service-error (service #f) (target-type target-type)) (&message (message (format #f (G_ "more than one target service of type '~a'") (service-type-name target-type))))))))) (define (remove-service-extensions type lst) "Return TYPE, a service type, without any of the service extensions targeting one of the types in LST." (service-type (inherit type) (extensions (remove (lambda (extension) (memq (service-extension-target extension) lst)) (service-type-extensions type))))) (define-syntax-parameter for-home? ;; Whether the configuration being defined is for a Home service. (identifier-syntax #f)) (define-syntax-rule (for-home exp ...) "Mark EXP, which typically defines a service configuration, as targeting a Home service rather than a System service." (syntax-parameterize ((for-home? (identifier-syntax #t))) exp ...)) (define-with-syntax-properties (validate-service-list (value properties)) (%validate-service-list value properties)) (define (%validate-service-list value properties) (match value (((? service?) ...) value) (_ (raise (make-compound-condition (condition (&error-location (location (source-properties->location properties)))) (formatted-message (G_ "'services' field must contain a list of services"))))))) ;;; services.scm ends here.