Initial commit

srfi-233.scm

@@ -0,0 +1,87 @@
+;;;; SPDX-License-Identifier: MIT
+;;;; SPDX-FileCopyrightText: 2022 John Cowan, Arvydas Silanskas
+;;;; SPDX-FileCopyrightText: 2025 Lilianna Smólska
+
+;;;; Copyright (c) 2022 John Cowan, Arvydas Silanskas.
+;;;; Copyright (c) 2025 Lilianna Smólska
+;;;;
+;;;; Permission is hereby granted, free of charge, to any person obtaining a copy of
+;;;; this software and associated documentation files (the "Software"), to deal in
+;;;; the Software without restriction, including without limitation the rights to
+;;;; use, copy, modify, merge, publish, distribute, sublicense, and/or sell copies of
+;;;; the Software, and to permit persons to whom the Software is furnished to do so,
+;;;; subject to the following conditions:
+;;;;
+;;;; The above copyright notice and this permission notice (including the next
+;;;; paragraph) shall be included in all copies or substantial portions of the
+;;;; Software.
+;;;;
+;;;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+;;;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, FITNESS
+;;;; FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR
+;;;; COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER
+;;;; IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;;;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
+
+(define (make-ini-file-accumulator port #!optional (key-value-separator #\=) (comment-delimiter #\;))
+  (define current-section '||)
+  (define (write-comment str)
+    (format port "~a ~a~%" comment-delimiter str))
+  (define (write-data section key value)
+    (unless (eq? section current-section)
+      (set! current-section section)
+      (format port "[~a]~%" section))
+    (if key
+        (format port "~a~a~a~%" key key-value-separator value)
+        (format port "~a~%" value)))
+  (define (data-triple? arg)
+    (and (list? arg)
+         (= (length arg) 3)
+         (symbol? (car arg))
+         (or (not (cadr arg))
+             (symbol? (cadr arg)))
+         (string? (caddr arg))))
+  (lambda (arg)
+    (cond ((eof-object? arg) (eof-object))
+          ((string? arg) (write-comment arg))
+          ((data-triple? arg) (apply write-data arg))
+          (else (error (format #f "unexpected input: ~s" arg))))))
+
+(define (make-ini-file-generator port #!optional (key-value-separator #\=) (comment-delimiter #\;))
+  (define (comment? line)
+    (char=? (string-ref line 0) comment-delimiter))
+  (define (section line)
+    (let ((last-index (sub1 (string-length line))))
+      (and (char=? (string-ref line 0) #\[)
+           (char=? (string-ref line last-index) #\])
+           (string->symbol (string-copy line 1 last-index)))))
+  (define (key-value line)
+    (let ((separator-position (string-index line key-value-separator)))
+      (if separator-position
+          (cons (string->symbol (string-trim-right (string-copy line 0 separator-position)))
+                (string-trim (string-copy line (add1 separator-position))))
+          (cons #f line))))
+  (define current-section '||)
+  (define at-eof #f)
+  (lambda ()
+    (if at-eof
+        (eof-object)
+        (let loop ()
+          (let ((line (read-line port)))
+            (if (eof-object? line)
+                (begin
+                  (set! at-eof #t)
+                  (eof-object))
+                (let ((trimmed-line (string-trim-both line)))
+                  (cond
+                   ((string-null? trimmed-line)
+                    (loop))
+                   ((comment? trimmed-line)
+                    (loop))
+                   ((section trimmed-line) => (lambda (section)
+                                                (set! current-section section)
+                                                (loop)))
+                   ((key-value trimmed-line) => (lambda (key-value-pair)
+                                                  (list current-section
+                                                        (car key-value-pair)
+                                                        (cdr key-value-pair))))))))))))