bug#63135: [PATCH v2 0/5] MATCH-RECORD improvements

[Josselin Poiret via Guix-patches via <guix-patches@gnu.org>]

[-- Attachment #1: Type: text/plain, Size: 9001 bytes --]

Hi,

"(" <paren@disroot.org> writes:

> This v2 fixes the dir-locals.el file so that it indents MATCH-RECORD
> properly and adds a MATCH-RECORD-LAMBDA macro.
>
> ( (5):
>   records: match-record: Raise a syntax error if TYPE is nonexistent.
>   records: match-record: Display more helpful field-not-found error.
>   records: match-record: Support thunked and delayed fields.
>   dir-locals: Fix MATCH-RECORD indentation.
>   records: Add MATCH-RECORD-LAMBDA.
>
>  .dir-locals.el    |   3 +-
>  guix/records.scm  | 110 +++++++++++++++++++++++++++++++---------------
>  tests/records.scm |  41 +++++++++++++++++
>  3 files changed, 117 insertions(+), 37 deletions(-)

Thanks!

For some reason your From identity line messed up my patch mangling
tools, so I committed with (unmatched-paren instead of just ( as author.
Might be the emacs code I'm using that's hitting some corner cases.

Pushed as 178ffed3b7fe1784fff67b963c5c4bb667fbad2a with the
modifications below (that's a git-range-diff).  Basically, I dropped
"Display more helpful field-not-found error." since it was causing
issues when the body contained an ellipsis, and chose not to display the
total form that the error appeared in, but instead attach proper source
properties to the field syntax object in a new commit.  I also added a
test case for match-lambda with an ellipsis in the body, and added
match-record-lambda to (guix read-print).

1:  b2b374fafa = 1:  1a4aace3af records: match-record: Raise a syntax error if TYPE is nonexistent.
2:  1b3949cae7 < -:  ---------- records: match-record: Display more helpful field-not-found error.
3:  8def5ef633 ! 2:  b88e38d4b5 records: match-record: Support thunked and delayed fields.
    @@ guix/records.scm: (define (recutils->alist port)
        (lambda (s)
     -    "Look up FIELD in the given list and return an expression that represents
     -its offset in the record.  Raise a syntax violation when the field is not
    --found, displaying it as originating in form S*."
    +-found."
     -    (syntax-case s ()
    --      ((_ s* field offset ())
    +-      ((_ field offset ())
    +-       (syntax-violation 'lookup-field "unknown record type field"
     +    "Look up FIELD in the given list and return both an expression that represents
     +its offset in the record and a procedure that wraps it to return its \"true\" value
     +(for instance, FORCE is returned in the case of a delayed field).  RECORD is passed
    -+to thunked values.  Raise a syntax violation when the field is not found, displaying
    -+it as originating in form S*."
    ++to thunked values.  Raise a syntax violation when the field is not found."
     +    (syntax-case s (normal delayed thunked)
    -+      ((_ s* record field offset ())
    -        (syntax-violation 'match-record
    -                          "unknown record type field"
    -                          #'s* #'field))
    --      ((_ s* field offset (head tail ...))
    -+      ((_ s* record field offset ((head normal) tail ...))
    ++      ((_ record field offset ())
    ++       (syntax-violation 'match-record
    ++                         "unknown record type field"
    +                          s #'field))
    +-      ((_ field offset (head tail ...))
    ++      ((_ record field offset ((head normal) tail ...))
     +       (free-identifier=? #'field #'head)
     +       #'(values offset identity))
    -+      ((_ s* record field offset ((head delayed) tail ...))
    ++      ((_ record field offset ((head delayed) tail ...))
             (free-identifier=? #'field #'head)
     -       #'offset)
    --      ((_ s* field offset (_ tail ...))
    --       #'(lookup-field s* field (+ 1 offset) (tail ...))))))
    +-      ((_ field offset (_ tail ...))
    +-       #'(lookup-field field (+ 1 offset) (tail ...))))))
     +       #'(values offset force))
    -+      ((_ s* record field offset ((head thunked) tail ...))
    ++      ((_ record field offset ((head thunked) tail ...))
     +       (free-identifier=? #'field #'head)
     +       #'(values offset (cut <> record)))
    -+      ((_ s* record field offset (_ tail ...))
    -+       #'(lookup-field+wrapper s* record field
    ++      ((_ record field offset (_ tail ...))
    ++       #'(lookup-field+wrapper record field
     +                               (+ 1 offset) (tail ...))))))
      
      (define-syntax match-record-inner
        (lambda (s)
          (syntax-case s ()
    -       ((_ s* record type ((field variable) rest ...) body ...)
    +       ((_ record type ((field variable) rest ...) body ...)
     -       #'(let-syntax ((field-offset (syntax-rules ()
     -			              ((_ f)
    --                                       (lookup-field s* field 0 f)))))
    +-                                       (lookup-field field 0 f)))))
     -           (let* ((offset (type (map-fields type match-record) field-offset))
     -                  (variable (struct-ref record offset)))
     +       #'(let-syntax ((field-offset+wrapper
     +                       (syntax-rules ()
     +			 ((_ f)
    -+                          (lookup-field+wrapper s* record field 0 f)))))
    ++                          (lookup-field+wrapper record field 0 f)))))
     +           (let* ((offset wrap (type (map-fields type match-record)
     +                                     field-offset+wrapper))
     +                  (variable (wrap (struct-ref record offset))))
    -              (match-record-inner s* record type (rest ...) body ...))))
    -       ((_ s* record type (field rest ...) body ...)
    +              (match-record-inner record type (rest ...) body ...))))
    +       ((_ record type (field rest ...) body ...)
             ;; Redirect to the canonical form above.
     @@ guix/records.scm: (define-syntax match-record
    -   (lambda (s)
    +   (syntax-rules ()
          "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
      The order in which fields appear does not matter.  A syntax error is raised if
     -an unknown field is queried.
    @@ guix/records.scm: (define-syntax match-record
     -The current implementation does not support thunked and delayed fields."
     -    ;; TODO support thunked and delayed fields
     +an unknown field is queried."
    -     (syntax-case s ()
    -       ((_ record type (fields ...) body ...)
    -        #`(if (eq? (struct-vtable record) type)
    +     ((_ record type (fields ...) body ...)
    +      (if (eq? (struct-vtable record) type)
    +          (match-record-inner record type (fields ...) body ...)
     
      ## tests/records.scm ##
     @@ tests/records.scm: (define (location-alist loc)
4:  25d001ca8d = 3:  e6dc1d3996 dir-locals: Fix MATCH-RECORD indentation.
5:  384d6c9562 ! 4:  4cd5293621 records: Add MATCH-RECORD-LAMBDA.
    @@ .dir-locals.el
         ;; TODO: Contribute these to Emacs' scheme-mode.
         (eval . (put 'let-keywords 'scheme-indent-function 3))
     
    + ## guix/read-print.scm ##
    +@@ guix/read-print.scm: (define %special-forms
    +    ('letrec* 2)
    +    ('match 2)
    +    ('match-record 3)
    ++   ('match-record-lambda 2)
    +    ('when 2)
    +    ('unless 2)
    +    ('package 1)
    +
      ## guix/records.scm ##
     @@ guix/records.scm: (define-module (guix records)
                  alist->record
    @@ guix/records.scm: (define-module (guix records)
      ;;; Commentary:
      ;;;
     @@ guix/records.scm: (define-syntax match-record
    -              (match-record-inner #,s record type (fields ...) body ...)
    -              (throw 'wrong-type-arg record))))))
    +          (match-record-inner record type (fields ...) body ...)
    +          (throw 'wrong-type-arg record)))))
      
     +(define-syntax match-record-lambda
    -+  (lambda (s)
    ++  (syntax-rules ()
     +    "Return a procedure accepting a single record of the given TYPE for which each
     +FIELD will be bound to its FIELD name within the returned procedure.  A syntax error
     +is raised if an unknown field is queried."
    -+    (syntax-case s ()
    -+      ((_ type (field ...) body ...)
    -+       #`(lambda (record)
    -+           (if (eq? (struct-vtable record) type)
    -+               (match-record-inner #,s record type (field ...) body ...)
    -+               (throw 'wrong-type-arg record)))))))
    ++    ((_ type (field ...) body ...)
    ++     (lambda (record)
    ++       (if (eq? (struct-vtable record) type)
    ++           (match-record-inner record type (field ...) body ...)
    ++           (throw 'wrong-type-arg record))))))
     +
      ;;; records.scm ends here
     
-:  ---------- > 5:  f045c7ac80 records: match-record: Do not show internal form.
-:  ---------- > 6:  178ffed3b7 tests: records: Add test for ellipsis in body.

-- 
Josselin Poiret

[-- Attachment #2: signature.asc --]
[-- Type: application/pgp-signature, Size: 682 bytes --]