(module syncheck-debug mzscheme
  (require (lib "pretty.ss")
           (lib "list.ss")
           (lib "class.ss")
           (lib "mred.ss" "mred"))
  
  (provide debug-origin)  ;; : syntax [syntax] -> void
                          ;; creates a frame for examining the 
                          ;; origin and source fields of an expanded sexp
                          ;; also the 'bound-in-source syntax property
  
  (define debug-origin
    (case-lambda 
     [(original-object) (debug-origin original-object (expand original-object))]
     [(original-object expanded-object)
      (define-values (expanded-datum stx-ht) (syntax-object->datum/ht expanded-object))
      
      (define output-text (make-object text%))
      (define output-port (make-text-port output-text))
      (define info-text (make-object text%))
      (define info-port (make-text-port info-text))
      
      ;; assume that there aren't any eq? sub structures, only eq? flat stuff (symbols, etc)
      ;; this is guaranteed by syntax-object->datum/ht
      (define range-start-ht (make-hash-table))
      (define range-ht (make-hash-table))
      (define original-output-port (current-output-port))
      (define (range-pretty-print-pre-hook x v)
        (hash-table-put! range-start-ht x (send output-text last-position)))
      (define (range-pretty-print-post-hook x v)
        (hash-table-put! range-ht x 
                         (cons
                          (cons
                           (hash-table-get range-start-ht x)
                           (send output-text last-position))
                          (hash-table-get range-ht x (λ () null)))))
      
      (define (make-modern text)
        (send text change-style
              (make-object style-delta% 'change-family 'modern)
              0
              (send text last-position)))
      
      (define dummy
        (begin (pretty-print (syntax-object->datum original-object) output-port)
               (newline output-port)
               (parameterize ([current-output-port output-port]
                              [pretty-print-pre-print-hook range-pretty-print-pre-hook]
                              [pretty-print-post-print-hook range-pretty-print-post-hook]
                              [pretty-print-columns 30])
                 (pretty-print expanded-datum))
               (make-modern output-text)))
      
      (define ranges 
        (quicksort 
         (apply append (hash-table-map range-ht (λ (k vs) (map (λ (v) (cons k v)) vs))))
         (λ (x y)
           (<= (- (car (cdr x)) (cdr (cdr x)))
               (- (car (cdr y)) (cdr (cdr y)))))))
      
      (define (show-info stx)
        (fprintf info-port "datum: ~s\nsource: ~a\nposition: ~s\noffset: ~s\noriginal: ~s\nbound-in-source: ~s\n\n"
                 (syntax-object->datum stx)
                 (syntax-source stx)
                 (syntax-position stx)
                 (syntax-span stx)
                 (syntax-original? stx)
                 (syntax-property stx 'bound-in-source))
        (let loop ([origin (syntax-property stx 'origin)])
          (cond
            [(pair? origin)
             (loop (car origin))
             (loop (cdr origin))]
            [(syntax? origin)
             (display "  " info-port)
             (display origin info-port)
             (newline info-port)
             (fprintf info-port
                      "  original? ~a\n  datum:\n  ~a\n\n"
                      (and (syntax? origin) (syntax-original? origin))
                      (and (syntax? origin) (syntax-object->datum origin)))]
            [else (void)])))
      
      (for-each
       (λ (range)
         (let* ([obj (car range)]
                [stx (hash-table-get stx-ht obj)]
                [start (cadr range)]
                [end (cddr range)])
           (when (syntax? stx)
             (send output-text set-clickback start end 
                   (λ _ 
                     (send info-text begin-edit-sequence)
                     (send info-text erase)
                     (show-info stx)
                     (make-modern info-text)
                     (send info-text end-edit-sequence))))))
       ranges)
      
      (newline output-port)
      (newline output-port)
      (let ([before (send output-text last-position)])
        (display "all" output-port)
        (send output-text set-clickback
              before
              (send output-text last-position)
              (λ _
                (send info-text begin-edit-sequence)
                (send info-text erase)
                (for-each (λ (rng)
                            (let ([stx (hash-table-get stx-ht (car rng))])
                              (when (syntax? stx)
                                (show-info stx))))
                          ranges)
                (make-modern info-text)
                (send info-text end-edit-sequence))))
      
      (let ()
        (define f (make-object frame% "Syntax 'origin Browser" #f 600 300))
        (define p (make-object horizontal-panel% f))
        (make-object editor-canvas% p output-text)
        (make-object editor-canvas% p info-text)
        (send f show #t))]))
  
  ;; build-ht : stx -> hash-table
  ;; the resulting hash-table maps from the each sub-object's to it's syntax.
  (define (syntax-object->datum/ht stx)
    (let ([ht (make-hash-table)])
      (values (let loop ([stx stx])
                (let ([obj (syntax-e stx)])
                  (cond
                    [(list? obj) 
                     (let ([res (map loop obj)])
                       (hash-table-put! ht res stx)
                       res)]
                    [(pair? obj) 
                     (let ([res (cons (loop (car obj))
                                      (loop (cdr obj)))])
                       (hash-table-put! ht res stx)
                       res)]
                    [(vector? obj) 
                     (let ([res (list->vector (map loop (vector->list obj)))])
                       (hash-table-put! ht res stx)
                       res)]
                    [else 
                     (let ([res (syntax-object->datum stx)])
                       (hash-table-put! ht res stx)
                       res)])))
              ht)))
  
  ;; make-text-port : text -> port
  ;; builds a port from a text object.  
  (define (make-text-port text)
    (let-values ([(in out) (make-pipe)])
      (thread
       (λ ()
         (let loop ()
           (let ([c (read-char in)])
             (unless (eof-object? c)
               (send text insert (string c)
                     (send text last-position)
                     (send text last-position))
               (loop))))))
      out)))