[bug#51838] [PATCH v6 03/41] guix: node-build-system: Add JSON utilities.

[Liliana Marie Prikler]

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