;; Something not unlike racket's at-expr.
;; I, Linus Björnstam, release this into the public domain.
;; If public domain is not applicable in your jurisdiction
;; you may use this under the Creative Commons 0 licence.
;; I hope you have fun, though.


(define-module (syntax at-expr)
  #:use-module (ice-9 rdelim)
  #:use-module (sxml simple)
  #:use-module (sxml transform)
  #:use-module (srfi srfi-1))

(define (fix-atexp sexp)
  (define (untext tag str)
    str)
  (define (unstr tag pos str) str)
  (define (undefault . args) args)
  (define (unatexp tag pos atexp)
    atexp)
  (pre-post-order sexp `((atexpr . ,unatexp)
                         (str . ,unstr)
                         (*text* . ,untext)
                         (*default* . ,undefault))))

(read-hash-extend #\@ (lambda (chr port)  (define res (read-atexp port))
                              (fix-atexp res)))

(define dispatch-char #\@)

(read-enable 'curly-infix)

(define (get-output-string-and-close port)
  (let ((res (get-output-string port)))
    (close-port port)
    res))
(define (port-unwritten? port)
  (and (= 0 (port-column port))
       (= 0 (port-line port))))


(define (skip-whitespace port)
  (when (char-whitespace? (peek-char port))
    (read-char port)
    (skip-whitespace port)))


(define (skip-at-most-n-whitespace port n)
  (let loop ((c 0))
    (cond
     ((= c n) n)
     ((eq? #\space (peek-char port))
      (read-char port)
      (loop (+ c 1)))
     ((eq? #\newline (peek-char port))
      n)
     (else c))))

;; TODO: just skip spaces in "\n  \n"
(define* (read-squiggly port #:optional (skip-space 0) (squiggly-delimiter #f))
  (define sp (open-output-string))
  (define line (port-line port))
  (define col (port-column port))
  (define (string str)
    `(str (@ (line ,line) (column ,col)) ,str))
  (let loop ((ch (peek-char port)))
    (cond
     ((or (eof-object? ch)
          (and squiggly-delimiter (eq? ch #\})))
      (read-char port)
      (if (port-unwritten? sp)
          '()
          (list (string (get-output-string-and-close sp)))))
     ((eq? ch dispatch-char)
      (read-char port)
      (let* ((output-str (get-output-string-and-close sp))
             (atexp (read-atexp port))
             (rest (read-squiggly port skip-space squiggly-delimiter)))
        (if (string-null? output-str)
            (cons atexp rest)
            (cons* (string output-str) atexp rest))))
     ((eq? ch #\newline)
      (read-char port)
      (let* ((new-skip-space? (skip-at-most-n-whitespace port skip-space))
             (str (get-output-string-and-close sp))
             (skip-space (if (string-null? str) skip-space new-skip-space?))
             (rest (read-squiggly port skip-space squiggly-delimiter)))
        (if (string-null? str)
            (cons "\n" rest)
            (cons* (string str) "\n" rest))))
     (else
      (display (read-char port) sp)
      (loop (peek-char port))))))

(define (read-atexp port)
  (define invalid-start-chars (string->list "]})"))
  (define line (port-line port))
  (define col (port-column port))
  (define (command-part)
    (define invalid-starts (string->list "[]{}()"))
    (define ch (peek-char port))
    (when (eof-object? ch)
      (error "Invalid atexpr at" line ': col))
    (if (memq (peek-char port) invalid-starts)
        #f
        (list (read port))))
  (define (arg-part)
    (if (memq (peek-char port) '(#\[ #\())
        (begin
          (read-char port)
          (let loop ((ch (peek-char port)))
            (cond
             ((eof-object? ch) (error "invalid atexp at " line ': col))
             ((memq ch '(#\] #\)))
              (read-char port)
              '())
             (else
              (let ((res (read port)))
                (skip-whitespace port)
                (cons res (loop (peek-char port))))))))
        #f))
  (define (squiggly-part)
    (if (eq? (peek-char port) #\{)
        (begin
          (read-char port)
          (read-squiggly port (port-column port) #t))
        #f))
  (define ch (peek-char port))
  (when (or (eof-object? ch)
            (char-whitespace? ch)
            (memq ch invalid-start-chars))
    (error "reading of at-expr failed at port position: " line ': col))

  (let* ((command? (command-part))
         (arg? (arg-part))
         (squiggly? (squiggly-part)))
    (unless (or command? arg? squiggly?)
      (error "Invalid atexpr at" line ': col))
    `(atexpr (@ (line ,line) (column ,col)) ,(compile-atexp command? arg? squiggly?))))

(define (compile-atexp command arg squiggly)
  (define (include arg)
    (or arg '()))
  (if (and command (not arg) (not squiggly))
      (car command)
      `(,@(include command)
        ,@(include arg)
        ,@(include squiggly))))