#lang scheme/base
(require "base.ss" "depend.ss" "util.ss"
scheme/pretty
)
(define (serialize-tz tz)
(define (span-helper span)
(make-span (if (date? (span-bound span))
(date->*date (span-bound span))
(span-bound span))
(span-std span)
(span-dst span)
(span-year span)
(span-abbr span)))
(make-tz (map span-helper (tz-spans tz))
(tz-rules tz)
(map span-helper (tz-min tz))
))
(define (serialize-tz-abbrs! name tz)
(call-with-output-file (abbr-path)
(lambda (out)
(write (cons name
(filter-not
(lambda (abbr)
(or (equal? abbr "LMT") (equal? abbr "") (regexp-match #px"~a" abbr)))
(list->unique (map span-abbr
(tz-spans tz))))) out))
#:exists 'append))
(define (tz->file! name tz)
(let ((path (zone-path name)))
(make-directory* (parent-path path))
(serialize-tz-abbrs! name tz)
(call-with-output-atomic-file path
(lambda (out)
(pretty-print (serialize-tz tz) out)))))
(define (spans->hash spans (year 2039) (hash (make-immutable-hash '())))
(if (null? spans)
hash
(let ((span (car spans)))
(if (equal? -inf.0 (span-bound span))
hash
(cond ((> year (span-year span))
(spans->hash spans (sub1 year) (hash-set hash year spans)))
((= year (span-year span))
(spans->hash (cdr spans) (sub1 year) (hash-set hash year spans)))
((< year (span-year span))
(spans->hash (cdr spans) year (hash-set hash year spans))))))))
(define (deserialize-tz tz)
(define (span-helper span)
(make-span (if (*date? (span-bound span))
(date->julian-day (*date->date (span-bound span)))
(span-bound span))
(span-std span)
(span-dst span)
(span-year span)
(span-abbr span)))
(make-tz (spans->hash (map span-helper (tz-spans tz)))
(tz-rules tz)
(map span-helper (tz-min tz))))
(define (file->tz name)
(let ((path (zone-path name)))
(call-with-input-file path
(lambda (in)
(deserialize-tz (read in))))))
(provide/contract
(serialize-tz (-> tz? tz?))
(deserialize-tz (-> tz? tz?))
(tz->file! (-> path-string? tz? any))
(file->tz (-> path-string? tz?))
)