#lang scheme
(require xml)

; a dict is (list 'dict assoc-pair ...)
; an assoc-pair is (list 'assoc-pair key value)
; a key is a string
; a value is either: 
;  a string,
;  a boolean, 
;  an integer : (list 'integer number)
;  a real : (list 'real number)
;  a dict, or
;  an array : (list 'array value ...)
; (we're ignoring data & date)

(define (plist-dict? v)
  (and (list? v)
       (pair? v)
       (eq? (car v) 'dict)
       (andmap (lambda (v)
                 (and (list? v)
                      (= 3 (length v))
                      (eq? (car v) 'assoc-pair)
                      (string? (cadr v))
                      (let pl-value? ([v (caddr v)])
                        (or (string? v)
                            (and (pair? v)
                                 (case (car v)
                                   [(true) (null? (cdr v))]
                                   [(false) (null? (cdr v))]
                                   [(integer) (and (= (length v) 2)
                                                   (exact-integer? (cadr v)))]
                                   [(real) (and (= (length v) 2)
                                                (real? (cadr v)))]
                                   [(array) (andmap pl-value? (cdr v))]
                                   [else (plist-dict? v)]))))))
               (cdr v))))


; raise-plist-exn : string mark-set xexpr symbol -> ???
(define (raise-plist-exn tag mark-set xexpr type)
  (raise (make-exn:fail:contract (string-append "badly formed '" tag "'")
                                 mark-set)))

; expand-dict : xexpr -> xexpr
(define (expand-dict x)
  (cond [(and (eq? (car x) 'dict)
              (map expand-assoc-pair (cdr x)))
         =>
         (lambda (x) `(dict ,@(apply append x)))]
        [else
         (raise-plist-exn "dict" (current-continuation-marks) x 'plist:dict)]))

; expand-assoc-pair : xexpr -> (list xexpr xexpr)
(define (expand-assoc-pair x)
  (cond [(and (eq? (car x) 'assoc-pair)
              (string? (cadr x))
              (expand-value (caddr x)))
         =>
         (lambda (z) `((key ,(cadr x))
                       ,z))]
        [else
         (raise-plist-exn "assoc-pair" (current-continuation-marks) x 'plist:assoc-pair)]))

; expand-value : xexpr -> xexpr
(define (expand-value x)
  (cond [(string? x)
         `(string ,x)]
        [(or (equal? x '(true))
             (equal? x '(false)))
         x]
        [(and (eq? (car x) 'integer)
              (expand-integer x))
         => 
         (lambda (x) x)]
        [(and (eq? (car x) 'real)
              (expand-real x))
         =>
         (lambda (x) x)]
        [(and (eq? (car x) 'dict)
              (expand-dict x))
         =>
         (lambda (x) x)]
        [(and (eq? (car x) 'array)
              (expand-array x))
         =>
         (lambda (x) x)]
        [else
         (raise-plist-exn "value" (current-continuation-marks) x 'plist:value)]))

; expand-real : xexpr -> xexpr
(define (expand-real x)
  (cond [(and (eq? (car x) 'real)
              (real? (cadr x)))
         `(real ,(number->string (cadr x)))]
        [else
         (raise-plist-exn "real" (current-continuation-marks) x 'plist:real)]))

; expand-integer : xexpr -> xexpr
(define (expand-integer x)
  (cond [(and (eq? (car x) 'integer)
              (integer? (cadr x)))
         `(integer ,(number->string (cadr x)))]
        [else
         (raise-plist-exn "integer" (current-continuation-marks) x 'plist:integer)]))

; expand-array : xexpr -> xexpr
(define (expand-array x)
  (cond [(and (eq? (car x) 'array)
              (map expand-value (cdr x)))
         =>
         (lambda (x)
           `(array ,@x))]
        [else
         (raise-plist-exn "array" (current-continuation-marks) x 'plist:array)]))

; dict? tst -> boolean
(define (dict? x)
  (with-handlers [(exn:fail:contract? (lambda (exn) #f))]
    (expand-dict x)
    #t))

; write-plist : xexpr port -> (void)
(define (write-plist xexpr port)
  (let ([plist-xexpr `(plist ,(expand-dict xexpr))])
    (write-xml 
     (make-document (make-prolog (list (make-p-i #f #f 'xml "version=\"1.0\" encoding=\"UTF-8\"")) 
                                 (make-document-type 'plist
                                                     (if (eq? (system-type) 'macosx)
                                                         (make-external-dtd/system 
                                                          "file://localhost/System/Library/DTDs/PropertyList.dtd")
                                                         #f)
                                                     #f)
                                 empty)
                    (xexpr->xml `(plist ((version "0.9"))
                                        ,(expand-dict xexpr)))
                    null)
     port)))


; collapse-dict : xexpr -> dict
(define (collapse-dict x)
  `(dict ,@(collapse-assoc-pairs (cdr x))))

; collapse-assoc-pairs : (listof xexpr) -> (listof assoc-pairs)
(define (collapse-assoc-pairs args)
  (if (null? args)
      null
      (let ([key (car args)]
            [value (cadr args)]
            [rest (cddr args)])
        (cons `(assoc-pair ,(cadr key) ,(collapse-value value))
              (collapse-assoc-pairs rest)))))

; collapse-value : xexpr -> value
(define (collapse-value value)
  (case (car value)
    [(string) (cadr value)]
    [(true false) value]
    [(integer real) (list (car value) (string->number (cadr value)))]
    [(dict) (collapse-dict value)]
    [(array) (collapse-array value)]))

; collapse-array : xexpr -> array
(define (collapse-array xexpr)
  `(array ,@(map collapse-value (cdr xexpr))))

(define tags-without-whitespace
  '(plist dict array))

; read-plist : port -> dict
(define (read-plist port)
  (let* ([xml-doc (read-xml port)]
         [content (parameterize ([xexpr-drop-empty-attributes #t])
                    (xml->xexpr
                     ((eliminate-whitespace tags-without-whitespace (lambda (x) x))
                      (document-element xml-doc))))])
    (unless (eq? (car content) 'plist)
      (error 'read-plist "xml expression is not a plist: ~a" content))
    (collapse-dict (caddr content))))

(provide/contract 
 [plist-dict? (any/c . -> . boolean?)]
 [read-plist (input-port? . -> . plist-dict?)]
 [write-plist (plist-dict? output-port? . -> . void?)])