(module quasistring mzscheme
  (provide qs current-quasistring-converter)
  
  (define current-quasistring-converter (make-parameter display))
  
  (define (to-string v)
    (let ((p (open-output-string)))
      (parameterize ((current-output-port p))
        ((current-quasistring-converter) v))
      (begin0
        (get-output-string p)
        (close-output-port p))))
  
  (define-syntax (qs stx)
    
    ; rewrite : syntax[string] -> syntax
    ; rewrites a quasistring syntax string into an expression that
    ; evaluates to the proper string
    (define (rewrite val)

      ; start -> syntax
      ; the main function rewrite calls.
      ; [Implementation detail: we know string->strings-and-syntax returns >= 1 object.
      ;  If it returns only one, we don't want to call string-append, because it could
      ;  make strings that were eq? into strings that aren't eq?.]
      (define (start)
        (let ((exprs (string->strings-and-syntax (syntax-e val))))
          (if (pair? (cdr exprs))
              #`(string-append #,@exprs)
              #`(#%datum . #,(car exprs)))))
      
      ; add-lexical-context : syntax -> syntax
      ;   produces a syntax object with structure and source locations equal to the argument
      ;   but with all subexpressions having lexical context of stx, the syntax object that
      ;   this macro accepts as input
      (define (add-lexical-context stx-to-enrich)
        (define (add-lexical-context/slist sl)
          (cond
            [(pair? sl) (cons (add-lexical-context (car sl))
                             (add-lexical-context/slist (cdr sl)))]
            [(null? sl) null]
            [else (add-lexical-context sl)]))
              
        (let ([s (syntax-e stx-to-enrich)])
          (cond
            [(pair? s) 
             (quasisyntax/loc stx-to-enrich #,(add-lexical-context/slist s))]
            [(null? s) stx-to-enrich]
            [else (datum->syntax-object val s stx-to-enrich stx-to-enrich)])))
            
      ; extra-width : char -> nat
      ; returns a guess at the number of characters needed to represent the given
      ; character on the screen. This number is just a guess!
      (define (width c)
        (define (char-typable? c)
          (let ((n (char->integer c)))
            (and (>= n 32) (<= n 127))))
        
        (cond
          [(memq c (map integer->char '(7 8 9 10 11 12 13 27 92))) 1]
          [(char-typable? c) 0]
          ; this is just a guess. 3 is either a 3-octet or 2-hextet representation,
          ; so I choose it.
          [else 3]))
      
      ; fresh-port : ip (box num) -> ip
      ; makes a new port that just forwards to the original port
      (define (monitored-port p box)
        (make-custom-input-port 
         (lambda (s)
           (let ((len (string-length s)))
             (let loop ((idx 0))
               (cond
                 [(and (< idx len) (char-ready? p))
                  (let ((c (read-char p)))
                    (if (eof-object? c)
                        (if (= idx 0) eof idx)
                        (begin 
                          (string-set! s idx c)
                          (set-box! box (+ (unbox box) (width c)))
                          (loop (add1 idx)))))]
                 [else idx]))))
         #f
         void))
      
      
      ; port->syntaxes : input-port -> (listof syntax)
      (define (port->syntaxes ip)
        (define offset (box 0))
        (define p (monitored-port ip offset))
        
        (define (port->syntaxes/str acc-str)
          (define (curr-string) (datum->syntax-object val (list->string (reverse acc-str))))
          (let ((c (read-char p)))
            (cond
              [(eof-object? c) (list (curr-string))]
              [(eq? c #\$) (cons (curr-string) (port->syntaxes/expr))]
              [(eq? c #\\) (port->syntaxes/escape acc-str)]
              [else (port->syntaxes/str (cons c acc-str))])))

        (define (port->syntaxes/escape acc-str)
          (define (curr-string) (datum->syntax-object val (list->string (reverse (cons #\\ acc-str)))))
          (let ((c (read-char p)))
            (cond
              [(eof-object? c) (list (curr-string))]
              [(eq? c #\$) (port->syntaxes/str (cons #\$ acc-str))]
              [else (port->syntaxes/str (list* c #\\ acc-str))])))

        (define (port->syntaxes/expr)
          (with-handlers 
              ([exn:read? 
                (lambda (e) (raise-syntax-error #f 
                                                "bad expression inside quasistring"
                                                stx
                                                (datum->syntax-object val
                                                                      (syntax-e val)
                                                                      (list 
                                                                       (exn:read-source e)
                                                                       (exn:read-line e)
                                                                       (exn:read-column e)
                                                                       (+ (syntax-position val)
                                                                          (- (exn:read-position e) (syntax-position stx)))
                                                                       (exn:read-span e))
                                                                      #f)))])
            (let* ([string-expr 
                    (read-syntax (syntax-source val)
                                 p
                                 (if (and (syntax-line val) (syntax-column val) (syntax-position val))
                                     (list (syntax-line val)
                                           (syntax-column val)
                                           (+ (syntax-position val) (unbox offset)))
                                     (list 0 0 0)))])
              (if (eof-object? string-expr)
                  (raise-syntax-error #f "no expression follows quasistring delimiter" stx)
                  (cons
                   #`(to-string #,(add-lexical-context string-expr))
                   (port->syntaxes/str '()))))))
        
        (port->syntaxes/str '()))
      
      ; string->strings-and-syntax : string -> listof syntax
      ; given a string, produces a list of syntax objects that when evaluated
      ; produce strings that can be appended to produce the equivalent quasistring value
      (define (string->strings-and-syntax str)
        (let ((p (open-input-string str)))
          (port-count-lines! p)
          (port->syntaxes p)))
      
      (start))
    
    (syntax-case stx ()
      [(_ s) 
       (string? (syntax-e #'s))
       (rewrite #'s)]
      [_ (raise-syntax-error 
          #f
          "not a string"
          stx)])))