aboutsummaryrefslogtreecommitdiff
path: root/src/curth0.scm
diff options
context:
space:
mode:
Diffstat (limited to 'src/curth0.scm')
-rw-r--r--src/curth0.scm258
1 files changed, 258 insertions, 0 deletions
diff --git a/src/curth0.scm b/src/curth0.scm
new file mode 100644
index 0000000..13a3ec8
--- /dev/null
+++ b/src/curth0.scm
@@ -0,0 +1,258 @@
+(define-module (curth0)
+ #:use-module ((language tree-il) #:prefix tree-il:)
+ #:use-module ((srfi srfi-1) #:prefix s1:)
+ #:use-module ((srfi srfi-64) #:prefix t:)
+ #:export (->
+ ->>))
+
+
+(define (expand l)
+ (tree-il:tree-il->scheme (macroexpand l)))
+
+(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)
+ (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))))))
+ (list #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
+ '(" " " " " ")))))
+
+(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:third 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)))
+ (if (< 0 (length non-quote-chars))
+ non-quote-chars
+ #f)))
+
+(define (multiline-string-reader _char port)
+ "FIXME:
+ - remove the need to indent the last line with the rest of the content.
+ How does Perl, Ruby, Python, sh do it?"
+ (let ((multiline? #f)
+ (chars '()))
+ (do ((curr (read-char port)
+ (read-char port)))
+ ((equal? #\newline curr))
+ (set! chars (cons curr chars)))
+ (when (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-fns
+ (list
+ test-thread-macro
+ test-extract-single-line-indentation
+ test-extract-line-indentations))
+
+(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 15:13:27 +0000