@@ -26,6 +26,7 @@ (define-module (guix build node-build-system)
#:use-module (ice-9 match)
#:use-module (srfi srfi-1)
#:export (%standard-phases
+ with-atomic-json-file-replacement
node-build))
;; Commentary:
@@ -34,6 +35,237 @@ (define-module (guix build node-build-system)
;;
;; 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
+to be written as json to the replacement FILE."
+ (with-atomic-file-replacement file
+ (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.
+ (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*)))))
+
+
+;;;
+;;; Phases.
+;;;
+
(define (set-home . _)
(with-directory-excursion ".."
(let loop ((i 0))
@@ -49,7 +281,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)))
- (assoc-ref package-meta "name")))
+ (jsobject-ref package-meta "name" #f)))
(define (index-modules input-paths)
(define (list-modules directory)
@@ -73,27 +305,24 @@ (define* (patch-dependencies #:key inputs #:allow-other-keys)
(define index (index-modules (map cdr inputs)))
- (define (resolve-dependencies package-meta meta-key)
- (fold (lambda (key+value acc)
- (match key+value
- ('@ acc)
- ((key . value) (acons key (hash-ref index key value) acc))))
- '()
- (or (assoc-ref package-meta meta-key) '())))
+ (define resolve-dependencies
+ (match-lambda
+ (('@ . alist)
+ (cons '@ (map (match-lambda
+ ((key . value)
+ (cons key (hash-ref index key value))))
+ alist)))))
- (with-atomic-file-replacement "package.json"
- (lambda (in out)
- (let ((package-meta (read-json in)))
- (assoc-set! package-meta "dependencies"
- (append
- '(@)
- (resolve-dependencies package-meta "dependencies")
- (resolve-dependencies package-meta "peerDependencies")))
- (assoc-set! package-meta "devDependencies"
- (append
- '(@)
- (resolve-dependencies package-meta "devDependencies")))
- (write-json package-meta out))))
+ (with-atomic-json-file-replacement "package.json"
+ (lambda (pkg-meta)
+ (jsobject-update*
+ pkg-meta
+ "devDependencies" '(@) resolve-dependencies
+ "dependencies" '(@) (lambda (deps)
+ (resolve-dependencies
+ (jsobject-union
+ (jsobject-ref pkg-meta "peerDependencies" '(@))
+ deps))))))
#t)
(define* (delete-lockfiles #:key inputs #:allow-other-keys)
@@ -114,9 +343,7 @@ (define* (configure #:key outputs inputs #:allow-other-keys)
(define* (build #:key inputs #:allow-other-keys)
(let ((package-meta (call-with-input-file "package.json" read-json)))
- (if (and=> (assoc-ref package-meta "scripts")
- (lambda (scripts)
- (assoc-ref scripts "build")))
+ (if (jsobject-ref (jsobject-ref package-meta "scripts" '(@)) "build" #f)
(let ((npm (string-append (assoc-ref inputs "node") "/bin/npm")))
(invoke npm "run" "build"))
(format #t "there is no build script to run~%"))