aboutsummaryrefslogtreecommitdiff
path: root/src/infrastructure/lib/curth0.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/infrastructure/lib/curth0.scm')
-rw-r--r--src/infrastructure/lib/curth0.scm481
1 files changed, 0 insertions, 481 deletions
diff --git a/src/infrastructure/lib/curth0.scm b/src/infrastructure/lib/curth0.scm
deleted file mode 100644
index 7360f6d..0000000
--- a/src/infrastructure/lib/curth0.scm
+++ /dev/null
@@ -1,481 +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-1) #:select (first second))
- #:use-module ((srfi srfi-64) #:prefix t:)
- #:export (->
- ->>
- tap)
- #:re-export (first
- second))
-
-(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)))))
-
-(eval-when (expand load eval)
- (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)))))
-
-(eval-when (compile load eval)
- (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")))))
-
-(eval-when (compile load eval)
- (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")))))
-
-(eval-when (compile load eval)
- (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
-"))))
-
-
-(eval-when (compile load eval)
- (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 #\")))))
-
-(eval-when (expand load eval)
- (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))
generated by cgit v1.2.3 (git 2.49.0) at 2025-07-13 22:04:29 +0000