diff options
| -rw-r--r-- | src/infrastructure/lib/curth0.scm | 188 |
1 files changed, 97 insertions, 91 deletions
diff --git a/src/infrastructure/lib/curth0.scm b/src/infrastructure/lib/curth0.scm index 5d73160..7360f6d 100644 --- a/src/infrastructure/lib/curth0.scm +++ b/src/infrastructure/lib/curth0.scm @@ -72,24 +72,25 @@ (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)) +(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" @@ -149,13 +150,14 @@ (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)) +(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" @@ -187,13 +189,14 @@ (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))))) +(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" @@ -229,18 +232,19 @@ (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"))) +(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" @@ -294,7 +298,7 @@ if cmd; then fi exit $ret " - (trim-indentation " + (trim-indentation " #!/bin/sh set -eu @@ -307,11 +311,12 @@ exit $ret ")))) -(define (non-quote-chars? chars) - (let ((non-quote-chars (filter (lambda (c) - (not (equal? #\" c))) - chars))) - (< 0 (length non-quote-chars)))) +(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?" @@ -335,47 +340,48 @@ exit $ret (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) +(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" |