racket/collects/stepper/private/xml-snip-helpers.ss

(module xml-snip-helpers mzscheme
  (require xml/xml
           syntax/readerr
           mred
           mzlib/class
           mzlib/list
           "shared.ss")
  
  (provide xml-read-special
           xml-snip<%>
           scheme-read-special
           scheme-snip<%>)
  
  (define (scheme-read-special snip source line col pos)
    (let ([text (send snip get-editor)]
          [splice? (send snip get-splice?)])
      (when (= 0 (send text last-position))
        (raise-read-error 
           (if splice?
               "read: bad syntax: empty scheme splice box"
               "read: bad syntax: empty scheme box")
           source line col pos 1))
      (let* ([source-name (get-source-name text)]
             [stx (read-syntax source-name
                               (open-input-text-editor text 0 'end values source-name))])
        (when (eof-object? stx)
          (raise-read-error
           (if splice?
               "read: bad syntax: empty scheme splice box"
               "read: bad syntax: empty scheme box")
           source-name 1 1 1 (send text last-position)))
	stx)))
  
  (define (get-source-name text)
    (cond
      [(method-in-interface? 'get-port-name (object-interface text))
       (send text get-port-name)]
      [else
       (send text get-filename)]))
  
  (define (xml-read-special eliminate-whitespace-in-empty-tags? snip source line col pos)
    (let ([editor (send snip get-editor)]
          [old-locked #f])
      (when (= 0 (send editor last-position))
        (raise-read-error "read: bad syntax: empty xml box"
                            source line col pos 1))
      (dynamic-wind
       (lambda () 
         (set! old-locked (send editor is-locked?))
         (send editor lock #t))
       (lambda ()
         (let* ([source-name (get-source-name editor)]
                [port (open-input-text-editor editor 0 'end (xml-snip-filter editor) source-name)]
                [xml (read-xml port)]
                [xexpr (xml->xexpr (document-element xml))]
                [clean-xexpr (if eliminate-whitespace-in-empty-tags?
                                 (eliminate-whitespace-in-empty-tags xexpr)
                                 xexpr)]
                [expd-xexpr (expand-embedded clean-xexpr)]
                [qq-body (datum->syntax-object #'here expd-xexpr (list editor #f #f #f #f))])
           (with-syntax ([qq-body qq-body])
             (stepper-syntax-property (syntax (quasiquote qq-body))
                              'stepper-xml-hint
                              'from-xml-box))))
       (lambda () (send editor lock old-locked)))))
  
  (define ((xml-snip-filter text) s)
    (cond
      [(is-a? s scheme-snip<%>)
       (let* ([position (send text get-snip-position s)]
              [line (send text position-paragraph position)]
              [col (- position (send text paragraph-start-position line))])
         (make-wrapped s text line col position))]
      [else s]))
  
  (define scheme-snip<%>
    (interface ()
      get-splice?))
  
  (define xml-snip<%>
    (interface ()))
  
  ;; eliminate-whitespace-in-empty-tags : xexpr -> xexpr
  (define (eliminate-whitespace-in-empty-tags xexpr)
    (cond
      [(and (pair? xexpr)
            (symbol? (car xexpr)))
       (list* (car xexpr)
              (cadr xexpr)
              (map eliminate-whitespace-in-empty-tags
                   (eliminate-whitespace-in-list (cddr xexpr))))]
      [else xexpr]))
  
  ;; wrapped = (make-wraped sexp text number number number)
  (define-struct wrapped (snip text line col pos))
  
  ;; expand-embedded : xexpr -> xexpr
  ;; constructs a new xexpr that has the embedded snips expanded 
  ;; and wrapped with unquotes
  ;; CRUCIAL INVARIANT: an expression must not receive both 'from-xml-box and 'from-scheme/splice-box tags.
  (define (expand-embedded _xexpr)
    (let loop ([xexpr _xexpr])
      (cond
        [(pair? xexpr)
         (cons (loop (car xexpr))
               (loop (cdr xexpr)))]
        [(wrapped? xexpr)
         (let* ([snip (wrapped-snip xexpr)]
                [text (wrapped-text xexpr)]
                [pos (wrapped-pos xexpr)]
                [line (wrapped-line xexpr)]
                [col (wrapped-col xexpr)]
                [raw-stxs (list (send snip read-special text line col pos))])
           (with-syntax ([(stxs ...) raw-stxs])
             (if (and (is-a? snip scheme-snip<%>)
                      (send snip get-splice?))
                 (with-syntax ([err (syntax/loc 
                                     (car (last-pair raw-stxs))
                                     (error 'scheme-splice-box "expected a list, found: ~e" lst))])
                   #`,@#,(stepper-syntax-property #`(let ([lst (begin stxs ...)])
                                              (if (list? lst)
                                                  lst
                                                  err))
                                          'stepper-xml-hint
                                          'from-splice-box))
                 #`,#,(stepper-syntax-property #`(begin stxs ...) 
                                       'stepper-xml-hint
                                       'from-scheme-box))))]
        [else xexpr])))
  
  ;; eliminate-whitespace-in-list (listof xexpr) -> (listof xexpr)
  ;; if each string in xexprs is a whitespace string, remove all strings
  ;; otherwise, return input.
  (define (eliminate-whitespace-in-list xexprs)
    (cond
      [(andmap (lambda (x) (or (not (string? x))
                               (string-whitespace? x)))
               xexprs)
       (filter (lambda (x) (not (string? x))) xexprs)]
      [else xexprs]))
  
  ;; string-whitespace? : string -> boolean
  ;; return #t if the input string consists entirely of whitespace
  (define (string-whitespace? str)
    (let loop ([i (string-length str)])
      (cond
        [(zero? i) #t]
        [(char-whitespace? (string-ref str (- i 1)))
         (loop (- i 1))]
        [else #f])))
  
  
  ;; transformable? : snip -> boolean
  ;; deteremines if a snip can be expanded here
  (define (transformable? snip)
    (or (is-a? snip xml-snip<%>)
        (is-a? snip scheme-snip<%>))))