[gnunet-scheme] 105/324: config: value-parser: Parse values in configuration files.

[gnunet]

This is an automated email from the git hooks/post-receive script.

maxime-devos pushed a commit to branch master
in repository gnunet-scheme.

commit cc3894bc7a170acc8c3ae6dcfa790686e0a8637b
Author: Maxime Devos <maximedevos@telenet.be>
AuthorDate: Sun Apr 11 11:05:41 2021 +0200

    config: value-parser: Parse values in configuration files.
    
    * gnu/gnunet/config/value-parser.scm: New module, for parsing values
      in configuration files.
    * tests/config-value-parser.scm: Test the new module.
    * Makefile.am
      (modules): Compile new module.
      (SCM_TESTS): Run the new test.
---
 Makefile.am                        |   2 +
 README.org                         |   2 +
 gnu/gnunet/config/value-parser.scm | 273 +++++++++++++++++++++++++
 tests/config-value-parser.scm      | 395 +++++++++++++++++++++++++++++++++++++
 4 files changed, 672 insertions(+)

diff --git a/Makefile.am b/Makefile.am
index 84d0438..cfad81f 100644
--- a/Makefile.am
+++ b/Makefile.am
@@ -49,6 +49,7 @@ modules = \
   gnu/gnunet/utils/platform-enum.scm \
   \
   gnu/gnunet/config/parser.scm \
+  gnu/gnunet/config/value-parser.scm \
   gnu/gnunet/config/expand.scm \
   \
   gnu/gnunet/util/cmsg.scm \
@@ -101,6 +102,7 @@ SCM_TESTS = \
   tests/bv-slice.scm \
   tests/cmsg.scm \
   tests/config-parser.scm \
+  tests/config-value-parser.scm \
   tests/config-expander.scm
 
 SCM_TESTS_ENVIRONMENT = \
diff --git a/README.org b/README.org
index 3414a62..915b22c 100644
--- a/README.org
+++ b/README.org
@@ -76,6 +76,8 @@
 ** Configuration
    + gnu/gnunet/config/parser.scm: Parse configuration files.
    + gnu/gnunet/config/expand.scm: Perform variable expansion.
+   + gnu/gnunet/config/value-parser.scm: Parse configuration values.
+     TODO: value->data, value->relative-time
 
    TODO: writing, modifying, querying ...
 ** Network structures
