private/loc-wrapper.ss
;; test cases:
#;()
#;(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))
  
  ;; lw = (union quo unq loc-wrapper)
  
  ;; e : (union string symbol (listof lw))
  ;; line, line-span, column, column-span : number
  (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))))