(module srfi-105 ()
  (import scheme
          chicken.read-syntax
          chicken.port
          chicken.base
          chicken.io
          chicken.irregex
          chicken.string
          chicken.condition
          srfi-13)

  (include "srfi-105-core.scm")

  (define (unmatched-close str open close)
    (let ((strlst (string->list str)))
      (let loop ((index 0)
                 (stack 0)
                 (lst strlst))
        (cond ((null? lst)
               #f)
              ((char=? (car lst) open)
               (loop (add1 index) (add1 stack) (cdr lst)))
              ((and (char=? (car lst) close)
                    (> stack 0))
               (loop (add1 index) (sub1 stack) (cdr lst)))
              ((char=? (car lst) close)
               index)
              (else (loop (add1 index) stack (cdr lst)))))))

  (define (replace-neoteric str #!optional (sym 'symbol))
    (or (and-let* ((match (irregex-search `(: (submatch ,sym) (submatch ("{(["))) str))
                   (symbol (irregex-match-substring match 1))
                   (open (irregex-match-substring match 2))
                   (open-char (string-ref open 0))
                   (close-char (case open-char
                                 ((#\{) #\})
                                 ((#\() #\))
                                 ((#\[) #\])))
                   (start (irregex-match-start-index match))
                   (end (irregex-match-end-index match))
                   (rest (substring str end))
                   (close-index (+ end (unmatched-close rest open-char close-char))))
          (replace-neoteric
           (if (condition-case
                   (member (string-ref str (add1 close-index)) '(#\{ #\( #\[))
                 ((exn bounds) #f))
               (let ((newsym (symbol->string (gensym))))
                 (string-translate*
                  (replace-neoteric (string-replace str newsym start (add1 close-index))
                                    newsym)
                  `((,newsym . ,(substring str start (add1 close-index))))))
               (string-append
                (substring str 0 start)
                (case open-char
                  ((#\()
                   (string-append open symbol " "
                                  (replace-neoteric (substring str end close-index))
                                  (substring str close-index)))
                  ((#\[)
                   (string-append "($bracket-apply$ " symbol " "
                                  (replace-neoteric (substring str end  close-index))
                                  ")"
                                  (substring str (add1 close-index))))
                  ((#\{)
                   (string-append "(" symbol
                                  (let ((inside (substring str end (add1 close-index))))
                                    (newline)
                                    (if (irregex-match '(: (* whitespace) "}") inside)
                                        ""
                                        (string-append
                                         " "
                                         open
                                         (replace-neoteric inside))))
                                  ")"
                                  (substring str (add1 close-index)))))))))
        str))

  (define (read-curly-string port)
    (let* ((stack 0)
           (str (read-token
                 (lambda (c)
                   (cond ((char=? c #\{)
                          (set! stack (add1 stack))
                          #t)
                         ((and (char=? c #\})
                               (> stack 0))
                          (set! stack (sub1 stack))
                          #t)
                         ((char=? c #\})
                          #f)))
                 port)))
      (read-char port)
      str))

  (define (read-curly port #!optional (stop-char #\}))
    (let ((str (replace-neoteric (read-curly-string port))))
      (call-with-input-string str (cut read-list <>))))

  (set-read-syntax! #\{ (lambda (p) (process-curly (read-curly p)))))