From f926a676ef06c7bc14d73a8414be32c27b663473 Mon Sep 17 00:00:00 2001 From: EuAndreh Date: Mon, 14 Mar 2022 07:20:20 -0300 Subject: mv src/curth0.scm src/lib/ --- src/curth0.scm | 471 ----------------------------------------------------- src/lib/curth0.scm | 471 +++++++++++++++++++++++++++++++++++++++++++++++++++++ 2 files changed, 471 insertions(+), 471 deletions(-) delete mode 100644 src/curth0.scm create mode 100644 src/lib/curth0.scm (limited to 'src') diff --git a/src/curth0.scm b/src/curth0.scm deleted file mode 100644 index c56263f..0000000 --- a/src/curth0.scm +++ /dev/null @@ -1,471 +0,0 @@ -(define-module (curth0) - #:use-module ((language tree-il) #:prefix tree-il:) - #:use-module ((ice-9 pretty-print) #:prefix pp:) - #:use-module ((srfi srfi-1) #:prefix s1:) - #:use-module ((srfi srfi-64) #:prefix t:) - #:export (-> - ->>)) - -(define (tap x) - (pp:pretty-print x) - x) - -(define-syntax -> - (syntax-rules () - ((_) #f) - ((_ x) x) - ((_ x (f . (head ...))) (f x head ...)) - ((_ x f) (f x)) - ((_ x (f . (head ...)) rest ...) (-> (f x head ...) rest ...)) - ((_ x f rest ...) (-> (f x) rest ...)))) - -(define-syntax ->> - (syntax-rules () - ((_) #f) - ((_ x) x) - ((_ x (f ...)) (f ... x)) - ((_ x f) (f x)) - ((_ x (f ...) rest ...) (->> (f ... x) rest ...)) - ((_ x f rest ...) (->> (f x) rest ...)))) - -(define (test-thread-macro) - (define (expand l) - (tree-il:tree-il->scheme (macroexpand l))) - - (t:test-group "-> and ->>" - (t:test-equal '#f (expand '(->))) - (t:test-equal '#f (expand '(->>))) - - (t:test-equal '1 (expand '(-> 1))) - (t:test-equal '1 (expand '(->> 1))) - - (t:test-equal '(f 1) (expand '(-> (f 1)))) - (t:test-equal '(f 1) (expand '(->> (f 1)))) - - (t:test-equal '(f 1 2 3) (expand '(-> 1 (f 2 3)))) - (t:test-equal '(f 2 3 1) (expand '(->> 1 (f 2 3)))) - - (t:test-equal '(f 1) (expand '(-> 1 f))) - (t:test-equal '(f 1) (expand '(->> 1 f))) - - (t:test-equal '(f2 (f1 1)) (expand '(-> 1 f1 f2))) - (t:test-equal '(f2 (f1 1)) (expand '(->> 1 f1 f2))) - - (t:test-equal '(f2 (f1 1)) (expand '(-> 1 (f1) f2))) - (t:test-equal '(f2 (f1 1)) (expand '(->> 1 (f1) f2))) - - (t:test-equal '(f2 (f1 1)) (expand '(-> 1 f1 (f2)))) - (t:test-equal '(f2 (f1 1)) (expand '(->> 1 f1 (f2)))) - - (t:test-equal '(f2 (f1 1)) (expand '(-> 1 (f1) (f2)))) - (t:test-equal '(f2 (f1 1)) (expand '(->> 1 (f1) (f2)))) - - (t:test-equal '(f1 1 (f2)) (expand '(-> 1 (f1 (f2))))) - (t:test-equal '(f1 (f2) 1) (expand '(->> 1 (f1 (f2))))) - - (t:test-equal '(f6 (f5 (f4 (f3 (f1 1 (f2)))) 0 1 2)) - (expand '(-> 1 (f1 (f2)) f3 (f4) (f5 0 1 2) f6))) - (t:test-equal '(f6 (f5 0 1 2 (f4 (f3 (f1 (f2) 1))))) - (expand '(->> 1 (f1 (f2)) f3 (f4) (f5 0 1 2) f6))))) - -(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 (test-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 (extract-line-indentations lines) - (map (compose (lambda (triple) - (list (s1:first triple) - (s1:third triple))) - extract-single-line-indentation - string->list) - lines)) - -(define (test-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 (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 (test-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 (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 (test-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 (non-quote-chars? chars) - (let ((non-quote-chars (filter (lambda (c) - (not (equal? #\" c))) - chars))) - (< 0 (length non-quote-chars)))) - -(define (test-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 (multiline-string-reader _char port) - (let ((multiline? #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! multiline? #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 multiline? - (trim-indentation s) - s))))) - -(read-hash-extend #\" multiline-string-reader) - -(define (test-multiline-string-reader) - (t:test-group "multiline-string-reader" - (t:test-equal "" - #"" -""#) - - (t:test-equal " " - #"" - ""#) - - (t:test-equal " " - #"" - ""#) - - (t:test-equal "" - #""- - ""#) - - (t:test-equal " some\n text" - #"" - some - text""#) - - (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 "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-thread-macro - test-extract-single-line-indentation - test-extract-line-indentations - test-maximum-indentation - test-trim-indentation - test-non-quote-chars? - test-multiline-string-reader)) - -(define (unit-tests) - (t:test-begin "curth0-tests") - (for-each (lambda (fn) (fn)) test-fns) - (let ((n-fail (t:test-runner-fail-count (t:test-runner-get)))) - (t:test-end) - n-fail)) diff --git a/src/lib/curth0.scm b/src/lib/curth0.scm new file mode 100644 index 0000000..c56263f --- /dev/null +++ b/src/lib/curth0.scm @@ -0,0 +1,471 @@ +(define-module (curth0) + #:use-module ((language tree-il) #:prefix tree-il:) + #:use-module ((ice-9 pretty-print) #:prefix pp:) + #:use-module ((srfi srfi-1) #:prefix s1:) + #:use-module ((srfi srfi-64) #:prefix t:) + #:export (-> + ->>)) + +(define (tap x) + (pp:pretty-print x) + x) + +(define-syntax -> + (syntax-rules () + ((_) #f) + ((_ x) x) + ((_ x (f . (head ...))) (f x head ...)) + ((_ x f) (f x)) + ((_ x (f . (head ...)) rest ...) (-> (f x head ...) rest ...)) + ((_ x f rest ...) (-> (f x) rest ...)))) + +(define-syntax ->> + (syntax-rules () + ((_) #f) + ((_ x) x) + ((_ x (f ...)) (f ... x)) + ((_ x f) (f x)) + ((_ x (f ...) rest ...) (->> (f ... x) rest ...)) + ((_ x f rest ...) (->> (f x) rest ...)))) + +(define (test-thread-macro) + (define (expand l) + (tree-il:tree-il->scheme (macroexpand l))) + + (t:test-group "-> and ->>" + (t:test-equal '#f (expand '(->))) + (t:test-equal '#f (expand '(->>))) + + (t:test-equal '1 (expand '(-> 1))) + (t:test-equal '1 (expand '(->> 1))) + + (t:test-equal '(f 1) (expand '(-> (f 1)))) + (t:test-equal '(f 1) (expand '(->> (f 1)))) + + (t:test-equal '(f 1 2 3) (expand '(-> 1 (f 2 3)))) + (t:test-equal '(f 2 3 1) (expand '(->> 1 (f 2 3)))) + + (t:test-equal '(f 1) (expand '(-> 1 f))) + (t:test-equal '(f 1) (expand '(->> 1 f))) + + (t:test-equal '(f2 (f1 1)) (expand '(-> 1 f1 f2))) + (t:test-equal '(f2 (f1 1)) (expand '(->> 1 f1 f2))) + + (t:test-equal '(f2 (f1 1)) (expand '(-> 1 (f1) f2))) + (t:test-equal '(f2 (f1 1)) (expand '(->> 1 (f1) f2))) + + (t:test-equal '(f2 (f1 1)) (expand '(-> 1 f1 (f2)))) + (t:test-equal '(f2 (f1 1)) (expand '(->> 1 f1 (f2)))) + + (t:test-equal '(f2 (f1 1)) (expand '(-> 1 (f1) (f2)))) + (t:test-equal '(f2 (f1 1)) (expand '(->> 1 (f1) (f2)))) + + (t:test-equal '(f1 1 (f2)) (expand '(-> 1 (f1 (f2))))) + (t:test-equal '(f1 (f2) 1) (expand '(->> 1 (f1 (f2))))) + + (t:test-equal '(f6 (f5 (f4 (f3 (f1 1 (f2)))) 0 1 2)) + (expand '(-> 1 (f1 (f2)) f3 (f4) (f5 0 1 2) f6))) + (t:test-equal '(f6 (f5 0 1 2 (f4 (f3 (f1 (f2) 1))))) + (expand '(->> 1 (f1 (f2)) f3 (f4) (f5 0 1 2) f6))))) + +(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 (test-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 (extract-line-indentations lines) + (map (compose (lambda (triple) + (list (s1:first triple) + (s1:third triple))) + extract-single-line-indentation + string->list) + lines)) + +(define (test-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 (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 (test-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 (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 (test-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 (non-quote-chars? chars) + (let ((non-quote-chars (filter (lambda (c) + (not (equal? #\" c))) + chars))) + (< 0 (length non-quote-chars)))) + +(define (test-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 (multiline-string-reader _char port) + (let ((multiline? #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! multiline? #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 multiline? + (trim-indentation s) + s))))) + +(read-hash-extend #\" multiline-string-reader) + +(define (test-multiline-string-reader) + (t:test-group "multiline-string-reader" + (t:test-equal "" + #"" +""#) + + (t:test-equal " " + #"" + ""#) + + (t:test-equal " " + #"" + ""#) + + (t:test-equal "" + #""- + ""#) + + (t:test-equal " some\n text" + #"" + some + text""#) + + (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 "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-thread-macro + test-extract-single-line-indentation + test-extract-line-indentations + test-maximum-indentation + test-trim-indentation + test-non-quote-chars? + test-multiline-string-reader)) + +(define (unit-tests) + (t:test-begin "curth0-tests") + (for-each (lambda (fn) (fn)) test-fns) + (let ((n-fail (t:test-runner-fail-count (t:test-runner-get)))) + (t:test-end) + n-fail)) -- cgit v1.2.3