148 lines
4.6 KiB
Scheme
148 lines
4.6 KiB
Scheme
;; 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))))
|