Simplify structure analysis.

* NEWS: Mention new changes.
* doc/network-structures.tm: Document new macros.
* gnu/gnunet/cadet/client.scm: Use new macros.
* gnu/gnunet/dht/client.scm: Likewise.
* gnu/gnunet/fs/network.scm: Likewise.
* gnu/gnunet/netstruct/syntactic.scm (r%,s%,analyse,define-analyser):
New macros.

6 files changed, 174 insertions, 110 deletions

diff --git a/NEWS b/NEWS
index d1faba9..4e2a667 100644
--- a/NEWS
+++ b/NEWS
@@ -12,6 +12,9 @@
      in the manual.  These tools have been used to reduce duplication between
      client code of different services, so tests targeting a single service
      automatically also test the other services a bit.
+   - New macro 'analyse' and 'define-analyser', to make using read% and select%
+     less tedious when the type and slice remains the same.  Also, by using the
+     new macros, the code base should now be a bit more readible.
 ** Bugfixes
    - A potential (but unverified) bug with automatic collection is fixed --
      previously, if DHT garbage was found multiple times within a single
diff --git a/doc/network-structures.tm b/doc/network-structures.tm
index d52b3b2..ebda27a 100644
--- a/doc/network-structures.tm
+++ b/doc/network-structures.tm
@@ -177,6 +177,8 @@
   The fields can also be read:
 
   <\scm-code>
+    ;; This example is simplified later!
+
     (read% /:msg:nse:estimate/example '(header size) message) ; 12
 
     (read% /:msg:nse:estimate/example '(header type) message) ; 165
@@ -184,6 +186,67 @@
     (read% /:msg:nse:estimate/example '(size-estimate) message) ; 19.2
   </scm-code>
 
+  Repeating the message type and the slice can be repetitive, so <scm|(gnu
+  gnunet netstruct syntactic)> has a macro to avoid that:
+
+  <\explain>
+    <scm|(analyse <var|type> <var|message> <var|body>
+    <text-dots>)><index|analyse>
+  <|explain>
+    Expand to <scm|<var|body ...>> \ in a context where the syntax parameters
+    <scm|r%> and <scm|s%> (from <scm|(gnu gnunet netstruct syntactic)>) are
+    bound to macros with the following interface:
+
+    <\description>
+      <item*|<scm|(r% <var|field> ...)><index|r%>>Read the field
+      <scm|(<var|field> ...)> of <var|message>. This is to be understood as a
+      literal list, not as a procedure invocation \U neither the list nor
+      <var|field> <text-dots> is evaluated.
+
+      <item*|<scm|(s% <var|field> ...)><index|s%>>Select the field
+      <scm|(field ...)> of <var|message>, where <scm|(field ...)> is
+      interpreted the same way as for <scm|r%>.
+    </description>
+
+    <var|type> and <var|message> can currently be evaluated multiple times.
+    These macros <scm|r%> and <scm|s%> can only be used inside a
+    <scm|analyse> or <scm|define-analyser> construct; in other contexts an
+    exception is raised.
+  </explain>
+
+  Using this macro, the previous example can be simplified to: '
+
+  <\scm-code>
+    ;; 'pk' is for printing the value
+
+    (analyse /:msg:nse:estimate/example message
+
+    \ \ \ \ \ \ \ \ \ (pk (r% header size)) ; 12
+
+    \ \ \ \ \ \ \ \ \ (pk (r% header type)) ; 165
+
+    \ \ \ \ \ \ \ \ \ (pk (r% size-estimate))) ; 19.2
+  </scm-code>
+
+  For very simple 'analysis' procedures, the macro
+  <scm|define-analyser><index|define-analyser> can be useful:
+
+  <\scm-code>
+    ;; 'pk' is for printing the value
+
+    (define-analyser analyse-example /:msg:nse:estimate/example
+
+    \ \ "Put a docstring here"
+
+    \ \ (pk (r% header size)) ; 12
+
+    \ \ (pk (r% header type)) ; 165
+
+    \ \ (pk (r% size-estimate)))
+
+    (analyse-example [...])
+  </scm-code>
+
   <section|Primitive types>
 
   There are a number of pre-defined types.<space|1em>First, there is
diff --git a/gnu/gnunet/cadet/client.scm b/gnu/gnunet/cadet/client.scm
index c37b908..50118fe 100644
--- a/gnu/gnunet/cadet/client.scm
+++ b/gnu/gnunet/cadet/client.scm
@@ -77,7 +77,7 @@
           (only (gnu gnunet mq)
                 make-message-queue inject-message!)
           (only (gnu gnunet netstruct syntactic)
-                sizeof select read% set%!)
+                sizeof select read% set%! r% s% define-analyser analyse)
           (only (gnu gnunet utils bv-slice)
                 make-slice/read-write slice-copy/read-only slice-length
                 slice-copy! slice-slice)
@@ -412,20 +412,13 @@ the CADET addresss @var{cadet-address}, using the channel number
        mq (construct-local-channel-create
            (channel-address channel) (channel-channel-number channel))))
 
