guile-rsv

commit efeb9ec923bea071019961a2769e143d6ab587ed
parent 863b60b69124fedd66b5c1f8bf660df83878417a
Author: Yuval Langer <yuval.langer@gmail.com>
Date:   Mon,  8 Jan 2024 17:38:48 +0200

Add arbitrary null procedures.

Diffstat:
A
rsv/arbitrary-null.scm
 | 
103
+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

1 file changed, 103 insertions(+), 0 deletions(-)
diff --git a/rsv/arbitrary-null.scm b/rsv/arbitrary-null.scm
@@ -0,0 +1,103 @@
+(define-library (rsv arbitrary-null)
+  (import (scheme base)
+          (scheme file)
+          (scheme write)
+          (ice-9 match))
+  (export scm->rsv
+          rsv->scm
+          main)
+
+  (begin
+    (define ROW-TERMINATOR-BYTE 253)
+    (define VALUE-TERMINATOR-BYTE 255)
+    (define NULL-VALUE-BYTE 254)
+
+    (define (row-terminator-byte? byte) (= ROW-TERMINATOR-BYTE byte))
+    (define (value-terminator-byte? byte) (= VALUE-TERMINATOR-BYTE byte))
+    (define (null-value-byte? byte) (= NULL-VALUE-BYTE byte))
+
+    (define (null-value? null-value our-value)
+      (equal? null-value our-value))
+
+    (define (field->rsv field null-value? port)
+      (match field
+        ((? null-value?)
+         (write-u8 NULL-VALUE-BYTE
+                   port))
+        (field
+         (write-bytevector (string->utf8 field)
+                           port))))
+
+    (define (row->rsv row null-value? port)
+      (let loop ((row row))
+        (match row
+          (()
+           (write-u8 ROW-TERMINATOR-BYTE
+                     port))
+          ((field fields ...)
+           (field->rsv field null-value? port)
+           (write-u8 VALUE-TERMINATOR-BYTE port)
+           (loop fields)))))
+
+    (define (scm->rsv scm null-value? port)
+      (let loop ((scm scm))
+        (match scm
+          (() '())
+          ((row rows ...)
+           (row->rsv row null-value? port)
+           (loop rows)))))
+
+    (define (field->scm null-value port)
+      (match (peek-u8 port)
+        ((? null-value-byte?)
+         (read-u8 port) ;; remove null byte.
+         (read-u8 port) ;; remove value terminator byte.
+         null-value)
+        ((? value-terminator-byte?)
+         (read-u8 port) ;; remove value terminator byte.
+         "")
+        (byte
+         (let loop ((field #u8()))
+           (match (read-u8 port)
+             ((? value-terminator-byte? byte)
+              (utf8->string field))
+             (byte
+              (loop (bytevector-append field
+                                       (make-bytevector 1 byte)))))))))
+
+    (define (row->scm null-value port)
+      (match (peek-u8 port)
+        ((? row-terminator-byte?)
+         (read-u8 port) ;; remove row terminator.
+         '())
+        (_
+         (let loop ((row '()))
+           (match (peek-u8 port)
+             ((? row-terminator-byte? byte)
+              (read-u8 port) ;; Remove row terminator.
+              (reverse row))
+             (byte
+              (loop (cons (field->scm null-value port)
+                          row))))))))
+
+    (define (rsv->scm null-value port)
+      (let loop ((rows '()))
+        (match (peek-u8 port)
+          ((? eof-object?)
+           (reverse rows))
+
+          (_
+           (loop (cons (row->scm null-value port)
+                       rows))))))
+
+    (define (main args)
+      (let ((our-scm '(("abc" "" "") ("def" #f "ghi") () (#f))))
+        (write our-scm) (newline)
+        (call-with-output-file "poop.rsv"
+          (lambda (port)
+            (scm->rsv our-scm
+                      (lambda (x) (equal? #f x))
+                      port)))
+        (call-with-input-file "poop.rsv"
+          (lambda (port)
+            (write (rsv->scm #f port)) (newline)))))))