()
(a)
(a
b)
(a
(b c)
d)
(abcdefghijkl
c)
((a b)
c)
([{}])
,@,'(x)
(term a)
(module loc-wrapper mzscheme
(require (lib "kw.ss")
(lib "etc.ss")
"term.ss"
(lib "contract.ss"))
(require-for-syntax "term-fn.ss")
(define-struct unq (e) (make-inspector))
(define-struct quo (e) (make-inspector))
(define (build-loc-wrapper e line column)
(make-loc-wrapper e line #f column #f))
(define-struct loc-wrapper (e line line-span column column-span) (make-inspector))
(define-syntax-set (to-loc-wrapper to-loc-wrapper/uq)
(define (process-arg stx)
(define (reader-shorthand shorthand arg)
#`(build-loc-wrapper
(list (build-loc-wrapper #,shorthand
#,(syntax-line stx)
#,(syntax-column stx))
#,(process-arg arg))
#,(syntax-line stx)
#,(syntax-column stx)))
(let-values ([(op cl)
(if (syntax? stx)
(case (syntax-property stx 'paren-shape)
[(#\{) (values "{" "}")]
[(#\[) (values "[" "]")]
[else (values "(" ")")])
(values #f #f))])
(syntax-case* stx (unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
['a #`(make-quo #,(reader-shorthand "'" #'a))]
[,a #`(make-unq #,(reader-shorthand "," #'a))]
[,@a #`(make-unq #,(reader-shorthand ",@" #'a))]
[(term a)
#`(build-loc-wrapper
(list (build-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx))
#,(process-arg (car (syntax->list stx)))
(make-quo #,(process-arg (cadr (syntax->list stx))))
(build-loc-wrapper #,cl #f #f))
#,(syntax-line stx)
#,(syntax-column stx))]
[(a ...)
#`(build-loc-wrapper
(list (build-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx))
#,@(map process-arg (syntax->list (syntax (a ...))))
(build-loc-wrapper #,cl #f #f))
#,(syntax-line stx)
#,(syntax-column stx))]
[(a b ... . c)
#`(build-loc-wrapper
(list (build-loc-wrapper #,op #,(syntax-line stx) #,(syntax-column stx))
#,@(map process-arg (syntax->list (syntax (a b ...))))
(build-loc-wrapper #," . " #f #f)
#,(process-arg #'c)
(build-loc-wrapper #,cl #f #f))
#,(syntax-line stx)
#,(syntax-column stx))]
[x
(identifier? #'x)
#`(build-loc-wrapper
'#,(syntax-e #'x)
#,(syntax-line stx)
#,(syntax-column stx))]
[x
#`(build-loc-wrapper
#,(format "~s" (syntax-e #'x))
#,(syntax-line stx)
#,(syntax-column stx))])))
(define (to-loc-wrapper/proc stx)
(syntax-case stx ()
[(_ stx)
#`(add-spans #,(process-arg #'stx))]))
(define (to-loc-wrapper/uq/proc stx)
(syntax-case stx ()
[(_ stx)
#`(add-spans (make-unq #,(process-arg #'stx)))])))
(define (add-spans lw)
(define (add-spans/lw lw line col)
(cond
[(quo? lw) (add-spans/lw (quo-e lw) line col)]
[(unq? lw) (add-spans/lw (unq-e lw) line col)]
[else
(let ([start-line (or (loc-wrapper-line lw) line)]
[start-column (or (loc-wrapper-column lw) col)])
(let-values ([(last-line last-column) (add-spans/obj (loc-wrapper-e lw) start-line start-column)])
(unless (loc-wrapper-line lw)
(set-loc-wrapper-line! lw line))
(unless (loc-wrapper-column lw)
(set-loc-wrapper-column! lw col))
(set-loc-wrapper-line-span! lw (- last-line start-line))
(set-loc-wrapper-column-span! lw (- last-column start-column))
(values last-line last-column)))]))
(define (add-spans/obj e line col)
(cond
[(string? e)
(values line (+ col (string-length e)))]
[(symbol? e)
(values line (+ col (string-length (symbol->string e))))]
[else
(let loop ([lws e]
[line line]
[current-col col])
(cond
[(null? lws) (values line current-col)]
[else
(let-values ([(last-line last-column) (add-spans/lw (car lws) line current-col)])
(loop (cdr lws)
last-line
last-column))]))]))
(add-spans/lw lw #f #f)
lw)
(provide/contract
(struct loc-wrapper ((e any/c)
(line (and/c number? (or/c zero? positive?)))
(line-span (and/c number? (or/c zero? positive?)))
(column (and/c number? (or/c zero? positive?)))
(column-span (and/c number? (or/c zero? positive?))))))
(provide to-loc-wrapper
to-loc-wrapper/uq
(struct unq (e))
(struct quo (e))))