Package: guix-patches;
Reported by: Philip McGrath <philip <at> philipmcgrath.com>
Date: Sun, 14 Nov 2021 12:43:01 UTC
Severity: normal
Tags: patch
Done: Liliana Marie Prikler <liliana.prikler <at> gmail.com>
Bug is archived. No further changes may be made.
Message #1082 received at 51838 <at> debbugs.gnu.org (full text, mbox):
From: Liliana Marie Prikler <liliana.prikler <at> gmail.com> To: Philip McGrath <philip <at> philipmcgrath.com>, 51838 <at> debbugs.gnu.org Cc: Timothy Sample <samplet <at> ngyro.com>, Pierre Langlois <pierre.langlois <at> gmx.com>, Jelle Licht <jlicht <at> fsfe.org> Subject: Re: [PATCH v6 03/41] guix: node-build-system: Add JSON utilities. Date: Thu, 30 Dec 2021 19:18:48 +0100
Having argued for these procedures to be moved into their own file in a
separate mail, now it's time to bikeshed stylistic choices.
Am Donnerstag, dem 30.12.2021 um 02:38 -0500 schrieb Philip McGrath:
> +(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)))))
We can safely replace failure-result by Guile's DEFAULT and leave error
handling to the user.
> +(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))))))))))
I think this can be more efficiently be done in a "single" loop.
(let loop ((rest alist)
(previous '()))
(match rest
(() (values #f alist))
((first . rest)
(if (eq? (car first) key)
(values first (reverse! previous rest))
(loop rest (cons first previous))))))
Also, I don't think your version is tail-recursive. (loop alist) is
not in tail position from what I can tell.
We should also look into SRFI-1 span.
> +;; 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)
That's a pretty long comment around something that could be done with
call-with-values or SRFI-71 let. I think one of these two should be
preferred.
Note that both our versions of alist-pop only pop the first key (as
they should). This means that alist-delete* should really be called
alist-delete-1 as in "remove the first pair in ALIST belonging to KEY".
For the larger JSON handling below, this makes no difference however.
> +(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)))))
Fair enough.
> +(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)))
Is order relevant here? Because we could just as well reimplement our
alist-delete* loop and cons the replacement onto the rest. WDYT?
> +(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)))))
I think it'd be wiser to put the cons inside the match.
> +(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))))))))))
I'm not sure if I like this "syntax". I think I'd prefer
(jsobject-set* obj (FIELD1 VALUE1) (FIELD2 VALUE2) ...)
with FIELD1, FIELD2 being identifiers
WDYT?
> +(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*`.
Which alist-update* are you referring to here? Either way, the
failure-result to default argument from above applies, but we could
keyword it.
> + (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))
SRFI-71 let says hi. Also the ordering question applies. I'm starting
to think we should implement alist-pop, alist-set and alist-update in
terms of a single more powerful function producing three values (or
SRFI-1 span).
> +(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)))))
Same default argument. Cons inside.
> +(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))))))))))
Same default argument. Cons inside.
> +(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*)))))
Same default argument. Cons inside.
I think having a single combine function taking (k a b) would be less
confusing than having two. Is there a rationale for the form you
chose?
> +
> +;;;
> +;;; 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)
We should probably add a function to our js utils that "generates an
empty object", because '(@) is quite confusing to see in these
circumstances. Otherwise LGTM with the aforementioned caveats.
Cheers
GNU bug tracking system
Copyright (C) 1999 Darren O. Benham,
1997,2003 nCipher Corporation Ltd,
1994-97 Ian Jackson.