#|
matchertext.scm -- reader extension for embedding matchertext

Copyright © 2026 Hernán Ibarra Mejia.

This file is part of `matchertext`.

`matchertext` is free software: you can redistribute it and/or modify it under
the terms of the GNU General Public License as published by the Free Software
Foundation, version 3 of the License.

`matchertext` is distributed in the hope that it will be useful, but WITHOUT ANY
WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A
PARTICULAR PURPOSE. See the GNU General Public License for more details.

You should have received a copy of the GNU General Public License along with
`matchertext` If not, see <https://www.gnu.org/licenses/>.
|#

(define-library matchertext
  (import (scheme base)
          (scheme read)
          (scheme char)
          (chicken type)
          (only (chicken base) assert add1)
          (only (chicken string) reverse-list->string substring=?)
          (only (chicken port) call-with-input-string)
          (only (chicken read-syntax) set-sharp-read-syntax!))

  (begin
    (: matching? (char char --> boolean))
    (define (matching? opener closer)
      (case opener
        ((#\oroundbracket) (char=? closer #\croundbracket))
        ((#\osquarebracket) (char=? closer #\csquarebracket))
        ((#\ocurlybracket) (char=? closer #\ccurlybracket))
        (else #f)))

    (: opener? (char --> boolean))
    (define (opener? char)
      (or (char=? char #\oroundbracket)
          (char=? char #\osquarebracket)
          (char=? char #\ocurlybracket)))

    (: closer? (char --> boolean))
    (define (closer? char)
      (or (char=? char #\croundbracket)
          (char=? char #\csquarebracket)
          (char=? char #\ccurlybracket)))

    (: substring-at-index? (string string number --> boolean))
    (define (substring-at-index? maybe-substr str index)
      (substring=? maybe-substr str 0 index (string-length maybe-substr)))

    (: skip-whitespace (input-port -> void))
    (define (skip-whitespace port)
      (let ((char (peek-char port)))
        (when (and (not (eof-object? char)) (char-whitespace? char))
          (read-char port)
          (skip-whitespace port))))

    (define (error-eof) (error "unexpected end of file"))

    (define (error-unexpected-char char)
      (error "unexpected character" char))

    (define (error-unmatched openers)
      (error "unmatched openers" openers))

    (: consume-char (char input-port -> (or undefined noreturn)))
    (define (consume-char expected-char port)
      (let ((char (read-char port)))
        (cond ((eof-object? char) (error-eof))
              ((not (char=? char expected-char))
               (error-unexpected-char char)))))

    (: read-matchertext (input-port -> string))
    (define (read-matchertext port)
      (let loop ((chars-read '())
                 (unmatched-openers '()))
        (let ((char (peek-char port))
              (return (lambda ()
                        (unless (null? unmatched-openers)
                          (error-unmatched unmatched-openers))
                        (reverse-list->string chars-read))))
          (cond ((eof-object? char) (return))
                ((opener? char)
                 (read-char port)
                 (loop (cons char chars-read)
                       (cons char unmatched-openers)))
                ((closer? char)
                 (cond ((null? unmatched-openers) (return))
                       ((matching? (car unmatched-openers) char)
                        (read-char port)
                        (loop (cons char chars-read)
                              (cdr unmatched-openers)))
                       (else (return))))
                (else (read-char port)
                      (loop (cons char chars-read)
                            unmatched-openers))))))

    (: read-openers (input-port -> (list-of char)))
    (define (read-openers port)
      (let loop ((openers '())
                 (char (peek-char port)))
        (if (opener? char)
          (begin (read-char port)
                 (loop (cons char openers)
                       (peek-char port)))
          openers)))

    (: read-matching-closers
       ((list-of char) input-port -> (list-of char)))
    (define (read-matching-closers openers port)
      (do ((openers openers (cdr openers))
           (closers '() (cons (read-char port) closers)))
        ((null? openers) closers)
        (unless (matching? (car openers) (peek-char port))
          (error-unexpected-char (peek-char port)))))

    (: parse-interpolations (string string string --> list))
    (define (parse-interpolations str opener-str closer-str)
      (define (space-for-interpolation-at-index? index)
        (let ((chars-remaining (- (string-length str) index)))
          (> chars-remaining (+ (string-length opener-str)
                                (string-length closer-str)))))
      (let loop ((index 0) (old-index 0) (reversed-result '()))
        (cond ((not (space-for-interpolation-at-index? index))
               (reverse (cons (string-copy str old-index)
                              reversed-result)))
              ((substring-at-index? opener-str str index)
               (let* ((index-after-opener
                        (+ index (string-length opener-str)))
                      (interpolation
                        (call-with-input-string
                          (string-copy str index-after-opener)
                          read-matchertext))
                      (index-at-closer
                        (+ index-after-opener (string-length interpolation)))
                      (index-after-all
                        (+ index-at-closer (string-length closer-str))))
                 (assert (substring-at-index? closer-str str index-at-closer))
                 (let* ((p (open-input-string interpolation))
                        (expression (read p)))
                   (skip-whitespace p)
                   (unless (eof-object? (peek-char p))
                     (error-unexpected-char (read-char p)))
                   (loop index-after-all
                         index-after-all
                         (cons expression
                               (if (= old-index index)
                                 reversed-result
                                 (cons (string-copy str old-index index)
                                       reversed-result)))))))
              (else (loop (add1 index) old-index reversed-result)))))

    (: main-reader (input-port -> (or list string)))
    (define (main-reader port)
      (define reversed-openers (read-openers port))
      (define reversed-closers (read-matching-closers reversed-openers port))
      (consume-char #\" port)
      (consume-char #\oroundbracket port)
      (define matchertext (read-matchertext port))
      (consume-char #\croundbracket port)
      (consume-char #\" port)
      (if (null? reversed-openers)
        matchertext
        `(string-append
           ,@(parse-interpolations
               matchertext
               (reverse-list->string reversed-openers)
               (reverse-list->string reversed-closers)))))

    (set-sharp-read-syntax! #\M main-reader)))