diff --git a/gnu/gnunet/config/value-parser.scm 
b/gnu/gnunet/config/value-parser.scm
new file mode 100644
index 0000000..b29dba0
--- /dev/null
+++ b/gnu/gnunet/config/value-parser.scm
@@ -0,0 +1,273 @@
+;; This file is part of scheme-GNUnet.
+;; Copyright (C) 2021 Maxime Devos
+;; Copyright (C) 2005-2020 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
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL3.0-or-later
+
+;; Brief: parse values in configuration files
+;; Upstream source: src/util/configuration.c
+;; Upstream author (GNUnet, C): Christian Grothoff
+;; Downstream author (GNUnet, Scheme): Maxime Devos
+;; Tests: tests/config-value-parser.scm
+;;
+;; Values are parsed with procedures names @code{value->X}.
+;; These procedures do not eat whitespace.
+;; In case of a syntax error, a subtype of @code{&value-parse-error}
+;; is raised.
+
+(define-library (gnu gnunet config value-parser)
+  (export &value-parse-error value-parse-error?
+         make-value-parse-error value-parse-error-text
+         &value-parse/natural-error value-parse/natural-error?
+         make-value-parse/natural-error
+         &value-parse/float-error value-parse/float-error?
+         make-value-parse/float-error
+         &value-parse/boolean-error value-parse/boolean-error?
+         make-value-parse/boolean-error
+         &value-parse/size-error value-parse/size-error?
+         make-value-parse/size-error
+         &value-parse/choice-error value-parse/choice-error?
+         make-value-parse/choice-error
+         value->natural value->float #;value->relative-time
+         value->boolean value->size value->choice
+         value->file-name)
+  (import (only (gnu gnunet utils hat-let)
+               let^)
+         (only (rnrs base)
+               define if or and begin lambda let
+               > = >= string=? string? cond
+               expt + * assert vector-length vector-ref
+               string-length char=? string-ref
+               string->number not substring
+               integer? exact? vector?)
+         (only (rnrs exceptions)
+               raise)
+         (only (rnrs conditions)
+               define-condition-type &error)
+         (only (rnrs r5rs)
+               exact->inexact)
+         (only (srfi :4)
+               u64vector u64vector-ref u64vector-length)
+         (only (srfi :43)
+               vector-index)
+         ;; For cut.
+         (srfi srfi-26)
+         (only (guile)
+               string->char-set make-regexp regexp-exec
+               string-skip string-index))
+  (begin
+    (define-condition-type &value-parse-error &error
+      make-value-parse-error value-parse-error?
+      (text value-parse-error-text))
+
+    (define-condition-type &value-parse/natural-error &value-parse-error
+      make-value-parse/natural-error value-parse/natural-error?)
+    (define-condition-type &value-parse/float-error &value-parse-error
+      make-value-parse/float-error value-parse/float-error?)
+    (define-condition-type &value-parse/boolean-error &value-parse-error
+      make-value-parse/boolean-error value-parse/boolean-error?)
+    (define-condition-type &value-parse/size-error &value-parse-error
+      make-value-parse/size-error value-parse/size-error?)
+    (define-condition-type &value-parse/choice-error &value-parse-error
+      make-value-parse/choice-error value-parse/choice-error?)
+
+    (define (value->natural text)
+      "Parse @var{text} as a natural number.
+In case of a parse error, raise an appropriate
+@code{&value-parse/natural-error}."
+      ;; string->number can *not* be used as-is here,
+      ;; as it is supports too much syntax.
+      ;; E.g., try (string->number "#x10" 10).
+      (if (or (= (string-length text) 0)
+             (and (> (string-length text) 1)
+                  (char=? (string-ref text 0) #\0))
+             (string-skip text cs:digits))
+         (raise (make-value-parse/natural-error text))
+         (string->number text)))
+
+    (define float-regex
+      (make-regexp "^((0|[1-9][0-9]*)(\\.[0-9]*)?|\\.[0-9]+)$"))
+
+    (define (value->float text)
+      "Parse @var{text} as a floating-point number.
+In case of a parse error, raise an appropriate
+@ code{&value-parse/float-error}."
+      (if (regexp-exec float-regex text)
+         (exact->inexact (string->number text))
+         (raise (make-value-parse/float-error text))))
+
+    (define (value->boolean text)
+      "Parse @var{text} as a boolean (@code{#t} or @code{#f}).
+In case of a parse error, raise an appropriate
+@code{&value-parse/boolean-error}."
+      (cond ((string=? text "YES") #t)
+           ((string=? text "NO") #f)
+           (#t (raise (make-value-parse/boolean-error text)))))
+
+    (define cs:digits (string->char-set "0123456789"))
+
+    ;; From gnunet/src/util/strings.c (convert_with_table),
+    ;; with some changes.
+    (define (convert-with-table text keys values error-thunk)
+      "Let @var{text} be a string @code{\"N X M Y ...\"}, where @var{N}
+@var{M} ... represent exact natural in decimal, and @var{X} @var{Y} ...
+units from @var{keys}.  Return the sum of @var{N} @var{X} ..., where
+@var{N} .. is interpreted as an integer and @var{X} is intepreted as a
+unit, with value looked up in @var{keys} and @var{values}.
+
+In case of a parsing error, the thunk @var{thunk-thunk} is called, and
+probably should raise some kind of parsing error.  Spaces between @var{N}
+and @var{X} ... are optional.
+
+@var{keys} is a vector of non-empty strings that do not contain decimal
+digits or spaces.  @var{values} is a SRFI-4 u64vector."
+      (let^ ((/o/ loop
+                 (start 0)
+                 (accumulated 0))
+            ;; Find the start and end location of the number.
+            ;; Skip digits instead of searching for the whitespace
+            ;; between the number and unit.
+            ;;
+            ;; Otherwise, @var{number} below could be @code{#f},
+            ;; inexact or not an integer, or too much syntax would
+            ;; be recognised.  E.g., try @code{(string->number "#xf")}.
+            ;; Also, inputs like @code{"10s"} without a space should
+            ;; be recognised.
+            (! end-of-number (string-skip text cs:digits start))
+            ;; The number is supposed to be followed by a unit,
+            ;; and the number must be present!
+            (? (or (not end-of-number)
+                   (= start end-of-number))
+               (error-thunk))
+            ;; TODO: should multiple leading zeros be disallowed?
+            ;; Disallow leading zeros (unless the number is 0,
+            ;; in which case a single zero is accepted).
+            (? (and (> end-of-number (+ start 1))
+                    (char=? (string-ref text start) #\0))
+               (error-thunk))
+            ;; Parse the number.
+            (! number (string->number (substring text start end-of-number)))
+            (!! (and (integer? number)
+                     (exact? number)
+                     (>= number 0)))
+            ;; Find the start and end position of the unit.
+            ;; Skip the spaces between the number and the unit.
+            (! start-of-unit (string-skip text #\  end-of-number))
+            ;; There is supposed to be a (non-empty) unit!
+            (? (not start-of-unit) (error-thunk))
+            ;; Find out where the unit ends, by searching for the
+            ;; first whitespace (or end of string) after the unit.
+            (! end-of-unit (string-index text #\ start-of-unit))
+            (! unit (if end-of-unit
+                        ;; substring/shared, substring/read-only,
+                        ;; substring/copy and string-copy would work
+                        ;; as well.
+                        (substring text start-of-unit end-of-unit)
+                        (substring text start-of-unit)))
+            ;; Look up the unit in @var{keys}.
+            (! unit-index
+               (vector-index (cut string=? <> unit) keys))
+            ;; The unit might not be defined.
+            (? (not unit-index) (error-thunk))
+            (! unit-value (u64vector-ref values unit-index))
+            ;; Add the value of "N X".
+            (! accumulated (+ accumulated (* number unit-value)))
+            (? (not end-of-unit) accumulated)
+            ;; And continue with the rest of the string!
+            (! start (string-skip text #\  end-of-unit))
+            ;; Spaces are only allowed between numbers and units,
+            ;; not after the last unit.
+            (? (not start) (error-thunk)))
+           (loop start accumulated)))
+
+    (define size-keys
+      #("B"
+       "KiB" "MiB" "GiB" "TiB" "PiB" "EiB"
+       ;; Yes, "kB" and not "KB".
+       ;; See strings.c in GNUnet C source code.
+       ;; TODO: check whether this is a bug.
+       "kB" "MB" "GB" "TB" "PB" "EB"))
+    (define size-values
+      (u64vector
+       1
+       1024
+       (expt 1024 2)
+       (expt 1024 3)
+       (expt 1024 4)
+       (expt 1024 5)
+       (expt 1024 6)
+       1000
+       (expt 1000 2)
+       (expt 1000 3)
+       (expt 1000 4)
+       (expt 1000 5)
+       (expt 1000 6)))
+    (assert (= (vector-length size-keys)
+              (u64vector-length size-values)))
+
+    (define (value->size text)
+      "Evaluate a size (in bytes) expression @var{text}, e.g.
+@code{\"1B 1 GiB 4 kB\"}."
+      (convert-with-table text size-keys size-values
+                         (lambda ()
+                           (raise (make-value-parse/size-error text)))))
+
+    ;; TODO: what would be most useful, epoch time, SRFI time,
+    ;; which units ...
+    #;
+    (define (value->relative-time text)
+      "Evaluate a relative time expression (in ???) @var{text}, e.g.
+@code{\"1h 2m 3s\"}."
+      (convert-with-table text relative-time-keys relative-time-values
+                         (lambda ()
+                           (raise (make-value-parse/relative-time-error)))))
+
+    (define (value->choice text options-vector)
+      "Let @var{options-vector} be a vector @code{#(x y ...)} with in the
+even positions strings @var{x} ..., and in the odd positions objects @var{y}
+...  If @var{text} is in @code{#(x ...)}, return the corresponding value in
+@code{#(y ...)}, otherwise raise a @code{&value-parse/choice-error}."
+      (assert (and (string? text) (vector? options-vector)))
+      ;; Loop invariants:
+      ;;  * @var{i} is a natural number
+      ;;  * @var{i} is even
+      ;;  * @var{i} is at most the length of @var{options-vector}
+      ;;  * ∀ natural j, j even and j < i ==> options-vector[j] ≠ text
+      ;;    (Alternatively: if @var{text} does appear in @var{options-vector},
+      ;;    it will be at position @var{i} or higher.)
+      (let loop ((i 0))
+       (cond ((>= i (vector-length options-vector))
+              (raise (make-value-parse/choice-error text)))
+             ;; The key to test is at the current (even) position
+             ((string=? (vector-ref options-vector i) text)
+              ;; The value is at the next (odd) position.
+              (vector-ref options-vector (+ i 1)))
+             (#t (loop (+ 2 i))))))
+
+    ;; TODO!
+    #;
+    (define (value->data text size)
+      ... (raise (make-value-parse/data-error text))
+      ... (raise (make-value-parse/data-size-error text))
+      ...)
+
+    ;; TODO why is expansion done only in file names
+    ;; in C GNUnet?
+    (define (value->file-name text)
+      "Parse @var{text} as a file name (a string).
+This actually is simply a no-op."
+      (assert (string? text))
+      text)))
diff --git a/tests/config-value-parser.scm b/tests/config-value-parser.scm
new file mode 100644
index 0000000..cc5113e
--- /dev/null
+++ b/tests/config-value-parser.scm
@@ -0,0 +1,395 @@
+;; This file is part of scheme-GNUnet.
+;; Copyright (C) 2021 Maxime Devos
+;;
+;; 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
+;; by the Free Software Foundation, either version 3 of the License,
+;; or (at your option) any later version.
+;;
+;; scheme-GNUnet is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;; Affero General Public License for more details.
+;;
+;; You should have received a copy of the GNU Affero General Public License
+;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
+;;
+;; SPDX-License-Identifier: AGPL3.0-or-later
+(use-modules (gnu gnunet config value-parser)
+            (srfi srfi-26)
+            (srfi srfi-43)
+            (quickcheck)
+            (quickcheck generator)
+            (quickcheck property)
+            (quickcheck arbitrary)
+            ((rnrs conditions) #:select (&assertion))
+            ((rnrs base) #:select (assert mod)))
+
+;; (Incomplete) recollection of bugs found with these tests:
+;; * [A] some exception types were not exported
+;; * [A] off-by-one in value->choice
+;; * [A] float-regex is too permissive, leading to crashes
+;; * [A] incorrect detection of leading 0 in value->natural
+;; * [A] some imports are missing
+;; * [A] missing arguments to string-skip in convert-with-table
+;; * [A] missing detection of empty number string in convert-with-table
+;; * [A] incorrect detection of empty number string or missing unit
+;;       in convert-with-table, leading to crashes
+;; * [A] comparison of character with number
+;; * [A] variable naming errors in convert-with-table
+;; * [A] value->natural allows too much syntax
+;; * [A] size-values is missing an entry
+;; * [A] missing argument to make-value-parse/size-error
+;;
+;; Tally: 14 [A]
+;;
+;; [A]: bug caught before patch was merged
+
+;; Fresh object that is not eq? to anything else.
+(define *object* (cons '#f '#f))
+(define-syntax-rule (test-x-error value->x x msg text arg ...)
+  (test-equal msg
+    `(x ,text)
+    (with-exception-handler
+       (lambda (e)
+         `(x ,(value-parse-error-text e)))
+      (lambda ()
+       (cons *object* (value->x text arg ...)))
+      #:unwind? #t
+      #:unwind-for-type x)))
+
+(define-syntax-rule (define-test-x-error test-y-error value->y y)
+  (define-syntax test-y-error
+    (syntax-rules ::: ()
+      ((test-y-error msg text arg :::)
+       (test-x-error value->y y msg text arg :::)))))
+
+(define-test-x-error test-natural-error
+  value->natural &value-parse/natural-error)
+(define-test-x-error test-float-error
+  value->float &value-parse/float-error)
+(define-test-x-error test-boolean-error
+  value->boolean &value-parse/boolean-error)
+(define-test-x-error test-size-error
+  value->size &value-parse/size-error)
+(define-test-x-error test-choice-error
+  value->choice &value-parse/choice-error)
+
+(test-begin "value-parser")
+
+(test-equal "value->natural, valid"
+  (iota 23)
+  (map (compose value->natural number->string) (iota 23)))
+(test-equal "value->natural, valid (2)"
+  #xdeadbeef (value->natural (number->string #xdeadbeef)))
+
+(test-natural-error "value->natural, multiple leading zeros" "00")
+(test-natural-error "value->natural, multiple leading zeros (2)" "001")
+(test-natural-error "value->natural, leading zero" "01")
+(test-natural-error "value->natural, empty string" "")
+(test-natural-error "value->natural, leading space" " 1")
+(test-natural-error "value->natural, trailing space" "1 ")
+(test-natural-error "value->natural, spaces" " ")
+(test-natural-error "value->natural, hexadecimal" "#xdeadbeef")
+
+
+;; IEEE 754 makes a distinction between positive zero
+;; and negative zero, with (/ 1 +0.0) = +inf.0 and
+;; (/ 1 -0.0) = -inf.0
+;;
+;; In Guile 3.?, 0.0 and -0.0 are = but not eqv?.
+
+(test-skip (if (eqv? 0.0 -0.0) 1 0))
+(test-eqv "value->float, positive 0 (a)"
+  0.0
+  (value->float "0.0"))
+(test-eqv "value->float, positive 0 (b)"
+  0.0
+  (value->float "0."))
+(test-eqv "value->float, positive 0 (c)"
+  0.0
+  (value->float ".0"))
+(test-eqv "value->float, positive 0 (d)"
+  0.0
+  (value->float "0"))
+
+(test-equal "value->float, nothing before dot"
+  (list 0.1 0.3 0.19 0.22)
+  (map value->float '(".1" ".3" ".19" ".22")))
+
+(test-float-error "value->float, multiple 0" "00")
+(test-float-error "value->float, leading 0" "01")
+(test-equal "value->float, 0 and dot"
+  0.1
+  (value->float "0.1"))
+(test-equal "value->float, leading 0 after dot"
+  1.001
+  (value->float "1.001"))
+(test-equal "value->float, multiple 0 after dot"
+  1.0
+  (value->float "1.000"))
+
+(test-float-error "value->float, hexadecimal" "#xdeadbeef")
+(test-equal "value->float, exact->inexact naturals"
+  (map exact->inexact (iota 20))
+  (map (compose value->float number->string) (iota 20)))
+
+;; Powers of two are exactly representable in IEEE 754
+;; (if exponent is not too large).  Even then, (value->float "0.5")
+;; should return a flonum and not the exact rational 1/2.
+(test-skip (if (equal? (map (compose inexact->exact exact->inexact
+                                    (cut expt 2 <>))
+                           (iota 10 -5))
+                      (map (cut expt 2 <>) (iota 10 -5)))
+              0 1))
+(test-equal "value->float, exact->inexact fractionals"
+  (map (compose exact->inexact (cut expt 2 <>))
+       (iota 10 -5))
+  (map (compose value->float number->string exact->inexact
+               (cut expt 2 <>))
+       (iota 10 -5)))
+
+;; Whitespace is not allowed!
+(test-float-error "value->float, no leading spaces" " 1.0")
+(test-float-error "value->float, no trailing spaces" "1.0 ")
+(test-float-error "value->float, not empty!" "")
+(test-float-error "value->float, not only space!" " ")
+(test-float-error "value->float, not a single .!" ".")
+
+
+;; TODO: should exponential notation 2e-3 = (* 2 (expt 10 -3))
+;; be accepted?
+
+(test-equal "value->boolean, YES"
+  #t
+  (value->boolean "YES"))
+
+(test-equal "value->boolean, NO"
+  #f
+  (value->boolean "NO"))
+
+(define-syntax-rule (test-bool-error text extra)
+  (test-boolean-error (string-append "value->boolean, " text extra)
+                     text))
+
+;; We're not simply looking at the first or second
+;; character or the length of the string.
+(test-bool-error "Y" " (invalid)")
+(test-bool-error "YE" " (invalid)")
+(test-bool-error "NOS" " (invalid)")
+(test-bool-error "NOSE" " (invalid)")
+(test-bool-error "N" " (invalid)")
+(test-bool-error "YES! " " (invalid)")
+
+;; Case sensitive!
+(test-bool-error "yes" " (invalid case, 0)")
+(test-bool-error "Yes" " (invalid case, 1)")
+(test-bool-error "yEs" " (invalid case, 2)")
+(test-bool-error "yeS" " (invalid case, 3)")
+(test-bool-error "no" " (invalid case, 0)")
+(test-bool-error "No" " (invalid case, 1)")
+(test-bool-error "nO" " (invalid case, 2)")
+
+;; Space are not allowed!
+(test-bool-error " YES" " (leading space)")
+(test-bool-error " NO" " (leading space)")
+(test-bool-error "YES " " (trailing space)")
+(test-bool-error "NO " " (trailing space)")
+(test-bool-error "" " (empty string)")
+(test-bool-error " " " (only space)")
+
+
+(define-syntax-rule (test-size-equal msg text val)
+  (test-equal (string-append "value->size, " msg) val
+             (value->size text)))
+(define-syntax-rule (test-binary-unit unit value exponent)
+  (begin
+    (assert (= value (expt 1024 exponent)))
+    (test-size-equal (string-append "unit " unit)
+                    (string-append "1 " unit)
+                    (expt 1024 exponent))))
+;; XXX not actually decimal
+(define-syntax-rule (test-decimal-unit unit value exponent)
+  (begin
+    (assert (= value (expt 1000 exponent)))
+    (test-size-equal (string-append "unit " unit)
+                    (string-append "1 " unit)
+                    (expt 1000 exponent))))
+
+(define-syntax-rule (test-binary-units (unit value exponent) ...)
+  (begin (test-binary-unit unit value exponent) ...))
+
+(define-syntax-rule (test-decimal-units (unit value exponent) ...)
+  (begin (test-decimal-unit unit value exponent) ...))
+
+;; Verify the unit table and some parsing code.
+;; Sizes are copied from (coreutils)Block size
+(test-binary-units
+ ("B" 1 0) ("KiB" 1024 1) ("MiB" 1048576 2) ("GiB" 1073741824 3)
+ ("TiB" 1099511627776 4) ("PiB" 1125899906842624 5)
+ ("EiB" 1152921504606846976 6))
+(test-decimal-units
+ ("kB" 1000 1) ("MB" 1000000 2) ("GB" 1000000000 3)
+ ("TB" 1000000000000 4) ("PB" 1000000000000000 5)
+ ("EB" 1000000000000000000 6))
+
+(test-size-equal "value->size, multiple space in-between" "1  B" 1)
+
+(test-size-error "value->size, only space" " ")
+(test-size-error "value->size, empty string" "")
+(test-size-error "value->size, leading space" " 1 B")
+(test-size-error "value->size, trailing space" "1 B ")
+(test-size-error "value->size, negative" "-1 B")
+(test-size-error "value->size, fraction" "3/2 B")
+(test-size-error "value->size, flonum, 1" "1.5 B")
+(test-size-error "value->size, flonum, 2" "1. B")
+(test-size-error "value->size, flonum, 3" ".1 B")
+(test-size-error "value->size, leading zero" "01 B")
+
+(define (factorial n)
+  (assert (and (integer? n)
+              (exact? n)
+              (>= n 0)))
+  (let loop ((acc 1)
+            (n n))
+    (if (> n 1)
+       (loop (* acc n) (- n 1))
+       acc)))
+(assert (= (factorial 0) 1))
+(assert (= (factorial 1) 1))
+(assert (= (factorial 2) 2))
+(assert (= (factorial 3) 6))
+(assert (= (factorial 4) 24))
+
+(define (choose-permutation size)
+  (choose-integer 0 (- (factorial size) 1)))
+
+;; The Fisher-Yates shuffle, as described on Wikipedia,
+;; but with random numbers extracted from PERMUTATION.
+(define (shuffle-vector vector permutation)
+  (assert (and (integer? permutation)
+              (exact? permutation)
+              (>= permutation 0)))
+  (let ((v (make-vector (vector-length vector))))
+    (let loop ((i 0)
+              (permutation permutation))
+      (if (< i (vector-length v))
+         (let ((j (mod permutation (+ i 1)))
+               (rest (floor/ permutation (+ i 1))))
+           ;; Except this assignment is unconditional.
+           ;; (On Wikipedia "if j != i" is added.)
+           (vector-set! v i (vector-ref v j))
+           (vector-set! v j (vector-ref vector i))
+           (loop (+ i 1) rest))
+         (begin
+           (assert (= permutation 0))
+           v)))))
+
+(define choose-unit
+  (choose-one (map generator-return '("KiB" "MiB" "GiB" "B" "kB" "MB"))))
+(define choose-value choose-byte) ; large enough
+(define choose-required-space-count (choose-integer 1 2))
+(define choose-optional-space-count (choose-integer 0 2))
+
+(define (choose-part-vector n)
+  (choose-vector
+   (generator-lift
+    vector choose-required-space-count choose-value
+    choose-optional-space-count choose-unit)
+   (+ 1 n)))
+
+(define (parts->string part-vector)
+  (call-with-output-string
+    (lambda (out)
+      (vector-for-each
+       (lambda (i val)
+        (apply (lambda (spaces-before value spaces-between unit)
+                 (unless (= i 0)
+                   (for-each (lambda _ (display " " out))
+                             (iota spaces-before)))
+                 (display value out)
+                 (for-each (lambda _ (display " " out))
+                           (iota spaces-between))
+                 (display unit out))
+               (vector->list val)))
+       part-vector))))
+
+(test-assert "value->size, morphism: (string-append, +)"
+  (quickcheck
+   (property ((parts (arbitrary
+                     (gen (sized-generator choose-part-vector))
+                     (xform #f))))
+     (= (value->size (parts->string parts))
+       (apply + (vector->list
+                 (vector-map
+                  (lambda (_ e)
+                    ((compose value->size parts->string vector) e))
+                  parts)))))))
+
+(test-assert "value->size, invariant under permutation"
+  (quickcheck
+   (property ((parts+property
+              (arbitrary
+               (gen (sized-generator
+                     (lambda (size)
+                       (generator-lift cons
+                                       (choose-permutation size)
+                                       (choose-part-vector size)))))
+               (xform #f))))
+     (= (value->size (parts->string (cdr parts+property)))
+       (value->size (parts->string
+                     (shuffle-vector (cdr parts+property)
+                                     (car parts+property))))))))
+
+
+(test-eq "value->choice, direct match"
+  'x
+  (value->choice "x" #("x" x)))
+
+(test-eq "value->choice, match later"
+  'y
+  (value->choice "y" #("x" x "y" y)))
+
+(test-eq "value->choice, match early"
+  'x
+  (value->choice "x" #("x" x "y" y)))
+
+(test-choice-error "value->choice, empty vector"
+                  "x" #())
+(test-error "value->choice, bad text"
+  &assertion
+  (value->choice 0 #("x" x)))
+(test-error "value->choice, bad choices"
+  &assertion
+  (value->choice "x" '(("x" x))))
+
+(test-eq "value->choice, whitespace (left) left intact"
+  'y
+  (value->choice " y" #("y" x " y" y)))
+
+(test-eq "value->choice, whitespace (right) left intact"
+  'y
+  (value->choice " y" #("y" x " y" y)))
+
+(test-eq "value->choice, case sensitive (1)"
+  'upper
+  (value->choice "X" #("x" lower "X" upper)))
+
+(test-eq "value->choice, case sensitive (2)"
+  'mixed
+  (value->choice "Xy" #("XY" upper "xy" lower "Xy" mixed)))
+
+(test-eq "value->choice, case sensitive (3)"
+  'lower
+  (value->choice "xy" #("xy" lower)))
+
+(test-assert "value->file-name, no-op"
+  (quickcheck
+   (property ((text ($string $char)))
+     (string=? (value->file-name text) text))))
+
+(test-error "value->file-name, text must be a string"
+  &assertion
+  (value->file-name 'bad))
+
+(test-end "value-parser")

-- 
To stop receiving notification emails like this one, please contact
gnunet@gnunet.org.