From 280dd782003075444037297a4a5dd5723ff1f459 Mon Sep 17 00:00:00 2001 From: Liliana Marie Prikler Date: Thu, 6 Jan 2022 15:08:24 +0100 Subject: [PATCH 1/3] Fixup 03/41. This commit adds several utility functions for non-destructive transformation of the JSON representation used by (guix build json), particularly for purely functional update of JSON objects. They ought to eventually be exported from their own module, but for now are kept private to allow experimentation. * guix/build/node-build-system.scm (assoc-ref*, jsobject-ref, alist-pop) (alist-update, jsobject-update*, jsobject-union): New variables. (with-atomic-json-file-replacement): New public variable. (module-name, build, patch-dependencies): Use them. Do not resort to unsafe alist primitives from Guile core. --- guix/build/node-build-system.scm | 313 +++++++++---------------------- 1 file changed, 85 insertions(+), 228 deletions(-) diff --git a/guix/build/node-build-system.scm b/guix/build/node-build-system.scm index 9967223b86..d695424e50 100644 --- a/guix/build/node-build-system.scm +++ b/guix/build/node-build-system.scm @@ -25,35 +25,12 @@ (define-module (guix build node-build-system) #:use-module (ice-9 ftw) #:use-module (ice-9 match) #:use-module (srfi srfi-1) + #:use-module (srfi srfi-71) #:export (%standard-phases with-atomic-json-file-replacement delete-dependencies node-build)) -;; Commentary: -;; -;; Builder-side code of the standard Node/NPM package install procedure. -;; -;; Code: - -;;; -;;; JSON utilities. -;;; -;;; The following procedures facilitate transforming JSON values using the -;;; representation from (guix build json), particularly purely functional -;;; update of JSON objects. If we decide to make more of them public, we -;;; might instead put them in their own file or, eventually, add them to -;;; (guix build json). -;;; -;;; JSON objects with duplicate keys are not interoperable: see RFC 8259 ยง 4. -;;; These procedures assume, but generally do not check, that JSON objects -;;; given to them as arguments do not have duplicate keys. As long as that -;;; precondition is satisfied, they will produce JSON objects without -;;; duplicate keys. Procedures that operate on unwrapped assosciation lists -;;; may do likewise, which should be considered before exporting them for -;;; general use. -;;; - (define (with-atomic-json-file-replacement file proc) "Like 'with-atomic-file-replacement', but PROC is called with a single argument---the result of parsing FILE's contents as json---and should a value @@ -62,205 +39,83 @@ (define (with-atomic-json-file-replacement file proc) (lambda (in out) (write-json (proc (read-json in)) out)))) -(define (jsobject-ref js key failure-result) - "Return the value assosciated with KEY in the json object JS. If KEY is not -found and FAILURE-RESULT is a procedure, it is called in tail position with -zero arguments. Otherwise, FAILURE-RESULT is returned." - ;; TODO: `failure-result` should be optional, but should the default - ;; `failure-result` be #f (like `assoc-ref`), a thunk raising an exception, - ;; '(@), or something else? Keep it mandatory until we discuss and decide. +(define* (assoc-ref* alist key #:optional default) + "Like assoc-ref, but return DEFAULT instead of #f if no value exists." + (match (assoc key alist) + (#f default) + ((_ . value) value))) + +(define* (jsobject-ref obj key #:optional default) + (match obj + (('@ . alist) (assoc-ref* alist key default)))) + +(define* (alist-pop alist key #:optional (= equal?)) + "Return two values, the first pair in ALIST with key KEY, and the other +elements. Equality calls are made as (= KEY ALISTCAR)." + (define (found? pair) + (= key (car pair))) + + (let ((before after (break found? alist))) + (if (pair? after) + (values (car after) (append before (cdr after))) + (values #f before)))) + +(define* (alist-update alist key proc #:optional default (= equal?)) + "Return an association list like ALIST, but with KEY mapped to the result of +PROC applied to the first value found under the comparison (= KEY ALISTCAR). +If no such value exists, use DEFAULT instead. +Unlike acons, this removes the previous association of KEY (assuming it is +unique), but the result may still share storage with ALIST." + (let ((pair rest (alist-pop alist key =))) + (acons key + (proc (if (pair? pair) + (cdr pair) + default)) + rest))) + +(define (jsobject-update* js . updates) + "Return a json object like JS, but with all UPDATES applied. Each update +is a list (KEY PROC [DEFAULT]), so that KEY is mapped to the result of +PROC applied to the value found for it, or DEFAULT otherwise." (match js (('@ . alist) - (match (assoc key alist) - (#f - (if (procedure? failure-result) - (failure-result) - failure-result)) - ((_ . value) - value))))) - -(define (alist-pop alist key) - "Return two values: the first pair in ALIST with the given KEY in its -'car' (or #f, if no such pair exists) and an assosciation list like (and -potentially sharing storage with) ALIST, but with no entry for KEY." - (match (assoc key alist) - ;; If key isn't present, we don't need to do any allocation - (#f - (values #f alist)) - (found - (values found - ;; Because we have `found`, we can find it more - ;; efficiently this time with `eq?`. We avoid using - ;; `delq` because it would copy pairs in a shared - ;; tail. We assume a sufficiently smart compiler to - ;; handle "tail recursion modulo cons" (vid. e.g. Indiana - ;; University Technical Report No. 19, Friedman & Wise - ;; 1975) at least as efficiently as a hand-written - ;; tail-recursive implementation with an accumulator. - (let loop ((alist alist)) - (match alist - ;; We know that `found` is present, - ;; so no need to check for '() - ((this . alist) - (if (eq? this found) - alist - (cons this (loop alist)))))))))) - -;; Sadly, Guile's implementation of (@ (srfi srfi-1) alist-delete) -;; performs unnecessary allocation, e.g. this currently evaluates to #f: -;; -;; (let ((alist `(("a" . 1)("b" . 2)("c" . 3)))) -;; (eq? alist (alist-delete "x" alist))) -;; -;; These functions generally choose to allocate a new outer pair (with the '@ -;; tag), even though in unusual cases the resulting object might not have -;; changed, for the sake of simplicity and to avoid retaining a reference to -;; the original alist longer than necessary. But that is O(1) allocation that -;; could only rarely be avoided: `alist-delete` would allocate O(n) pairs, -;; which would only be necessary in the worst case. -(define (alist-delete* alist key) - "Return an assosciation list like (and potentially sharing storage with) -ALIST, but with no entry for KEY." - (define-values (_popped remaining) - (alist-pop alist key)) - remaining) - -(define (jsobject-delete js key) - "Return a json object like JS, but with no entry for KEY." - (cons '@ (match js - (('@ . alist) - (alist-delete* alist key))))) - -(define (alist-set alist key value) - "Return an assosciation list like ALIST, but with KEY mapped to VALUE, -replacing any existing mapping for KEY." - (acons key value (alist-delete* alist key))) - -(define (jsobject-set js key value) - "Return a json object like JS, but with KEY mapped to VALUE, replacing any -existing mapping for KEY." - (cons '@ (match js - (('@ . alist) - (alist-set alist key value))))) - -(define jsobject-set* - (case-lambda - "Return a json object like JS, but functionally extended by mapping each -KEY to each VALUE, replacing any existing mapping for each KEY. The update -takes place from left to right, so later mappings overwrite earlier mappings -for the same KEY." - ((js) - js) - ((js key value) - (jsobject-set js key value)) - ((js . args) - (cons '@ (match js - (('@ . alist) - (let loop ((alist alist) - (args args)) - (match args - (() - alist) - ((key value . args) - (loop (alist-set alist key value) - args)))))))))) - -(define (alist-update alist key failure-result updater) - "Return an assosciation list like ALIST, but with KEY mapped to the result -of applying UPDATER to the value to which KEY is mapped in ALIST. When ALIST -does not have an existing mapping for KEY, FAILURE-RESULT is used as with -'jsobject-ref' to obtain the argument for UPDATER." - ;; Often, `updater` will be a lambda expression, so making it the last - ;; argument may help to makes the code legible, and the most likely - ;; `failure-result` arguments are all shorter than the keyword - ;; `#:failure-result`. Plus, making `failure-result` mandatory helps make - ;; `alist-update` consistent with `alist-update*`. - (define-values (popped tail-alist) - (alist-pop alist key)) - (acons key - (updater (match popped - (#f - (if (procedure? failure-result) - (failure-result) - failure-result)) - ((_ . value) - value))) - tail-alist)) - -(define (jsobject-update js key failure-result updater) - "Return a json object like JS, but with KEY mapped to the result of applying -UPDATER to the value to which KEY is mapped in JS. When JS does not have an -existing mapping for KEY, FAILURE-RESULT is used as with 'jsobject-ref' to -obtain the argument for UPDATER." - (cons '@ (match js - (('@ . alist) - (alist-update alist key failure-result updater))))) - -(define jsobject-update* - (case-lambda - "Return a json object like JS, but functionally extended by replacing the -mapping for each KEY with the result of applying the corresponding UPDATER to -the value to which that KEY is mapped in JS---or, if no such mapping exists, -to a value based on the corresponding FAILURE-RESULT as with 'jsobject-ref'. -The update takes place from left to right, so later UPDATERs will receive the -values returned by earlier UPDATERs for the same KEY." - ((js) - js) - ((js key failure-result updater) - (jsobject-update js key failure-result updater)) - ((js . args) - (cons '@ (match js - (('@ . alist) - (let loop ((alist alist) - (args args)) - (match args - (() - alist) - ((key failure-result updater . args) - (loop (alist-update alist key failure-result updater) - args)))))))))) - -(define* (jsobject-union #:key - (combine (lambda (a b) b)) - (combine/key (lambda (k a b) (combine a b))) - #:rest json-objects) - "Combine the given JSON-OBJECTS into a single json object. The JSON-OBJECTS -are merged from left to right by adding each key/value pair of each object to -the aggregate object in turn. When one of the JSON-OBJECTS contains a mapping -from some key KEY to a value VAL such that the aggregate object already -contains a mapping from KEY to a value VAL0, the aggregate object is -functionally updated to instead map KEY to the value of (COMBINE/KEY KEY VAL0 -VAL). The default COMBINE/KEY tail-calls (COMBINE VAL0 VAL), and the default -COMBINE simply returns its second argument, so, by default, mappings in later -JSON-OBJECTS supersede those in earlier ones." - (match (filter (lambda (v) - (not (or (keyword? v) - (procedure? v)))) - json-objects) - (() - '(@)) - (((and js0 ('@ . _))) - js0) - ((('@ . alist0) ('@ . alist*) ...) - (cons '@ (fold (lambda (alist1 alist0) - (if (null? alist0) - alist1 - (fold (lambda (k+v alist0) - (match k+v - ((k . v) - (define-values (popped tail-alist) - (alist-pop alist0 k)) - (match popped - (#f - (cons k+v tail-alist)) - ((_ . v0) - (acons k - (combine/key k v0 v) - tail-alist)))))) - alist0 - alist1))) - alist0 - alist*))))) + (let loop ((alist alist) + (updates updates)) + (match updates + (() (cons '@ alist)) + (((key proc) . updates) + (loop (alist-update alist key proc #f equal?) updates)) + (((key proc default) . updates) + (loop (alist-update alist key proc default equal?) updates))))))) + +(define (jsobject-union combine seed . objects) + "Merge OBJECTS into SEED by applying (COMBINE KEY VAL0 VAL), where VAL0 +is the value found in the (possibly updated) SEED and VAL is the new value +found in one of the OBJECTS." + (match seed + (('@ . aseed) + (match objects + (() seed) + ((('@ . alists) ...) + (cons + '@ + (fold (lambda (alist aseed) + (if (null? aseed) alist + (fold + (match-lambda* + (((k . v) aseed) + (let ((pair tail (alist-pop alist k))) + (match pair + (#f (acons k v aseed)) + ((_ . v0) (acons k (combine k v0 v) aseed)))))) + aseed + alist))) + aseed + alists))))))) + +;; Possibly useful helper functions: +;; (define (newest key val0 val) val) +;; (define (unkeyed->keyed proc) (lambda (_key val0 val) (proc val0 val))) ;;; @@ -282,7 +137,7 @@ (define (set-home . _) (define (module-name module) (let* ((package.json (string-append module "/package.json")) (package-meta (call-with-input-file package.json read-json))) - (jsobject-ref package-meta "name" #f))) + (jsobject-ref package-meta "name"))) (define (index-modules input-paths) (define (list-modules directory) @@ -318,12 +173,14 @@ (define resolve-dependencies (lambda (pkg-meta) (jsobject-update* pkg-meta - "devDependencies" '(@) resolve-dependencies - "dependencies" '(@) (lambda (deps) - (resolve-dependencies - (jsobject-union - (jsobject-ref pkg-meta "peerDependencies" '(@)) - deps)))))) + `("devDependencies" ,resolve-dependencies (@)) + `("dependencies" ,(lambda (deps) + (resolve-dependencies + (jsobject-union + (lambda (k a b) b) + (jsobject-ref pkg-meta "peerDependencies" '(@)) + deps))) + (@))))) #t) (define (delete-dependencies pkg-meta absent-dependencies) -- 2.34.0