(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))