;;;
;;; Copyright (c) 2006 OOHASHI Daichi, All rights reserved.
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;; 1. Redistributions of source code must retain the above copyright
;;;    notice, this list of conditions and the following disclaimer.
;;;
;;; 2. Redistributions in binary form must reproduce the above copyright
;;;    notice, this list of conditions and the following disclaimer in the
;;;    documentation and/or other materials provided with the distribution.
;;;
;;; 3. Neither the name of the authors nor the names of its contributors
;;;    may be used to endorse or promote products derived from this
;;;    software without specific prior written permission.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS
;;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT
;;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR
;;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT
;;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
;;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED
;;; TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
;;; PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
;;; LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;

(define-module text.plist
  (use srfi-1)
  (use srfi-19)
  (use gauche.collection)
  (use gauche.uvector)
  (use rfc.base64)
  (use sxml.ssax)
  (use sxml.sxpath)
  (use sxml.tools)
  (use text.tree)
  (use util.match)
  (use util.list)
  (export plist-load x->plist-sxml write-as-plist)
  )

(select-module text.plist)

(define *plist-version* "1.0")

(define *plist-doctype*
  "<!DOCTYPE plist PUBLIC \"-//Apple Computer//DTD PLIST 1.0//EN\" \"http://www.apple.com/DTDs/PropertyList-1.0.dtd\">")

(define *date-format* "~Y-~m-~dT~H:~M:~SZ")

(define (plist-load port)
  (let1 sxml (ssax:xml->sxml port '())
    (define (check-type class val)
      (if (is-a? val class)
	  val
	  (errorf "~A required, but got ~A" class val)))
    (let trans ((tree sxml))
      (define unused? symbol?)
      (match tree
	([or [? string?]
	     ([or '@ '*PI* '*COMMENT*] . _)]
	 'unused)
	(([or '*TOP* 'plist] . cs)
	 (car (remove unused? (map trans cs))))
	(('true)    #t)
	(('false)   #f)
	(('string)  "")
	(('string s) s)
	(('array . cs)
	 (remove unused? (map trans cs)))
	(('data c)
	 (string->u8vector (base64-decode-string c)))
	(('date c)
	 (string->date c *date-format*))
	(('real c)
	 (check-type <real> (string->number c 10)))
	(('integer c)
	 (check-type <integer> (string->number c 10)))
	(('dict . cs)
	 (receive (_ alis)
	     (fold2 (lambda (c key rs)
		      (match c
			([? unused?]
			 (values key rs))
			(('key k)
			 (if key
			     (error "missing value for" key)
			     (values k rs)))
			(_
			 (if (not key)
			     (error "missing key for" c)
			     (values #f (alist-cons key (trans c) rs))))))
		    #f '() cs)
	   (alist->hash-table alis 'string=?)))))))

(define (x->plist-sxml x)
  (define (trans obj)
    (cond ((list? obj)
	   `(array ,@(map trans obj)))
	  ((u8vector? obj)
	   `(data ,(base64-encode-string (u8vector->string obj))))
	  ((date? obj)
	   `(date ,(date->string obj *date-format*)))
	  ((hash-table? obj)
	   `(dict ,@(concatenate
		     (hash-table-map obj
		       (lambda (k v)
			 (if (string? k)
			     `((key ,k) ,(trans v))
			     (error "dict key must be string" k)))))))
	  ((integer? obj)
	   `(integer ,(number->string obj)))
	  ((real? obj)
	   `(real ,(number->string (exact->inexact obj))))
	  ((string? obj)
	   (if (string-incomplete? obj)
	       `(data ,(base64-encode-string obj))
	       `(string ,obj)))
	  ((boolean? obj)
	   (if obj '(true) '(false)))
	  (else
	   (error "object cannot be converted to plist" obj))))
  `(*TOP*
    (plist
     (@ (version ,*plist-version*))
     ,(trans x))))

(define (write-as-plist obj . opt)
  (define (tree-trans tree)
    (cond
     ((nodeset? tree)
      (map tree-trans tree))
     ((string? tree)
      (sxml:string->xml tree))
     ((pair? tree)
      (let1 name (sxml:name tree)
	(case name
	  ((*TOP*)
	   `("<?xml version=\"1.0\" encoding=\"utf-8\"?>"
	     "\n"
	     ,*plist-doctype*
	     "\n"
	     ,(tree-trans (sxml:content tree))))
	  ((*PI*)
	   '())
	  (else
	   (let* ((tn (symbol->string name))
		  (content (sxml:content-raw tree)))
	     `("<" ,tn ,(map sxml:attr->xml (sxml:attr-list tree))
	       ,(if (null? content)
		    "\n/>"
		    `(">" ,(tree-trans content) "</" ,tn "\n>"))))))))
     (else (error "unexpected node" tree))))
  (apply write-tree
	 (tree-trans (x->plist-sxml obj))
	 opt))

(provide "text/plist")