-    (define (analyse-local-channel-create message)
+    (define-analyser analyse-local-channel-create
+      /:msg:cadet:local:channel:create
       "Return the CADET address, channel number and options corresponding to
 the @code{/:msg:cadet:channel:create} message @var{message}."
-      (define-syntax read*
-        (cut-syntax read% /:msg:cadet:local:channel:create <> message))
-      (define-syntax select*
-        (cut-syntax select /:msg:cadet:local:channel:create <> message))
-      (let^ ((! channel-number (read* '(channel-number)))
-             (! peer (select* '(peer)))
-             (! port (select* '(port)))
-             (! channel-number (read* '(channel-number)))
-             (! options (read* '(options)))
-             (! address (make-cadet-address peer port)))
-            (values address channel-number options)))
+      (values (make-cadet-address (s% peer) (s% port))
+              (r% channel-number)
+              (r% options)))
 
     (define (construct-local-channel-destroy channel-number)
       "Create a @code{/:msg:cadet:channel:destroy} message for closing the
@@ -441,10 +434,11 @@ CADET channel with channel number @var{channel-number}."
       (set* '(channel-number) channel-number)
       s)
 
-    (define (analyse-local-channel-destroy message)
+    (define-analyser analyse-local-channel-destroy
+      /:msg:cadet:local:channel:destroy
       "Return the channel number corresponding to the
 @code{/:msg:cadet:local:channel:destroy} message @var{message}."
-      (read% /:msg:cadet:local:channel:destroy '(channel-number) message))
+      (r% channel-number))
 
     ;; TODO: determine maximum length
     (define %max-cadet-message-size
@@ -474,14 +468,11 @@ CADET channel with channel number @var{channel-number}."
 in the @code{/:msg:cadet:local:data} message @var{message}."
       (define header
         (slice-slice message 0 (sizeof /:msg:cadet:local:data '())))
-      (define-syntax read*
-        (cut-syntax read% /:msg:cadet:local:data <> header))
-      (define-syntax select*
-        (cut-syntax select /:msg:cadet:local:data <> header))
-      (values (read* '(channel-number))
-              (read* '(priority-preference))
-              (slice-slice message
-                           (sizeof /:msg:cadet:local:data '()))))
+      (analyse /:msg:cadet:local:data header
+               (values (r% channel-number)
+                       (r% priority-preference)
+                       (slice-slice message
+                                    (sizeof /:msg:cadet:local:data '())))))
 
     (define (construct-local-acknowledgement channel-number)
       "Create a @code{/:msg:cadet:local:acknowledgement} message,
@@ -498,10 +489,11 @@ identified by @var{channel-number}."
       (set* '(client-channel-number) channel-number)
       s)
 
-    (define (analyse-local-acknowledgement message)
+    (define-analyser analyse-local-acknowledgement
+      /:msg:cadet:local:acknowledgement
       "Return the channel number in the @code{/:msg:cadet:local:data}
 message @var{message}."
-      (read% /:msg:cadet:local:acknowledgement '(client-channel-number) message))
+      (r% client-channel-number))
 
     (define (stub . foo)
       (error "todo"))
diff --git a/gnu/gnunet/dht/client.scm b/gnu/gnunet/dht/client.scm
index bfc4bcc..047ca6d 100644
--- a/gnu/gnunet/dht/client.scm
+++ b/gnu/gnunet/dht/client.scm
@@ -88,7 +88,8 @@
                 run-loop spawn-server-loop)
           (only (guile)
                 pk define-syntax-rule define* lambda* error
-                ->bool and=>)
+                ->bool and=> define-syntax-parameter syntax
+                syntax-parameterize)
           (only (ice-9 atomic)
                 make-atomic-box)
           (only (ice-9 match)
@@ -106,7 +107,7 @@
           (only (gnu gnunet message protocols)
                 message-type)
           (only (gnu gnunet netstruct syntactic)
-                read% sizeof set%! select)
+                read% sizeof set%! select r% s% analyse define-analyser)
           (only (gnu gnunet utils bv-slice)
                 slice-length slice/read-only make-slice/read-write slice-copy!
                 slice-slice verify-slice-readable slice-copy/read-write
@@ -501,83 +502,66 @@ result object @var{search-result}, with @var{unique-id} as ‘unique id’"
             (slice-copy! value rest)
             message))
 
-    (define (analyse-client-get message)
+    (define-analyser analyse-client-get /:msg:dht:client:get
       "Return the query object, the unique id and the options corresponding to
 the @code{/:msg:dht:client:result} message @var{message}.  Xqueries are
 currently unsupported."
-      (let^ ((! type (read% /:msg:dht:client:get '(type) message))
-             (! key (make-hashcode:512/share
-                     (select /:msg:dht:client:get '(key) message)))
-             (! desired-replication-level
-                (read% /:msg:dht:client:get '(desired-replication-level) message))
-             (! unique-id (read% /:msg:dht:client:get '(unique-id) message))
-             (! options (read% /:msg:dht:client:get '(options) message))
-             (! query
-                (make-query type key #:desired-replication-level
-                            desired-replication-level)))
-            (values query unique-id options)))
-
-    (define (analyse-client-get-stop message)
+      (values (make-query (r% type) (make-hashcode:512/share (s% key))
+                          #:desired-replication-level
+                          (r% desired-replication-level))
+              (r% unique-id)
+              (r% options)))
+
+    (define-analyser analyse-client-get-stop /:msg:dht:client:get:stop
       "Return the unique id and the key corresponding to the
 @code{/:msg:dht:client:stop} message @var{message}."
-      (values (read% /:msg:dht:client:get:stop '(unique-id) message)
-              (select /:msg:dht:client:get:stop '(key) message)))
+      (values (r% unique-id) (s% key)))
 
     (define (analyse-client-put message)
       "Return the insertion object and options corresponding to the
 @code{/:msg:dht:client:put} message @var{message}."
-      (let^ ((! header (slice-slice message 0 (sizeof /:msg:dht:client:put '())))
-             (! type (read% /:msg:dht:client:put '(type) header))
-             (! key
-                (make-hashcode:512/share
-                 (select /:msg:dht:client:put '(key) header)))
-             (! value (slice-slice message (sizeof /:msg:dht:client:put '())))
-             (! desired-replication-level
-                (read% /:msg:dht:client:put '(desired-replication-level) header))
-             (! expiration
-                (read% /:msg:dht:client:put '(expiration) header))
-             (! options
-                (read% /:msg:dht:client:put '(option) header))
-             (! datum (make-datum type key value #:expiration expiration))
-             (! insertion
-                (datum->insertion datum #:desired-replication-level
-                                  desired-replication-level)))
-            (values insertion options)))
+      (define header (slice-slice message 0 (sizeof /:msg:dht:client:put '())))
+      (define value (slice-slice message (sizeof /:msg:dht:client:put '())))
+      (analyse /:msg:dht:client:put header
+               (values
+                (datum->insertion
+                 (make-datum
+                  (r% type)
+                  (make-hashcode:512/share (s% key))
+                  value
+                  #:expiration (r% expiration))
+                 #:desired-replication-level (r% desired-replication-level))
+                (r% option))))
 
     (define (analyse-client-result message)
       "Return search result object and unique id for the
 @code{/:msg:dht:client:result} message @var{message}."
-      (let^ ((! message (slice/read-only message))
-             (! size/header (sizeof /:msg:dht:client:result '()))
-             (! header (slice-slice message 0 size/header))
-             (! rest (slice/read-only message size/header))
-             (! put-path-length
-                (read% /:msg:dht:client:result '(put-path-length) header))
-             (! get-path-length
-                (read% /:msg:dht:client:result '(get-path-length) header))
-             (! size/path-element (sizeof /dht:path-element '()))
-             (! put-path
-                (slice-slice rest 0 (* size/path-element put-path-length)))
-             (! get-path
-                (slice-slice rest (* size/path-element put-path-length)
-                             (* size/path-element get-path-length)))
-             (! value
-                (slice-slice rest (* (sizeof /dht:path-element '())
-                                     (+ put-path-length get-path-length))))
-             (! datum
+      (define message* (slice/read-only message))
+      (define size/header (sizeof /:msg:dht:client:result '()))
+      (define header (slice-slice message* 0 size/header))
+      (define rest (slice-slice message* size/header))
+      (define size/path-element (sizeof /dht:path-element '()))
+      (analyse
+       /:msg:dht:client:result
+       header
+       (values (datum->search-result
                 (make-datum
-                 (read% /:msg:dht:client:result '(type) header)
-                 (make-hashcode:512/share
-                  (select /:msg:dht:client:result '(key) header))
-                 value
-                 #:expiration
-                 (read% /:msg:dht:client:result '(expiration) header)))
-             (! search-result
-                (datum->search-result
-                 datum #:get-path get-path #:put-path put-path))
-             (! unique-id (read% /:msg:dht:client:result '(unique-id) header)))
-            (values search-result unique-id)))
-
+                 (r% type)
+                 (make-hashcode:512/share (s% key))
+                 ;; 'value'
+                 (slice-slice rest
+                              (* size/path-element
+                                 (+ (r% put-path-length)
+                                    (r% get-path-length))))
+                 #:expiration (r% expiration))
+                #:get-path
+                (slice-slice rest
+                             (* size/path-element (r% put-path-length))
+                             (* size/path-element (r% get-path-length)))
+                #:put-path
+                (slice-slice rest 0
+                             (* size/path-element (r% put-path-length))))
+               (r% unique-id))))
     
 
     ;; New operations are communicated to the main event loop
diff --git a/gnu/gnunet/fs/network.scm b/gnu/gnunet/fs/network.scm
index 4b3b01c..65648a8 100644
--- a/gnu/gnunet/fs/network.scm
+++ b/gnu/gnunet/fs/network.scm
@@ -24,7 +24,6 @@
           (only (guile) begin define*)
           (only (gnu gnunet utils bv-slice)
                 make-slice/read-write slice-copy! slice-length )
-          (only (gnu gnunet utils hat-let) let^)
           (only (gnu extractor enum) value->index symbol-value)
           (only (gnu gnunet message protocols) message-type)
           (only (gnu gnunet fs struct)
@@ -37,7 +36,7 @@
                 hashcode:512->slice)
           (only (gnu gnunet utils cut-syntax) cut-syntax)
           (only (gnu gnunet netstruct syntactic)
-                set%! sizeof select read%))
+                set%! sizeof select r% s% define-analyser))
   (begin
     ;; GNUNET_SIGNATURE_PURPOSE_PEER_PLACEMENT,
     ;; (see gnunet-signatures/gnunet_signatures.rst)
@@ -72,19 +71,12 @@ expiring at @var{expiration-time} (TODO type), for @var{purpose}
       (set%!* '(file-length) file-length)
       s)
 
-   (define (analyse-request-loc-signature message)
-     "Return the file length, content hash key, expiration time (TODO type)
+    (define-analyser analyse-request-loc-signature
+      /:msg:fs:request-loc-signature
+      "Return the file length, content hash key, expiration time (TODO type)
 and signature purpose corresponding to the @code{/:msg:fs:request-loc-signature}
 message @var{message}."
-     (let^ ((! file-length
-               (read% /:msg:fs:request-loc-signature '(file-length) message))
-            (! content-hash-key
-               (make-content-hash-key/share
-                (select /:msg:fs:request-loc-signature
-                        '(content-hash-key) message)))
-            (! expiration-time
-               (read% /:msg:fs:request-loc-signature
-                      '(expiration-time) message))
-            (! purpose
-               (read% /:msg:fs:request-loc-signature '(purpose) message)))
-           (values file-length content-hash-key expiration-time purpose)))))
+      (values (r% file-length)
+              (make-content-hash-key/share (s% content-hash-key))
+              (r% expiration-time)
+              (r% purpose)))))
diff --git a/gnu/gnunet/netstruct/syntactic.scm b/gnu/gnunet/netstruct/syntactic.scm
index ff388af..fe54165 100644
--- a/gnu/gnunet/netstruct/syntactic.scm
+++ b/gnu/gnunet/netstruct/syntactic.scm
@@ -1,6 +1,6 @@
 ;#!r6rs
 ;;   This file is part of scheme-GNUnet, a partial Scheme port of GNUnet.
-;;   Copyright (C) 2020, 2021 GNUnet e.V.
+;;   Copyright © 2020--2022 GNUnet e.V.
 ;;
 ;;   scheme-GNUnet is free software: you can redistribute it and/or modify it
 ;;   under the terms of the GNU Affero General Public License as published
@@ -21,7 +21,8 @@
 ;; some checks and inlining during expansion.
 (define-library (gnu gnunet netstruct syntactic)
   (export sizeof offsetof select read% set%!
-          structure/packed define-type)
+          structure/packed define-type
+          r% s% analyse define-analyser)
   (import (rnrs base)
           (rnrs control)
           (only (rnrs exceptions)
@@ -33,7 +34,8 @@
                 newline
                 compose
                 call-with-prompt abort-to-prompt make-prompt-tag
-                resolve-module module-ref)
+                resolve-module module-ref
+                define-syntax-parameter syntax-parameterize)
           (only (system syntax) syntax-local-binding)
           (gnu gnunet utils bv-slice)
           (only (srfi srfi-1) span assq filter-map concatenate)
@@ -428,4 +430,32 @@ with some inlining where possible."
                       #`(#,(or (writer-syntax ns)
                                (not-inlinable
                                 #'(p@set%! type fields slice value)))
-                         #,sl)))))))))))
+                         #,sl)))))))))
+
+    
+    ;; Documentation is in the manual.
+    (define-syntax-parameter r% ; read field
+      (lambda (stx)
+        (syntax-violation 'r%
+                          "r% used outside of a 'analyzer' construct"
+                          stx)))
+    (define-syntax-parameter s% ; select field
+      (lambda (stx)
+        (syntax-violation 's%
+                          "s% used outside of a 'analyzer' construct"
+                          stx)))
+    (define-syntax analyse
+      (syntax-rules ()
+        ((_ type message body ...)
+         (syntax-parameterize
+          ((r% (syntax-rules ()
+                 ((_ . fields) (read% type 'fields message))))
+           (s% (syntax-rules ()
+                 ((_ . fields) (select type 'fields message)))))
+          body ...))))
+    (define-syntax define-analyser
+      (syntax-rules ()
+        ((_ name type docstring body ...)
+         (define (name message)
+           docstring
+           (analyse type message body ...)))))))