ris

1 files changed, 154 insertions, 0 deletions

diff --git a/mcgoron.ris.scm b/mcgoron.ris.scm
new file mode 100644
index 0000000..93e8d85
--- /dev/null
+++ b/mcgoron.ris.scm
@@ -0,0 +1,154 @@
+#| Copyright 2024 Peter McGoron
+ |
+ | Licensed under the Apache License, Version 2.0 (the "License");
+ |
+ | you may not use this file except in compliance with the License.
+ | You may obtain a copy of the License at
+ |
+ |     http://www.apache.org/licenses/LICENSE-2.0
+ |
+ | Unless required by applicable law or agreed to in writing, software
+ | distributed under the License is distributed on an "AS IS" BASIS,
+ | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
+ | See the License for the specific language governing permissions and
+ | limitations under the License.
+ |#
+
+(define-record-type <not-a-stream-error>
+  (not-a-stream-error obj)
+  not-a-stream-error?
+  (obj not-a-stream-error:obj))
+
+(define-record-type <malformed-reference-error>
+  (malformed-reference-error stream)
+  malformed-reference-error?
+  (stream malformed-reference-error:stream))
+
+(define-record-type <stream-error>
+  (stream-error stream)
+  stream-error?
+  (stream stream-error:stream))
+
+;;; Stream destructors.
+
+(define (stream-pair=> stream)
+  (cond-values
+    (when-ct (stream-pair? stream)
+      (values (stream-car stream) (stream-cdr stream)))))
+
+(define (stream-predicate=> stream predicate?)
+  (cond-values
+    (after ((let (stream-pair=> stream) => (head stream))
+            (when (predicate? head)))
+      (values head stream))))
+
+(define-syntax with-stream-predicates
+  (syntax-rules ()
+    ((_ stream ((predicate? name) ...) body ...)
+     (after ((let (stream-predicate=> stream predicate?) => (name stream))
+             ...)
+       body ...))))
+
+;;; Mapping destructors.
+
+(define (mapping-ref=> mapping key)
+  (mapping-ref mapping key (lambda () (values))))
+
+(define (mapping-new-field mapping key val)
+  (mapping-set mapping key (flexvector val)))
+
+;;; Flexvector utils.
+
+(define (flexvector-update-last! fv update)
+  (let ((len (flexvector-length fv)))
+    (flexvector-set! fv
+                     (- len 1)
+                     (update (flexvector-ref fv (- len 1))))))
+
+;;; Parsing each line.
+
+(define (prefix-char? ch)
+  (or (char-upper-case? ch) (char-numeric? ch)))
+
+(define (end=> stream)
+  (cond-values
+    (when-ct (stream-null? stream)
+      stream)
+    (with-stream-predicates stream (((cut eqv? #\return <>) _)
+                                    ((cut eqv? #\newline <>) _))
+      stream)
+    (with-stream-predicates stream (((cut eqv? #\newline <>) _))
+      stream)))
+
+(define (read-rest stream)
+  (let ((fv (flexvector)))
+    (let read-rest ((stream stream))
+      (cond-thunk
+        (after ((let (end=> stream) => (stream)))
+          (values (flexvector->string fv) stream))
+        (after ((let (stream-predicate=> stream char?)
+                  => (x stream)))
+          (flexvector-add-back! fv x)
+          (read-rest stream))
+        (else (raise (stream-error stream)))))))
+
+(define (prefix=> stream)
+  (let ((ws? (lambda (x)
+               (char=? x #\space))))
+    (cond-values
+      (with-stream-predicates stream ((prefix-char? char1)
+                                      (prefix-char? char2)
+                                      (ws? _)
+                                      (ws? _)
+                                      ((cut char=? #\- <>) _)
+                                      (ws? _))
+        (let-values (((rest stream) (read-rest stream)))
+          (values (string char1 char2) rest stream))))))
+
+;;; Parsing of references.
+
+(define (read-reference stream mapping last-name)
+  (cond-thunk
+    (after ((let (prefix=> stream) => (name rest stream)))
+      (cond-thunk
+        (when-ct (equal? name "ER")
+          (values stream mapping))
+        (after ((let (mapping-ref=> mapping name) => (fv)))
+          (flexvector-add-back! fv rest)
+          (read-reference stream mapping name))
+        (else
+         (read-reference stream
+                         (mapping-new-field mapping
+                                            name
+                                            rest)
+                         name))))
+    (when-ct (stream-null? stream)
+      (values stream mapping))
+    (else
+     (let-values
+         (((fv) (mapping-ref mapping
+                           last-name
+                           (lambda () (error "internal error" stream))))
+          ((rest stream) (read-rest stream)))
+       (flexvector-update-last! fv
+                                (lambda (last)
+                                  (string-append last "\n" rest)))
+       (read-reference stream mapping last-name)))))
+
+(define (read-new-reference stream mapping)
+  (cond-thunk
+    (when-ct (stream-null? stream)
+      mapping)
+    (after ((let (prefix=> stream) => (name rest stream))
+            (when (string=? name "TY")))
+      (let-values (((stream mapping)
+                    (read-reference stream
+                                    (mapping-new-field mapping name rest)
+                                    name)))
+        (read-new-reference stream mapping)))
+    (else (raise (malformed-reference-error stream)))))
+
+(define (ris->mapping port)
+  (read-new-reference (port->stream port)
+                      (mapping (make-default-comparator))))
+