(module sexp-diffs mzscheme
  (require (lib "pretty.ss")
           (lib "mred.ss" "mred")
           (lib "class.ss")
           (lib "framework.ss" "framework")
           (lib "list.ss")
           (lib "graph.ss" "mrlib")
           (lib "contract.ss"))
  
  (provide show-differences find-differences)
  
  (define (all-but-last l)
    (let loop ([l l])
      (cond
        [(null? (cdr l)) null]
        [else (cons (car l) (loop (cdr l)))])))
  
  (define (record-differences sexp1 sexp2)
    (let ([ht (make-hash-table)])
      ;; loop's result indicates if the sexps are different
      (let loop ([sexp1 sexp1]
                 [sexp2 sexp2])
        (cond
          [(eq? sexp1 sexp2) #f]
          [(and (pair? sexp1)
                (pair? sexp2)
                (equal? (d-length sexp1)
                        (d-length sexp2)))
           (let ([subs-same (map/d loop sexp1 sexp2)])
             (if (and (andmap values subs-same)
                      (not (= 1 (d-length sexp1))))
                 (begin
                   (hash-table-put! ht sexp1 #t)
                   (hash-table-put! ht sexp2 #t)
                   #t)
                 #f))]
          [(equal? sexp1 sexp2) #f]
          [else 
           (hash-table-put! ht sexp1 #t)
           (hash-table-put! ht sexp2 #t)
           #t]))
      ht))
  
  (define (unwrap s)
    (cond
      [(pair? s) (cons (unwrap (car s))
                       (unwrap (cdr s)))]
      [(wrap? s) (wrap-content s)]
      [else s]))
  
  (define (unkink s)
    (let loop ([s s])
      (cond
        [(pair? s) (cons (loop (car s))
                         (loop (cdr s)))]
        [(vector? s)
         (list->vector (map loop (vector->list s)))]
        [(box? s)
         (box (loop (unbox s)))]
        [(number? s) (make-wrap s)]
        [(symbol? s) (make-wrap s)]
        [else s])))
  
  (define-struct wrap (content) (make-inspector))
  
  (define (show-differences orig-s1 orig-s2 columns)
    (let-values ([(to-color-s1 to-color-s2)
                  (find-differences orig-s1 orig-s2 columns columns)])
      (define f (new frame% [label ""] [width 600] [height 500]))
      (define hp (new horizontal-panel% [parent f]))
      (define t1 (new text:basic%))
      (define t2 (new text:basic%))
      (define c1 (new editor-canvas% 
                      [parent hp]
                      [editor t1]))
      (define c2 (new editor-canvas% 
                      [parent hp]
                      [editor t2]))
      (render-sexp/colors orig-s1 to-color-s1 t1 columns)
      (render-sexp/colors orig-s2 to-color-s2 t2 columns)
      (send f show #t)))
  
  (define (find-differences orig-s1 orig-s2 columns1 columns2)
    (let ([s1 (unkink orig-s1)]
          [s2 (unkink orig-s2)])
      (define diff-ht (record-differences s1 s2))
      (values (find-coloring s1 diff-ht columns1)
              (find-coloring s2 diff-ht columns2))))
  
  ;; render-sexp/colors : sexp ht text -> void
  (define (render-sexp/colors sexp to-color text columns)
    (let ([start '()])
      (parameterize ([pretty-print-columns columns]
                     [pretty-print-abbreviate-read-macros #f])
        (pretty-print sexp (open-output-text-editor text)))
      (for-each 
       (λ (p) (send text highlight-range (car p) (cdr p) (send the-color-database find-color "NavajoWhite")))
       to-color)
      (send text change-style 
            (make-object style-delta% 'change-family 'modern)
            0
            (send text last-position))))
  
  (define (find-coloring sexp diff-ht columns)
    (let* ([start '()]
           [to-color '()]
           [pending-bytes (bytes)]
           [position 0]
           [counting-port
            (make-output-port 'counting-port
                              always-evt
                              (λ (bs start end can-block? breaks?)
                                (cond
                                  [(= 0 (bytes-length bs))
                                   0]
                                  [else
                                   (set! pending-bytes (bytes-append pending-bytes (bytes (bytes-ref bs start))))
                                   (let ([str (with-handlers ([exn:fail:contract? (λ (x) #f)])
                                                (bytes->string/utf-8 pending-bytes))])
                                     (when str
                                       (set! position (+ position (string-length str)))
                                       (set! pending-bytes (bytes))))
                                   1]))
                              void)])
      (parameterize ([pretty-print-columns columns]
                     [pretty-print-abbreviate-read-macros #f]
                     [pretty-print-remap-stylable
                      (λ (val)
                        (and (wrap? val)
                             (symbol? (wrap-content val))
                             (wrap-content val)))]
                     [pretty-print-size-hook
                      (λ (val dsp? port)
                        (if (wrap? val)
                            (string-length (format "~s" (wrap-content val)))
                            #f))]
                     [pretty-print-print-hook
                      (λ (val dsp? port)
                        (write (wrap-content val) port))]
                     [pretty-print-pre-print-hook
                      (λ (obj port)
                        (when (hash-table-get diff-ht obj #f)
                          (flush-output port)
                          (set! start (cons position start))))]
                     [pretty-print-post-print-hook
                      (λ (obj port)
                        (when (hash-table-get diff-ht obj #f)
                          (flush-output port)
                          (set! to-color (cons (cons (car start) position) to-color))
                          (set! start (cdr start))))])
        (pretty-print sexp counting-port))
      to-color))
  
  ;; does a map-like operation, but if the list is dotted, flattens the results into an actual list.
  (define (map/d f l1 l2)
    (let loop ([l1 l1]
               [l2 l2])
      (cond
        [(pair? l1)
         (cons (f (car l1) (car l2))
               (loop (cdr l1) (cdr l2)))]
        [(null? l1) null]
        [else (list (f l1 l2))])))
  
  (define (d-length l1)
    (let loop ([l1 l1]
               [n 0])
      (cond
        [(pair? l1) (loop (cdr l1) (+ n 1))]
        [(null? l1) n]
        [else (cons 'dotted (+ n 1))]))))