#! /bin/sh
#|
exec racket -tm "$0" ${1+"$@"}
|#

#lang racket

;; ---------------------------------------------------------------------------------------------------
;; compare two xml streams 

(provide
 ;; String String -> Boolean 
 ;; effect: spit out distinct XML elements 
 main)

;; if you want to see these messages in error elements
; (define verbose (make-parameter #f))

;; ---------------------------------------------------------------------------------------------------
;; Implementation 

(require xml racket/syntax)

(define (main file1 file2)
  (parameterize ((verbose #false)) ;; set to #t to see error messages 
    (define ip1 (open-file-or-port file1))
    (define ip2 (open-file-or-port file2))
    (if (diff ip1 ip2) 'success '**failure**)))

;; String -> InputPort 
(define (open-file-or-port file1)
  (cond
    [(string=? "-" file1) (current-input-port)]
    [(file-exists? file1) (open-input-file file1)]
    [else (error 'diff-xml "file not found: ~e" file1)]))

;; InputPort InputPort -> Boolean 
(define (diff ip1 ip2)
  (define (diff1 t ip next)
    (let diff1 ([next next])
      (unless (eof-object? next)
        (printf "additional lines in ~a:\n" t)
        (pretty-print next)
        (diff1 (read-xml-from-stdin ip))))
    #f)
  (let diff ([result #t])
    (define in1 (read-xml-from-stdin ip1))
    (define in2 (read-xml-from-stdin ip2))
    (cond
      [(and (eof-object? in1) (eof-object? in2)) result]
      [(eof-object? in1) (diff1 2 ip2 in2)]
      [(eof-object? in2) (diff1 1 ip1 in1)]
      [else (diff (xml-element-diff in1 in2))])))

;; InputPort -> Xexpr 
(define (read-xml-from-stdin ip)
  (with-handlers ((exn:xml? (λ (x) eof)))
    (xml->xexpr ((eliminate-whitespace '() (λ (x) #t)) (read-xml/element ip)))))

;; ---------------------------------------------------------------------------------------------------
;; IMPLEMENTATION of xml-element-diff

(define verbose (make-parameter #f))

;; Xexpr Xexpr -> Boolean 
(define (xml-element-diff x y)
  (define x-tag (first x))
  (define y-tag (first y))
  (cond 
    [(eq? x-tag y-tag) (xml-attribute-diff x-tag (rest x) (rest y))]
    [else (printf "distinct elements:\n")
          (printf "  1: ~e\n" x-tag)
          (printf "  2: ~e\n" y-tag)
          #f]))

;; Xattr = empty | (cons Attributes [Listof Xexpr])
;; SyXattr Xattr -> Boolean 
(define (xml-attribute-diff tag attr+body1 attr+body2)
  (cond
    [(and (empty? attr+body1) (empty? attr+body2)) #t]
    [(empty? attr+body1) 
     (printf "distinct attributes:\n")
     (printf "  1: empty\n")
     (printf "  2: ~e\n" attr+body2)
     #f]
    [(empty? attr+body2)
     (printf "distinct attributes:\n")
     (printf "  1: ~e\n" attr+body1)
     (printf "  2: empty\n")
     #f]
    [else 
     (define-values (x-attr x-err) (normalize-attribute tag (first attr+body1)))
     (define-values (y-attr y-err) (normalize-attribute tag (first attr+body2)))
     (cond
       [(equal? x-attr y-attr) 
        (when (and x-err (verbose))
          (printf "error messages:\n")
          (printf "  1: ~a\n" x-err)
          (printf "  2: ~a\n" y-err))
        (define body1 (rest attr+body1))
        (define body2 (rest attr+body2))
        (cond
          [(= (length body1) (length body2))
           (andmap xml-element-diff body1 body2)]
          [else 
           (printf "distinct element body list:\n")
           (printf "  1: ~e\n" body1)
           (printf "  2: ~e\n" body2)
           #f])]
       [else (printf "distinct attributes:\n")
             (printf "  1: ~e\n" x-attr)
             (printf "  2: ~e\n" y-attr)
             #f])]))

;; Symbol [Listof [List Symbol String]] ->* [Listof [List Symbol (U String Number)]] (U String false)
(define (normalize-attribute tag a)
  (define attr (sort a symbol<=? #:key first))
  (define msg #f)
  (values (for/list ((a attr))
            (define val (second a))
            (cond
              [(eq? 'error tag) (set! msg val) (list (first a) "")]
              [else (define num (string->number val))
                    (list (first a) (or  num val)) #f])) 
          ;; relying on left-to-right order here:
          msg))

;; Symbol Symbol -> Boolean 
(define (symbol<=? s t)
  (string<=? (symbol->string s) (symbol->string t)))
