(module ical mzscheme
  (require "ical-parser.ss"
           (all-except (lib "13.ss" "srfi") string-upcase string-titlecase string-downcase))
  (provide (all-defined))
  
  (define (ical->x-exprs/port port)
    (parse icalvcal-parser icalvcal-lexer port))
  (define (ical->x-exprs/file filename)
    (with-input-from-file filename
      (lambda ()
        (ical->x-exprs/port (current-input-port)))))
  (define (ical->x-exprs/string input-string)
    (ical->x-exprs/port (open-input-string input-string)))
  
  (define (x-exprs->ical x-expr)
    (define MAX-WIDTH 72)
    (define (vobject:attributes->ical attributes)
      (apply string-append
             (map (lambda (pair)
                    (let ([left (car pair)] [right (cadr pair)])
                      (if right
                          (format ";~a=~a" left right)
                          (format ";~a" left))))
                  attributes)))
    (define (vobject:value->ical value length-so-far)
      (let loop ([to-print (format ":~a" value)]
                 [length-so-far length-so-far]
                 [result ""])
        (if (equal? "" to-print)
            (string-drop-right result 1)
            (let ([n-chars (min (string-length to-print)
                                (- MAX-WIDTH length-so-far))])
              (loop (string-drop to-print n-chars)
                    0
                    (string-append result 
                                   (string-take to-print n-chars)
                                   (string #\return #\linefeed #\space)))))))
    (define (vobject->ical x-expr)
      (let* ([_type (car x-expr)]
             [type (if (eq? _type 'VCAL) 'VCALENDAR _type)]
             [content (cdr x-expr)])
        (if (member type `(VCAL VCALENDAR VEVENT VTODO VCARD))
            (string-append
             (format "BEGIN:~a" type)
             (string #\return #\linefeed)
             (apply string-append (map vobject->ical content))
             (format "END:~a" type)
             (string #\return #\linefeed))
            (let* ([has-attributes (and (list? content)
                                        (not (null? content))
                                        (list? (car content)))]
                   [attributes (if has-attributes (car content) (list))]
                   [value (if has-attributes (cadr content) (car content))]
                   [beginning (string-append
                               (format "~a" type)
                               (vobject:attributes->ical attributes))])
              (string-append
               beginning
               (vobject:value->ical value (string-length beginning)))))))
    (apply string-append
           (map vobject->ical x-expr))))