From patchwork Sat Nov 19 22:24:50 2022 Content-Type: text/plain; charset="utf-8" MIME-Version: 1.0 Content-Transfer-Encoding: 8bit X-Patchwork-Submitter: =?utf-8?q?Ludovic_Court=C3=A8s?= X-Patchwork-Id: 44690 Return-Path: X-Original-To: patchwork@mira.cbaines.net Delivered-To: patchwork@mira.cbaines.net Received: by mira.cbaines.net (Postfix, from userid 113) id 68C6A27BBED; Sat, 19 Nov 2022 22:27:00 +0000 (GMT) X-Spam-Checker-Version: SpamAssassin 3.4.6 (2021-04-09) on mira.cbaines.net X-Spam-Level: X-Spam-Status: No, score=-3.7 required=5.0 tests=BAYES_00,DKIM_INVALID, DKIM_SIGNED,MAILING_LIST_MULTI,RCVD_IN_MSPIKE_H2,SPF_HELO_PASS, URIBL_BLOCKED autolearn=ham autolearn_force=no version=3.4.6 Received: from lists.gnu.org (lists.gnu.org [209.51.188.17]) by mira.cbaines.net (Postfix) with ESMTPS id E7A2127BBE9 for ; Sat, 19 Nov 2022 22:26:58 +0000 (GMT) Received: from localhost ([::1] helo=lists1p.gnu.org) by lists.gnu.org with esmtp (Exim 4.90_1) (envelope-from ) id 1owWHv-0007Kt-Qq; Sat, 19 Nov 2022 17:26:15 -0500 Received: from eggs.gnu.org ([2001:470:142:3::10]) by lists.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1owWHi-0007JE-7g for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:03 -0500 Received: from debbugs.gnu.org ([209.51.188.43]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWHh-0004SW-Vg for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:01 -0500 Received: from Debian-debbugs by debbugs.gnu.org with local (Exim 4.84_2) (envelope-from ) id 1owWHh-0004gY-JK for guix-patches@gnu.org; Sat, 19 Nov 2022 17:26:01 -0500 X-Loop: help-debbugs@gnu.org Subject: [bug#59390] [PATCH 1/5] records: 'match-record' checks fields at macro-expansion time. References: <20221119222326.10644-1-ludo@gnu.org> In-Reply-To: <20221119222326.10644-1-ludo@gnu.org> Resent-From: Ludovic =?utf-8?q?Court=C3=A8s?= Original-Sender: "Debbugs-submit" Resent-CC: guix-patches@gnu.org Resent-Date: Sat, 19 Nov 2022 22:26:01 +0000 Resent-Message-ID: Resent-Sender: help-debbugs@gnu.org X-GNU-PR-Message: followup 59390 X-GNU-PR-Package: guix-patches X-GNU-PR-Keywords: patch To: 59390@debbugs.gnu.org Cc: Ludovic =?utf-8?q?Court=C3=A8s?= Received: via spool by 59390-submit@debbugs.gnu.org id=B59390.166889671117879 (code B ref 59390); Sat, 19 Nov 2022 22:26:01 +0000 Received: (at 59390) by debbugs.gnu.org; 19 Nov 2022 22:25:11 +0000 Received: from localhost ([127.0.0.1]:41579 helo=debbugs.gnu.org) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWGs-0004eG-Am for submit@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:11 -0500 Received: from eggs.gnu.org ([209.51.188.92]:40282) by debbugs.gnu.org with esmtp (Exim 4.84_2) (envelope-from ) id 1owWGp-0004e1-UX for 59390@debbugs.gnu.org; Sat, 19 Nov 2022 17:25:08 -0500 Received: from fencepost.gnu.org ([2001:470:142:3::e]) by eggs.gnu.org with esmtps (TLS1.2:ECDHE_RSA_AES_256_GCM_SHA384:256) (Exim 4.90_1) (envelope-from ) id 1owWGk-00046m-N5; Sat, 19 Nov 2022 17:25:02 -0500 DKIM-Signature: v=1; a=rsa-sha256; q=dns/txt; c=relaxed/relaxed; d=gnu.org; s=fencepost-gnu-org; h=MIME-Version:Date:Subject:To:From:in-reply-to: references; bh=hWBHwMNMZZHL/ndVgn37Mm3AsFQtPcAvVT/hCt2XNXw=; b=kagDA4tKWnqFN6 z/ssxgyn9Nu4dbOaOAvPseWIuq9BuLCj2y/OwKSL+S9r4hiNYgz7oUCEvBc6VIIGxIveutAi95J+O WPjDs/gOSBFGRcMVcVi9B9N+qUQFs17CgWRbRoQWiMvMLGa4BXgCqhu+yhCAu1s0yqQgUMiKj92jK XX5Y9Pppdam3XW5HY+NdsA4371qHNaDgUo03aXTHiJM8Z4/UcXm40Ssd5sBeHfsmO+vIcbdyqLuXE zibt522BM52OurUoj4O2AEkV2hB5E0RmVt4alWAsqN6ombXi8CHW+p9tEohJenZWakyVSahZ2HHar aTvyGU3C06EurRc4LNbQ==; Received: from 91-160-117-201.subs.proxad.net ([91.160.117.201] helo=gnu.org) by fencepost.gnu.org with esmtpsa (TLS1.2:ECDHE_RSA_AES_128_GCM_SHA256:128) (Exim 4.90_1) (envelope-from ) id 1owWGj-0006LD-Qb; Sat, 19 Nov 2022 17:25:02 -0500 From: Ludovic =?utf-8?q?Court=C3=A8s?= Date: Sat, 19 Nov 2022 23:24:50 +0100 Message-Id: <20221119222454.10759-1-ludo@gnu.org> X-Mailer: git-send-email 2.38.1 MIME-Version: 1.0 X-BeenThere: debbugs-submit@debbugs.gnu.org X-Mailman-Version: 2.1.18 Precedence: list X-BeenThere: guix-patches@gnu.org List-Id: List-Unsubscribe: , List-Archive: List-Post: List-Help: List-Subscribe: , Errors-To: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org Sender: guix-patches-bounces+patchwork=mira.cbaines.net@gnu.org X-getmail-retrieved-from-mailbox: Patches This allows 'match-record' to be more efficient (field offsets are computed at compilation time) and to report unknown fields at macro-expansion time. * guix/records.scm (map-fields): New macro. (define-record-type*)[rtd-identifier]: New procedure. Define TYPE as a macro and use a separate identifier for the RTD. (lookup-field, match-record-inner): New macros. (match-record): Rewrite in terms of 'match-error-inner'. * tests/records.scm ("record-match, simple") ("record-match, unknown field"): New tests. * gnu/services/cuirass.scm (cuirass-shepherd-service): Rename 'log-file' local variable to 'main-log-file'. * gnu/services/getmail.scm (serialize-getmail-configuration-file): Move after definition. --- gnu/services/cuirass.scm | 4 +- gnu/services/getmail.scm | 22 +++++----- guix/records.scm | 87 +++++++++++++++++++++++++++++++++++----- tests/records.scm | 33 +++++++++++++++ 4 files changed, 122 insertions(+), 24 deletions(-) diff --git a/gnu/services/cuirass.scm b/gnu/services/cuirass.scm index 52de5ca7c0..d7c6ab9877 100644 --- a/gnu/services/cuirass.scm +++ b/gnu/services/cuirass.scm @@ -125,7 +125,7 @@ (define (cuirass-shepherd-service config) (let ((cuirass (cuirass-configuration-cuirass config)) (cache-directory (cuirass-configuration-cache-directory config)) (web-log-file (cuirass-configuration-web-log-file config)) - (log-file (cuirass-configuration-log-file config)) + (main-log-file (cuirass-configuration-log-file config)) (user (cuirass-configuration-user config)) (group (cuirass-configuration-group config)) (interval (cuirass-configuration-interval config)) @@ -169,7 +169,7 @@ (define (cuirass-shepherd-service config) #:user #$user #:group #$group - #:log-file #$log-file)) + #:log-file #$main-log-file)) (stop #~(make-kill-destructor))) ,(shepherd-service (documentation "Run Cuirass web interface.") diff --git a/gnu/services/getmail.scm b/gnu/services/getmail.scm index fb82d054ca..19faea782f 100644 --- a/gnu/services/getmail.scm +++ b/gnu/services/getmail.scm @@ -215,17 +215,6 @@ (define-configuration getmail-options-configuration (parameter-alist '()) "Extra options to include.")) -(define (serialize-getmail-configuration-file field-name val) - (match-record val - (retriever destination options) - #~(string-append - "[retriever]\n" - #$(serialize-getmail-retriever-configuration #f retriever) - "\n[destination]\n" - #$(serialize-getmail-destination-configuration #f destination) - "\n[options]\n" - #$(serialize-getmail-options-configuration #f options)))) - (define-configuration getmail-configuration-file (retriever (getmail-retriever-configuration (getmail-retriever-configuration)) @@ -237,6 +226,17 @@ (define-configuration getmail-configuration-file (getmail-options-configuration (getmail-options-configuration)) "Configure getmail.")) +(define (serialize-getmail-configuration-file field-name val) + (match-record val + (retriever destination options) + #~(string-append + "[retriever]\n" + #$(serialize-getmail-retriever-configuration #f retriever) + "\n[destination]\n" + #$(serialize-getmail-destination-configuration #f destination) + "\n[options]\n" + #$(serialize-getmail-options-configuration #f options)))) + (define (serialize-symbol field-name val) "") (define (serialize-getmail-configuration field-name val) "") diff --git a/guix/records.scm b/guix/records.scm index ed94c83dac..13463647c8 100644 --- a/guix/records.scm +++ b/guix/records.scm @@ -1,5 +1,5 @@ ;;; GNU Guix --- Functional package management for GNU -;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 Ludovic Courtès +;;; Copyright © 2012-2022 Ludovic Courtès ;;; Copyright © 2018 Mark H Weaver ;;; ;;; This file is part of GNU Guix. @@ -104,6 +104,10 @@ (define (report-duplicate-field-specifier name ctor) (() #t))))))) +(define-syntax map-fields + (lambda (x) + (syntax-violation 'map-fields "bad use of syntactic keyword" x x))) + (define-syntax-parameter this-record (lambda (s) "Return the record being defined. This macro may only be used in the @@ -325,6 +329,15 @@ (define-record-type* thing make-thing field and its 'loc' field---the latter is marked as \"innate\", so it is not inherited." + (define (rtd-identifier type) + ;; Return an identifier derived from TYPE to name its record type + ;; descriptor (RTD). + (let ((type-name (syntax->datum type))) + (datum->syntax + type + (string->symbol + (string-append "% " (symbol->string type-name) " rtd"))))) + (define (field-default-value s) (syntax-case s (default) ((field (default val) _ ...) @@ -428,10 +441,31 @@ (define (compute-abi-cookie field-specs) field))) field-spec))) #`(begin - (define-record-type type + (define-record-type #,(rtd-identifier #'type) (ctor field ...) pred field-spec* ...) + + ;; Rectify the vtable type name... + (set-struct-vtable-name! #,(rtd-identifier #'type) 'type) + (cond-expand + (guile-3 + ;; ... and the record type name. + (struct-set! #,(rtd-identifier #'type) vtable-offset-user + 'type)) + (else #f)) + + (define-syntax type + (lambda (s) + "This macro lets us query record type info at +macro-expansion time." + (syntax-case s (map-fields) + ((_ map-fields macro) + #'(macro (field ...))) + (id + (identifier? #'id) + #'#,(rtd-identifier #'type))))) + (define #,(current-abi-identifier #'type) #,cookie) @@ -535,19 +569,50 @@ (define (recutils->alist port) (else (error "unmatched line" line)))))))) + +;;; +;;; Pattern matching. +;;; + +(define-syntax lookup-field + (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." + (syntax-case s () + ((_ field offset ()) + (syntax-violation 'lookup-field "unknown record type field" + s #'field)) + ((_ field offset (head tail ...)) + (free-identifier=? #'field #'head) + #'offset) + ((_ field offset (_ tail ...)) + #'(lookup-field field (+ 1 offset) (tail ...)))))) + +(define-syntax match-record-inner + (lambda (s) + (syntax-case s () + ((_ record type (field rest ...) body ...) + #`(let-syntax ((field-offset (syntax-rules () + ((_ f) + (lookup-field field 0 f))))) + (let* ((offset (type map-fields field-offset)) + (field (struct-ref record offset))) + (match-record-inner record type (rest ...) body ...)))) + ((_ record type () body ...) + #'(begin body ...))))) + (define-syntax match-record (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. + The current implementation does not support thunked and delayed fields." - ((_ record type (field fields ...) body ...) + ;; TODO support thunked and delayed fields + ((_ record type (fields ...) body ...) (if (eq? (struct-vtable record) type) - ;; TODO compute indices and report wrong-field-name errors at - ;; expansion time - ;; TODO support thunked and delayed fields - (let ((field ((record-accessor type 'field) record))) - (match-record record type (fields ...) body ...)) - (throw 'wrong-type-arg record))) - ((_ record type () body ...) - (begin body ...)))) + (match-record-inner record type (fields ...) body ...) + (throw 'wrong-type-arg record))))) ;;; records.scm ends here diff --git a/tests/records.scm b/tests/records.scm index 00c58b0736..76dadb3d48 100644 --- a/tests/records.scm +++ b/tests/records.scm @@ -528,4 +528,37 @@ (define (make-me-a-record) (foo))) '("a" "b" "c") '("a"))) +(test-equal "record-match, simple" + '((1 2) (a b)) + (let () + (define-record-type* foo make-foo + foo? + (first foo-first (default 1)) + (second foo-second)) + + (list (match-record (foo (second 2)) + (first second) + (list first second)) + (match-record (foo (first 'a) (second 'b)) + (second first) + (list first second))))) + +(test-equal "record-match, unknown field" + 'syntax-error + (catch 'syntax-error + (lambda () + (eval '(begin + (use-modules (guix records)) + + (define-record-type* foo make-foo + foo? + (first foo-first (default 1)) + (second foo-second)) + + (match-record (foo (second 2)) + (one two) + #f)) + (make-fresh-user-module))) + (lambda (key . args) key))) + (test-end)