#lang at-exp scheme
(provide $ $quote $quote-syntax #%infix)
(require "parameter.ss"
scheme/port
scheme/stxparam
(for-syntax scheme)
(planet soegaard/infix/parser)
(for-syntax (planet soegaard/infix/parser)))
(define-syntax ($quote stx)
(syntax-case stx ()
[(_ item ...)
(with-syntax ([(q ...) (local-expand #'($ item ...) 'expression #f)])
#''(#%infix (q ...)))]))
(define-syntax ($quote-syntax stx)
(syntax-case stx ()
[(_ item ...)
(with-syntax ([(q ...) (local-expand #'($ item ...) 'expression #f)])
#'#'(#%infix (q ...)))]))
(define-syntax ($ stx)
(syntax-case stx ()
[(_ item ...)
(let* ([from-at? (syntax-property stx 'scribble)])
(if from-at?
(with-syntax
([(item ...)
(let loop ([items (syntax->list #'(item ...))])
(if (null? items)
'()
(let* ([fst (car items)]
[prop (syntax-property fst 'scribble)]
[rst (loop (cdr items))])
(cond [(eq? prop 'indentation) rst]
[(not (and (pair? prop)
(eq? (car prop) 'newline)))
(cons fst rst)]
[else (cons (datum->syntax fst (cadr prop) fst)
rst)]))))])
#'($$ item ...))
#'($$ item ...)))]))
(define-syntax ($$ stx)
(syntax-case stx ()
[(_ str str* ...)
(let* ([from-at? (syntax-property stx 'scribble)]
[offset (if from-at? 0 1)]
[ip (open-input-string
(apply string-append
(map syntax->datum
(syntax->list #'(str str* ...)))))])
(port-count-lines! ip)
(let* ([line (syntax-line #'str)]
[col (+ (syntax-column #'str) offset)]
[pos (+ (syntax-position #'str) offset -1)])
(let ([result
(parse-expression
(if from-at?
(datum->syntax
#'str
(apply string-append
(map syntax->datum
(syntax->list #'(str str* ...))))
(list (syntax-source #'str)
line col pos
(syntax-span #'str)))
#'str)
ip)])
result)))]))