Add first workikng version, with proper Makefile with "install" target

4 files changed, 498 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..2311b75
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,4 @@
+/heredoc.log
+/src/*.go
+/vendor/
+/FIXME
diff --git a/Makefile b/Makefile
new file mode 100644
index 0000000..dfeabe4
--- /dev/null
+++ b/Makefile
@@ -0,0 +1,60 @@
+.POSIX:
+DATE         = 1970
+VERSION      = 0.1.0
+NAME         = guile-heredoc
+MAILING_LIST = public-inbox
+TRANSLATIONS = pt fr eo es
+CONTRIBLANGS =
+PREFIX       = /usr/local
+LIBDIR       = $(PREFIX)/lib
+SHAREDIR     = $(PREFIX)/share
+GUILE        = guile
+GUILD        = guild
+MODDIR       = $(SHAREDIR)/guile/site/$(GUILE_EFFECTIVE_VERSION)
+OBJDIR       = $(LIBDIR)/guile/$(GUILE_EFFECTIVE_VERSION)/site-ccache
+
+
+.SUFFIXES:
+.SUFFIXES: .scm .go
+
+.scm.go:
+	$(GUILD) compile -L src/ $(GUILE_FLAGS)-o $@ $<
+
+
+sources = src/heredoc.scm
+objects = $(sources:.scm=.go)
+
+
+all: $(objects)
+
+GUILE_EFFECTIVE_VERSION = `$(GUILE) -c '(display (effective-version))'`
+install: all
+	mkdir -p \
+		"$(DESTDIR)$(MODDIR)" \
+		"$(DESTDIR)$(OBJDIR)"
+	for s in $(sources); do \
+		cp $$s "$(DESTDIR)$(MODDIR)"; \
+	done
+	for o in $(objects); do \
+		cp $$o "$(DESTDIR)$(OBJDIR)"; \
+	done
+
+uninstall:
+	for s in $(sources); do \
+		rm -f "$(DESTDIR)$(MODDIR)/`basename $$s`"; \
+	done
+	for o in $(objects); do \
+		rm -f "$(DESTDIR)$(OBJDIR)/`basename $$o`"; \
+	done
+
+check-guile:
+	$(GUILE) -L src/ tests/heredoc.scm
+
+check: check-guile
+
+clean:
+	rm -f \
+		heredoc.log $(objects)
+
+
+dev-check: check
diff --git a/src/heredoc.scm b/src/heredoc.scm
new file mode 100644
index 0000000..fb10088
--- /dev/null
+++ b/src/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)))))
diff --git a/tests/heredoc.scm b/tests/heredoc.scm
new file mode 100644
index 0000000..a445ac1
--- /dev/null
+++ b/tests/heredoc.scm
@@ -0,0 +1,337 @@
+(use-modules
+  (heredoc)
+  ((srfi srfi-64) #:prefix t:))
+
+(eval-when (expand load eval)
+  (read-hash-extend #\" heredoc-reader))
+
+(define (test-extract-single-line-indentation)
+  (define extract-single-line-indentation
+    (@@ (heredoc) extract-single-line-indentation))
+  (t:test-group "extract-single-line-indentation"
+    (t:test-equal '(#nil #f 0)
+                  (extract-single-line-indentation
+                   '()))
+
+    (t:test-equal '(#nil #t 0)
+                  (extract-single-line-indentation
+                   '(#\a #\b #\c)))
+
+    (t:test-equal '(#\space #t 1)
+                  (extract-single-line-indentation
+                   '(#\space #\b #\c)))
+
+    (t:test-equal '(#\space #t 5)
+                  (extract-single-line-indentation
+                   '(#\space #\space #\space #\space #\space #\b #\c)))
+
+    (t:test-equal '(#\space #f 5)
+                  (extract-single-line-indentation
+                   '(#\space #\space #\space #\space #\space)))
+
+    (t:test-equal '(#\space #f 1)
+                  (extract-single-line-indentation
+                   '(#\space)))
+
+    (t:test-equal '(#\tab #t 3)
+                  (extract-single-line-indentation
+                   '(#\tab #\tab #\tab #\b #\c)))
+
+    (t:test-equal '(#\tab #f 3)
+                  (extract-single-line-indentation
+                   '(#\tab #\tab #\tab)))
+
+    (t:test-equal '(#\tab #f 1)
+                  (extract-single-line-indentation
+                   '(#\tab)))
+
+    (t:test-equal '(#\space #t 1)
+                  (extract-single-line-indentation
+                   '(#\space #\tab)))
+
+    (t:test-equal '(#\space #t 2)
+                  (extract-single-line-indentation
+                   '(#\space #\space #\tab #\space)))
+
+    (t:test-equal '(#\tab #t 3)
+                  (extract-single-line-indentation
+                   '(#\tab #\tab #\tab #\space)))
+
+    (t:test-equal '(#\tab #t 3)
+                  (extract-single-line-indentation
+                   '(#\tab #\tab #\tab #\a #\tab)))
+
+    (t:test-equal '(#\tab #t 3)
+                  (extract-single-line-indentation
+                   '(#\tab #\tab #\tab #\a #\space)))))
+
+(define (test-extract-line-indentations)
+  (define extract-line-indentations
+    (@@ (heredoc) extract-line-indentations))
+  (t:test-group "extract-line-indentations"
+    (t:test-equal '()
+                  (extract-line-indentations
+                   '()))
+
+    (t:test-equal '((#nil 0))
+                  (extract-line-indentations
+                   '("")))
+
+    (t:test-equal '((#nil 0) (#nil 0) (#nil 0))
+                  (extract-line-indentations
+                   '("" "" "")))
+
+    (t:test-equal '((#nil 0) (#nil 0) (#nil 0))
+                  (extract-line-indentations
+                   '("a" "b" "c")))
+
+    (t:test-equal '((#\space 1) (#\space 2) (#\space 3))
+                  (extract-line-indentations
+                   '(" " "  " "   ")))
+
+    (t:test-equal '((#\space 1) (#\tab 1) (#\space 3))
+                  (extract-line-indentations
+                   '(" " "	" "   ")))
+
+    (t:test-equal '((#nil 0) (#\space 3) (#\tab 2))
+                  (extract-line-indentations
+                   '("no spaces" "   with spaces" "		with tabs")))))
+
+(define (test-maximum-indentation)
+  (define maximum-indentation
+    (@@ (heredoc) maximum-indentation))
+  (t:test-group "maximum-indentation"
+    (t:test-equal 0
+                  (maximum-indentation
+                   '()))
+
+    (t:test-equal 0
+                  (maximum-indentation
+                   '("")))
+
+    (t:test-equal 0
+                  (maximum-indentation
+                   '("" "" "")))
+
+    (t:test-equal 0
+                  (maximum-indentation
+                   '("" " " "")))
+
+    (t:test-equal 1
+                  (maximum-indentation
+                   '(" " " " " ")))
+
+    (t:test-equal 2
+                  (maximum-indentation
+                   '("    a" "   b" "  c")))
+
+    (t:test-equal 1
+                  (maximum-indentation
+                   '("  space space" " 	space tab" "  	space space tab")))
+
+    (t:test-equal 0
+                  (maximum-indentation
+                   '("  space space" " 	space tab" "none")))))
+
+(define (test-trim-indentation)
+  (define trim-indentation
+    (@@ (heredoc) trim-indentation))
+  (t:test-group "trim-indentation"
+    (t:test-equal ""
+                  (trim-indentation ""))
+
+    (t:test-equal "alltogether"
+                  (trim-indentation "alltogether"))
+
+    (t:test-equal "with spaces between"
+                  (trim-indentation "with spaces between"))
+
+    (t:test-equal "with spaces around "
+                  (trim-indentation " with spaces around "))
+
+    (t:test-equal "with  multiple  spaces  "
+                  (trim-indentation "  with  multiple  spaces  "))
+
+    (t:test-equal "tabs	"
+                  (trim-indentation "		tabs	"))
+
+    (t:test-equal "tabs and spaces "
+                  (trim-indentation "		tabs and spaces "))
+
+    (t:test-equal "\n"
+                  (trim-indentation "\n"))
+
+    (t:test-equal "\n\n\nmultiple empty lines\n\n\n"
+                  (trim-indentation "\n\n\nmultiple empty lines\n\n\n"))
+
+    (t:test-equal "\n\nmixed\n indentations\n"
+                  (trim-indentation "\n\nmixed\n indentations\n"))
+
+    (t:test-equal "\n\n\n \n  lines with only spaces\n"
+                  (trim-indentation "\n\n  \n   \n    lines with only spaces\n"))
+
+    (t:test-equal "\n\n    mixed spaces\n	and tabs"
+                  (trim-indentation "\n\n    mixed spaces\n	and tabs"))
+
+    (t:test-equal "\nstripped\n  tabs"
+                  (trim-indentation "\n	stripped\n	  tabs"))
+
+    (t:test-equal "
+#!/bin/sh
+set -eu
+
+ret=0
+if cmd; then
+	echo 'Done!'
+	ret=1
+fi
+exit $ret
+"
+                    (trim-indentation "
+	#!/bin/sh
+	set -eu
+
+	ret=0
+	if cmd; then
+		echo 'Done!'
+		ret=1
+	fi
+	exit $ret
+"))))
+
+(define (test-non-quote-chars?)
+  (define non-quote-chars?
+    (@@ (heredoc) non-quote-chars?))
+  (t:test-group "non-quote-chars?"
+    (t:test-equal #f
+                  (non-quote-chars?
+                   '()))
+
+    (t:test-equal #f
+                  (non-quote-chars?
+                   '(#\")))
+
+    (t:test-equal #f
+                  (non-quote-chars?
+                   '(#\" #\" #\")))
+
+    (t:test-equal #t
+                  (non-quote-chars?
+                   '(#\" #\" #\-)))
+
+    (t:test-equal #t
+                  (non-quote-chars?
+                   '(#\a #\")))))
+
+(define (test-heredoc-reader)
+  (t:test-group "heredoc-reader"
+    (t:test-equal ""
+                  #""
+""#)
+
+    (t:test-equal "  "
+                  #""
+  ""#)
+
+    (t:test-equal "                    "
+                  #""
+                    ""#)
+
+    (t:test-equal ""
+                  #""-
+                    ""#)
+
+    (t:test-equal "                    some\n                    text"
+                  #""
+                    some
+                    text""#)
+
+    (t:test-equal "no trailing newline"
+                  #""-
+                    no trailing newline""#)
+
+    (t:test-equal "trailing newline\n"
+                  #""-
+                    trailing newline
+                    ""#)
+
+    (t:test-equal "some\ntext"
+                  #""-
+                    some
+                    text""#)
+
+    (t:test-equal "  indented\ntext"
+                  #""-
+                      indented
+                    text""#)
+
+    (t:test-equal "with\nnewline\n"
+                  #""-
+                      with
+                      newline
+                      ""#)
+
+    (t:test-equal "  unindented\n  newline\n"
+                  #""-
+                      unindented
+                      newline
+                    ""#)
+
+    (t:test-equal "single quote: \"inside\"\n"
+                  #"-
+                    single quote: "inside"
+                    "#)
+
+    (t:test-equal "multiple quotes: #\"\"\"inside\"\"\"#\n"
+                  #""""-
+                    multiple quotes: #"""inside"""#
+                    """"#)
+
+    (t:test-equal "                    indented"
+                  #"
+                    indented"#)
+
+    (t:test-equal "unindented"
+                  #""-
+                    unindented""#)
+
+    (t:test-equal "#!/bin/sh
+set -eu
+
+some-cmd
+echo \"$SOMETHING\"# here is a valid glued comment
+if cmd; then
+	echo 'Indentation here!'
+	echo \"\"# anothe valid comment, glued to an empty string
+fi
+"
+                  #"""-
+                    #!/bin/sh
+                    set -eu
+
+                    some-cmd
+                    echo "$SOMETHING"# here is a valid glued comment
+                    if cmd; then
+                    	echo 'Indentation here!'
+                    	echo ""# anothe valid comment, glued to an empty string
+                    fi
+                    """#)))
+
+(define test-fns
+  (list
+   test-extract-single-line-indentation
+   test-extract-line-indentations
+   test-maximum-indentation
+   test-trim-indentation
+   test-non-quote-chars?
+   test-heredoc-reader))
+
+(define (main)
+  (t:test-begin "heredoc")
+  (for-each (lambda (fn) (fn)) test-fns)
+  (let ((n-fail (t:test-runner-fail-count (t:test-runner-get))))
+    (t:test-end)
+    (when (not (= 0 n-fail))
+      (exit 1))))
+
+(main)