93 lines
3.5 KiB
Racket
93 lines
3.5 KiB
Racket
#lang racket/base
|
|
(require (for-template racket/base)
|
|
(for-template "loc-wrapper-rt.rkt")
|
|
"term-fn.rkt")
|
|
(provide to-lw/proc to-lw/uq/proc)
|
|
|
|
(define (process-arg stx quote-depth)
|
|
(define quoted? (quote-depth . > . 0))
|
|
(define init-loc-wrapper/q? (if quoted? 'init-loc-wrapper/quoted 'init-loc-wrapper/unquoted))
|
|
(define-values (op cl)
|
|
(if (syntax? stx)
|
|
(case (syntax-property stx 'paren-shape)
|
|
[(#\{) (values "{" "}")]
|
|
[(#\[) (values "[" "]")]
|
|
[else (values "(" ")")])
|
|
(values #f #f)))
|
|
(define (reader-shorthand arg qd-delta mrk)
|
|
#`#(#,init-loc-wrapper/q?
|
|
#(list #(#,init-loc-wrapper/q? #,mrk
|
|
#,(syntax-line stx)
|
|
#,(syntax-column stx))
|
|
'spring
|
|
#,(process-arg arg (+ quote-depth qd-delta)))
|
|
#,(syntax-line stx)
|
|
#,(syntax-column stx)))
|
|
(define (handle-sequence qd-delta)
|
|
(with-syntax ([(others ...) (map (λ (x) (process-arg x (+ qd-delta quote-depth))) (syntax->list stx))])
|
|
#`#(#,(if quoted?
|
|
'init-loc-wrapper-sequence/quoted
|
|
'init-loc-wrapper-sequence/unquoted)
|
|
#,op #,(syntax-line stx) #,(syntax-column stx)
|
|
others ...)))
|
|
(syntax-case* stx (name unquote quote unquote-splicing term) (λ (x y) (eq? (syntax-e x) (syntax-e y)))
|
|
['a (reader-shorthand #'a +1 (if (= quote-depth 0) "" "'"))]
|
|
[,a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ","))]
|
|
[,@a (reader-shorthand #'a -1 (if (= quote-depth 1) "" ",@"))]
|
|
[(term a)
|
|
(if (= quote-depth 0)
|
|
#`#(#,init-loc-wrapper/q?
|
|
#(list #(#,init-loc-wrapper/q? "" #,(syntax-line stx) #,(syntax-column stx))
|
|
'spring
|
|
#,(process-arg (cadr (syntax->list stx)) (+ quote-depth 1)))
|
|
#,(syntax-line stx)
|
|
#,(syntax-column stx))
|
|
(handle-sequence +1))]
|
|
[(a ...)
|
|
(handle-sequence 0)]
|
|
[(a b ... . c)
|
|
#`#(#,init-loc-wrapper/q?
|
|
#(list #(#,init-loc-wrapper/q? #,op #,(syntax-line stx) #,(syntax-column stx))
|
|
#,@(map (λ (x) (process-arg x quote-depth)) (syntax->list (syntax (a b ...))))
|
|
#(#,init-loc-wrapper/q? #," . " #f #f)
|
|
#,(process-arg #'c quote-depth)
|
|
#(#,init-loc-wrapper/q? #,cl #f #f))
|
|
#,(syntax-line stx)
|
|
#,(syntax-column stx))]
|
|
[x
|
|
(and (identifier? #'x)
|
|
(and (syntax-transforming?)
|
|
(or (term-fn? (syntax-local-value #'x (λ () #f)))
|
|
(judgment-form? (syntax-local-value #'x (λ () #f))))))
|
|
#`#(make-lw
|
|
'#,(syntax-e #'x)
|
|
#,(syntax-line stx)
|
|
#f
|
|
#,(syntax-column stx)
|
|
#f
|
|
#f
|
|
#t)]
|
|
[x
|
|
(identifier? #'x)
|
|
#`#(#,init-loc-wrapper/q?
|
|
'#,(syntax-e #'x)
|
|
#,(syntax-line stx)
|
|
#,(syntax-column stx))]
|
|
[x
|
|
#`#(#,init-loc-wrapper/q?
|
|
#,(let ([base (syntax-e #'x)])
|
|
(if (string? base)
|
|
#`#(rewrite-quotes #,(format "~s" base))
|
|
(format "~s" (syntax-e #'x))))
|
|
#,(syntax-line stx)
|
|
#,(syntax-column stx))]))
|
|
|
|
(define (to-lw/proc stx [add-add-spans? #t])
|
|
(if add-add-spans?
|
|
#`(add-spans/interp-lws #,(process-arg stx 1))
|
|
(process-arg stx 1)))
|
|
(define (to-lw/uq/proc stx [add-add-spans? #t])
|
|
(if add-add-spans?
|
|
#`(add-spans/interp-lws #,(process-arg stx 0))
|
|
(process-arg stx 0)))
|