git mv src/heredoc.scm src/xyz/euandreh/

1 files changed, 97 insertions, 0 deletions

diff --git a/src/xyz/euandreh/heredoc.scm b/src/xyz/euandreh/heredoc.scm
new file mode 100644
index 0000000..fb10088
--- /dev/null
+++ b/src/xyz/euandreh/heredoc.scm
@@ -0,0 +1,97 @@
+(define-module (heredoc)
+  #:use-module ((srfi srfi-1) #:prefix s1:)
+  #:export (heredoc-reader))
+
+(define consumable-chars
+  '(#\space #\tab))
+
+(define (extract-single-line-indentation chars)
+  (s1:fold (lambda (curr acc)
+             (let* ((prev (s1:first acc))
+                    (halted? (s1:second acc))
+                    (n (s1:third acc))
+                    (non-blank? (not (member curr consumable-chars)))
+                    (changed? (and (not (null? prev))
+                                   (not (equal? curr prev)))))
+               (cond
+                 (halted?    acc)
+                 (non-blank? (list prev #t n))
+                 (changed?   (list prev #t n))
+                 (#:else     (list curr #f (+ 1 n))))))
+           '(#nil #f 0)
+           chars))
+
+(define (extract-line-indentations lines)
+  (map (compose (lambda (triple)
+                  (list (s1:first triple)
+                        (s1:third triple)))
+                extract-single-line-indentation
+                string->list)
+       lines))
+
+(define (maximum-indentation lines)
+  (let* ((line-indentations (extract-line-indentations lines))
+         (chars (map s1:first line-indentations))
+         (different-indents? (not (= 1 (length (s1:delete-duplicates chars))))))
+    (if different-indents?
+      0
+      (apply min (map s1:second line-indentations)))))
+
+(define (trim-indentation s)
+  (let* ((lines (string-split s #\newline))
+         (trim-n (maximum-indentation
+                  (filter (lambda (s) (not (equal? "" s)))
+                          lines))))
+    (string-join
+     (map (lambda (line)
+            (if (equal? "" line)
+              line
+              (substring line trim-n)))
+          lines)
+     "\n")))
+
+(define (non-quote-chars? chars)
+  (let ((non-quote-chars (filter (lambda (c)
+                                   (not (equal? #\" c)))
+                                 chars)))
+    (< 0 (length non-quote-chars))))
+
+(define (heredoc-reader _char port)
+  (let ((should-trim? #f)
+        (chars '()))
+    (do ((curr (read-char port)
+               (read-char port)))
+        ((equal? #\newline curr))
+      (set! chars (cons curr chars)))
+    (when (and (not (null? chars))
+               (equal? #\- (car chars)))
+      (set! should-trim? #t)
+      (set! chars (cdr chars)))
+    (let ((non-quote-chars (non-quote-chars? chars)))
+      (when non-quote-chars
+        (error
+         (format
+          #f
+          "Invalid characters at the beginning of the multiline reader: ~s"
+          (reverse non-quote-chars)))))
+    (let* ((quote-count (+ 1 (length chars)))
+           (quote-n 0)
+           (output '()))
+      (while #t
+        (let ((curr (read-char port)))
+          (when (eof-object? curr)
+            (error "EOF while reading #\"\"# multiline string"))
+          (set! output (cons curr output))
+          (set! quote-n
+                (cond
+                  ((and (>= quote-n quote-count)
+                        (equal? #\# curr))
+                   (break))
+                  ((equal? #\" curr) (+ 1 quote-n))
+                  (#:else 0)))))
+      (let ((s (list->string
+                (reverse
+                 (s1:drop output (+ 1 quote-count))))))
+        (if should-trim?
+          (trim-indentation s)
+          s)))))