#|
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/>.
|#

(module matchertext ()
  (import scheme
          (only (chicken base)
                define-constant
                receive)
          (only (chicken string) reverse-list->string)
          (only (chicken format) sprintf)
          (only (chicken read-syntax) set-sharp-read-syntax!)
          (only (chicken syntax) syntax-error))

  (define-constant sharp-char #\m)
  (define-constant opening-char #\ocurlybracket)
  (define-constant closing-char #\ccurlybracket)

  (define (matcher-pair? opener closer)
    (case opener
      ((#\oroundbracket) (char=? closer #\croundbracket))
      ((#\osquarebracket) (char=? closer #\csquarebracket))
      ((#\ocurlybracket) (char=? closer #\ccurlybracket))
      (else #f)))

  (define (program-error errmsg)
    (syntax-error (string-append "matchertext: " errmsg)))
  (define (error-eof) (program-error "unexpected end of file"))
  (define (error-unexpected-char char)
    (program-error (sprintf "unexpected char: ~A" char)))

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

  (define (read-matchertext port)
    (let loop ((chars-read '()) (unmatched-openers '()))
      (define (return) (values chars-read unmatched-openers))
      (case (peek-char port)
        ((#!eof) (return))
        ((#\oroundbracket #\osquarebracket #\ocurlybracket)
         => (lambda (opener)
              (read-char port)
              (loop (cons opener chars-read) (cons opener unmatched-openers))))
        ((#\croundbracket #\csquarebracket #\ccurlybracket)
         => (lambda (closer)
              (cond ((null? unmatched-openers) (return))
                    ((matcher-pair? (car unmatched-openers) closer)
                     (read-char port)
                     (loop (cons closer chars-read) (cdr unmatched-openers)))
                    (else (return)))))
        (else => (lambda (regular-char)
                   (read-char port)
                   (loop (cons regular-char chars-read) unmatched-openers))))))

  (set-sharp-read-syntax!
    sharp-char
    (lambda (port)
      (consume-char opening-char port)
      (receive (chars-read unmatched-openers) (read-matchertext port)
        (if (not (null? unmatched-openers))
          (case (peek-char port)
            ((#!eof) (error-eof))
            (else => error-unexpected-char)))
        (consume-char closing-char port)
        (reverse-list->string chars-read)))))